From 46ea1a5bedcf5d2420c4587b1a1a20d9f054549a Mon Sep 17 00:00:00 2001 From: Daniel Date: Mon, 25 Mar 2024 23:56:09 +0100 Subject: [PATCH 1/5] `data_tabulate()` for crosstables prints NA-proportions when no values are available Fixes #492 --- R/data_xtabulate.R | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/R/data_xtabulate.R b/R/data_xtabulate.R index ef4edeb27..f6ebea22d 100644 --- a/R/data_xtabulate.R +++ b/R/data_xtabulate.R @@ -108,17 +108,23 @@ format.dw_data_xtabulate <- function(x, format = "text", digits = 1, big_mark = tmp <- x if (identical(props, "row")) { for (i in seq_len(nrow(x))) { - tmp[i, -1] <- paste( - format(x[i, -1]), - format(sprintf("(%.*f%%)", digits, 100 * x[i, -1] / sum(x[i, -1], na.rm = TRUE)), justify = "right") - ) + row_sum <- sum(x[i, -1], na.rm = TRUE) + if (row_sum == 0) { + row_sum_string <- "(0%)" + } else { + row_sum_string <- sprintf("(%.*f%%)", digits, 100 * x[i, -1] / row_sum) + } + tmp[i, -1] <- paste(format(x[i, -1]), format(row_sum_string, justify = "right")) } } else if (identical(props, "column")) { for (i in seq_len(ncol(x))[-1]) { - tmp[, i] <- paste( - format(x[, i]), - format(sprintf("(%.*f%%)", digits, 100 * x[, i] / sum(x[, i], na.rm = TRUE)), justify = "right") - ) + row_sum <- sum(x[, i], na.rm = TRUE) + if (row_sum == 0) { + row_sum_string <- "(0%)" + } else { + row_sum_string <- sprintf("(%.*f%%)", digits, 100 * x[, i] / row_sum) + } + tmp[, i] <- paste(format(x[, i]), format(row_sum_string, justify = "right")) } } else if (identical(props, "full")) { for (i in seq_len(ncol(x))[-1]) { From f528848256a66568c26ea4e8790a54cdfde0ebce Mon Sep 17 00:00:00 2001 From: Daniel Date: Mon, 25 Mar 2024 23:58:42 +0100 Subject: [PATCH 2/5] add test --- tests/testthat/test-data_tabulate.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/testthat/test-data_tabulate.R b/tests/testthat/test-data_tabulate.R index 7b78e06b9..5eeaa95dc 100644 --- a/tests/testthat/test-data_tabulate.R +++ b/tests/testthat/test-data_tabulate.R @@ -398,3 +398,10 @@ test_that("data_tabulate, validate against table", { out1[[2]] <- as.character(out1[[2]]) expect_equal(out1, out2, ignore_attr = TRUE) }) + + +test_that("data_tabulate, correct 0% for proportions", { + data(efc, package = "datawizard") + out <- data_tabulate(efc, "c172code", by = "e16sex", proportions = "column") + expect_identical(format(out[[1]])[[4]], c("0 (0%)", "0 (0%)", "0 (0%)", "0 (0%)", "", "0")) +}) From 8a6b8a77006682501dcc46d0bca5535a54922abe Mon Sep 17 00:00:00 2001 From: Daniel Date: Tue, 26 Mar 2024 09:15:02 +0100 Subject: [PATCH 3/5] Update snapshots, add snapshot --- tests/testthat/_snaps/data_tabulate.md | 17 +++++++++++++++-- tests/testthat/test-data_tabulate.R | 1 + 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/tests/testthat/_snaps/data_tabulate.md b/tests/testthat/_snaps/data_tabulate.md index e4b3e8628..49d1a5a69 100644 --- a/tests/testthat/_snaps/data_tabulate.md +++ b/tests/testthat/_snaps/data_tabulate.md @@ -430,7 +430,7 @@ c172code | male | | Total ---------+------------+------------+------ 2 | 2 (100.0%) | 0 (0.0%) | 2 - | 0 (NaN%) | 0 (NaN%) | 0 + | 0 (0%) | 0 (0%) | 0 ---------+------------+------------+------ Total | 2 | 0 | 2 @@ -439,7 +439,7 @@ c172code | male | female | | Total ---------+-----------+-----------+-----------+------ 2 | 2 (50.0%) | 2 (50.0%) | 0 (0.0%) | 4 - | 0 (NaN%) | 0 (NaN%) | 0 (NaN%) | 0 + | 0 (0%) | 0 (0%) | 0 (0%) | 0 ---------+-----------+-----------+-----------+------ Total | 2 | 2 | 0 | 4 @@ -548,3 +548,16 @@ attr(,"class") [1] "knitr_kable" "character" +# data_tabulate, correct 0% for proportions + + Code + print(format(out[[1]])) + Output + c172code male female Total + 1 1 5 (10.9%) 3 (5.6%) 0 (0%) 8 + 2 2 32 (69.6%) 34 (63.0%) 0 (0%) 66 + 3 3 4 (8.7%) 12 (22.2%) 0 (0%) 16 + 4 5 (10.9%) 5 (9.3%) 0 (0%) 10 + rep.....ncol.ftab.. + c..Total...as.character.total_row.. Total 46 54 0 100 + diff --git a/tests/testthat/test-data_tabulate.R b/tests/testthat/test-data_tabulate.R index 5eeaa95dc..750930c11 100644 --- a/tests/testthat/test-data_tabulate.R +++ b/tests/testthat/test-data_tabulate.R @@ -404,4 +404,5 @@ test_that("data_tabulate, correct 0% for proportions", { data(efc, package = "datawizard") out <- data_tabulate(efc, "c172code", by = "e16sex", proportions = "column") expect_identical(format(out[[1]])[[4]], c("0 (0%)", "0 (0%)", "0 (0%)", "0 (0%)", "", "0")) + expect_snapshot(print(format(out[[1]]))) }) From 1a3b44b1cc7a8ffc339e6f40ba6354bda9196e75 Mon Sep 17 00:00:00 2001 From: Daniel Date: Tue, 26 Mar 2024 09:17:13 +0100 Subject: [PATCH 4/5] be accurate --- R/data_xtabulate.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/data_xtabulate.R b/R/data_xtabulate.R index f6ebea22d..0e38c9c07 100644 --- a/R/data_xtabulate.R +++ b/R/data_xtabulate.R @@ -118,13 +118,13 @@ format.dw_data_xtabulate <- function(x, format = "text", digits = 1, big_mark = } } else if (identical(props, "column")) { for (i in seq_len(ncol(x))[-1]) { - row_sum <- sum(x[, i], na.rm = TRUE) - if (row_sum == 0) { - row_sum_string <- "(0%)" + col_sum <- sum(x[, i], na.rm = TRUE) + if (col_sum == 0) { + col_sum_string <- "(0%)" } else { - row_sum_string <- sprintf("(%.*f%%)", digits, 100 * x[, i] / row_sum) + col_sum_string <- sprintf("(%.*f%%)", digits, 100 * x[, i] / col_sum) } - tmp[, i] <- paste(format(x[, i]), format(row_sum_string, justify = "right")) + tmp[, i] <- paste(format(x[, i]), format(col_sum_string, justify = "right")) } } else if (identical(props, "full")) { for (i in seq_len(ncol(x))[-1]) { From eef26dbde44f9fc94011a5fd002b63bd7a68c084 Mon Sep 17 00:00:00 2001 From: Etienne Bacher <52219252+etiennebacher@users.noreply.github.com> Date: Tue, 26 Mar 2024 13:04:49 +0100 Subject: [PATCH 5/5] cleaner snapshot [skip ci] --- tests/testthat/_snaps/data_tabulate.md | 17 +++++++++-------- tests/testthat/test-data_tabulate.R | 2 +- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/tests/testthat/_snaps/data_tabulate.md b/tests/testthat/_snaps/data_tabulate.md index 49d1a5a69..59a20dc01 100644 --- a/tests/testthat/_snaps/data_tabulate.md +++ b/tests/testthat/_snaps/data_tabulate.md @@ -551,13 +551,14 @@ # data_tabulate, correct 0% for proportions Code - print(format(out[[1]])) + print(out[[1]]) Output - c172code male female Total - 1 1 5 (10.9%) 3 (5.6%) 0 (0%) 8 - 2 2 32 (69.6%) 34 (63.0%) 0 (0%) 66 - 3 3 4 (8.7%) 12 (22.2%) 0 (0%) 16 - 4 5 (10.9%) 5 (9.3%) 0 (0%) 10 - rep.....ncol.ftab.. - c..Total...as.character.total_row.. Total 46 54 0 100 + c172code | male | female | | Total + ---------+------------+------------+--------+------ + 1 | 5 (10.9%) | 3 (5.6%) | 0 (0%) | 8 + 2 | 32 (69.6%) | 34 (63.0%) | 0 (0%) | 66 + 3 | 4 (8.7%) | 12 (22.2%) | 0 (0%) | 16 + | 5 (10.9%) | 5 (9.3%) | 0 (0%) | 10 + ---------+------------+------------+--------+------ + Total | 46 | 54 | 0 | 100 diff --git a/tests/testthat/test-data_tabulate.R b/tests/testthat/test-data_tabulate.R index 750930c11..32a869b2a 100644 --- a/tests/testthat/test-data_tabulate.R +++ b/tests/testthat/test-data_tabulate.R @@ -404,5 +404,5 @@ test_that("data_tabulate, correct 0% for proportions", { data(efc, package = "datawizard") out <- data_tabulate(efc, "c172code", by = "e16sex", proportions = "column") expect_identical(format(out[[1]])[[4]], c("0 (0%)", "0 (0%)", "0 (0%)", "0 (0%)", "", "0")) - expect_snapshot(print(format(out[[1]]))) + expect_snapshot(print(out[[1]])) })