diff --git a/DESCRIPTION b/DESCRIPTION index efd2a72..da17b84 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,13 +1,11 @@ Package: projectable Title: Metadata-Rich Tables -Version: 0.0.6 -Authors@R: - c(person(given = "Kinto", - family = "Behr", - role = c("aut", "cre"), - email = "kinto.behr@srcentre.com.au"), - person(given = "The Social Research Centre", - role = "cph")) +Version: 0.0.7 +Authors@R: c( + person(given = "Kinto", family = "Behr", role = c("aut", "cre"), email = "kinto.behr@srcentre.com.au"), + person("Paddy", "Tobias", , "paddy.tobias@srcentre.com.au", role = "aut"), + person(given = "The Social Research Centre", role = "cph") + ) Description: Produce table-like objects made up of special metadata-rich column vectors, and project them into two dimensions. License: GPL-3 @@ -22,16 +20,16 @@ Imports: glue, stats, rlang, - tidyselect + tidyselect, + srcutils Suggests: testthat, gt, knitr, rmarkdown, - dplyr, flextable Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.3 VignetteBuilder: knitr diff --git a/NEWS.md b/NEWS.md index cb2c7e2..0e0b27e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,28 @@ +# projectable (development version) + +* Enhancing `prj_cast_shadow()` to allow the user to specify a label in the shadow definition, e.g., `n = "{dec_dig3(100*p, 2)}"`, will give the label a title of "n". If the shadow is unnamed, then, there won't be a spanner row in the formatted table. Where column names are duplicated, then a warning will be thrown and handled internally by incrementing the column names. + +``` + +tbl <- mtcars %>% + prj_tbl_rows( + Cylinders = cyl, + Transmission = list(Automatic = am %in% 0, Manual = am %in% 1), + ) %>% + prj_tbl_cols( + `V-Shaped` = col_freq(n = vs %in% 1, N = vs %in% 0:1), + `Not V-shaped` = col_freq(n = vs %in% 0, N = vs %in% 0:1) + ) %>% + prj_tbl_summarise() + +tbl %>% + prj_project(list( + `V-Shaped` = c(p = "{signif(p, 2)} ({n})"), + `Not V-shaped` = c(p = "{signif(p, 2)} ({n})") + )) + +``` + # projectable 0.0.6 * Deprecated `spec_col_freq()`. This function was implemented in a fairly unsafe way. It is being dropped without deprecation since it is purely a convenience function, the usefulness of which is limited anyway. diff --git a/R/prj_project.R b/R/prj_project.R index 6bb59bc..ac40528 100644 --- a/R/prj_project.R +++ b/R/prj_project.R @@ -49,6 +49,35 @@ #' `Not V-shaped` = "{signif(p, 2)} ({n})" #' )) #' +#' # With renamed columns +#' prj_project(my_tbl, list( +#' `V-Shaped` = c(`V-Shaped %` = "{signif(p, 2)} ({n})"), +#' `Not V-shaped` = c(`Not V-Shaped %` = "{signif(p, 2)} ({n})") +#' )) +#' +#' # With same renamed columns +#' ## Due to duplicate `%` as column names, these will be incremented +#' prj_project(my_tbl, list( +#' `V-Shaped` = c(`%` = "{signif(p, 2)} ({n})"), +#' `Not V-shaped` = c(`%` = "{signif(p, 2)} ({n})") +#' )) +#' +#' +#' # With multiple renamed columns +#' prj_project(my_tbl, list( +#' `V-Shaped` = c(`%` = "{signif(p, 2)} ({n})", `n` = "{n}"), +#' `Not V-shaped` = c(`%` = "{signif(p, 2)} ({n})", `n` = "{n}") +#' )) +#' +#' # A mix of some multiple renamed columns, and not renamed columns +#' prj_project( +#' my_tbl, list( +#' `V-Shaped` = c("{signif(p, 2)} ({n})"), +#' `Not V-shaped` = c(p = "{signif(p, 2)} ({n})", n = "{n}") +#' ) +#' ) +#' +#' #' # Produce a `gt` display object #' out <- prj_gt(my_tbl, list( #' `V-Shaped` = "{signif(p, 2)} ({n})", @@ -61,6 +90,7 @@ #' `Not V-shaped` = "{signif(p, 2)} ({n})" #' )) #' +#' #' @name prj_project # Project table ---------------------------------------------------------------- prj_project <- function(.data, .cols = list(), .digits = getOption("prj_digits")) { @@ -82,7 +112,7 @@ prj_cast_shadow <- function(.data, .digits = NULL) { out <- glue_each_in(col_shadow(col_i), col_i) } - if (length(out) > 1) { + if (length(out) > 1 | (!is_col_row(col_i) & !is.null(names(out)))) { out <- do.call(vctrs::vec_cbind, out) } else if (length(out) == 1){ out <- data.frame(out[[1]], stringsAsFactors = FALSE) @@ -106,6 +136,8 @@ prj_cast_shadow <- function(.data, .digits = NULL) { if(is.null(col_labels)) col_labels <- character(0) names(col_labels) <- NULL + + col_spanners <- unlist(lapply(names(out), function (x) { rep(x, ncol(out[[x]])) })) @@ -113,12 +145,33 @@ prj_cast_shadow <- function(.data, .digits = NULL) { names(col_spanners) <- NULL col_names <- paste(col_spanners, col_labels, sep = ".") - col_names[is.na(col_spanners)] <- col_labels[is.na(col_spanners)] + + col_names[is.na(col_spanners) | col_spanners == col_labels] <- col_labels[is.na(col_spanners) | col_spanners == col_labels] names(col_names) <- NULL + + # Output out <- do.call(cbind, out) + # Renaming duplicated column names + if (any(duplicated(names(out)))) { + warning("\nColumn name duplicated: `", names(out)[duplicated(names(out))], + "`\nResolving by incrementing...", call. = FALSE) + + which_dups <- which(names(out) == names(out)[duplicated(names(out))]) + rename_dups <- paste0(names(out)[which(names(out) == names(out)[duplicated(names(out))])], + seq_len(length(which(names(out) == names(out)[duplicated(names(out))])))) + + + col_labels[which_dups] <- rename_dups + + mapply(function(elem, i) { + names(out)[elem] <<- rename_dups[i] + }, which_dups, seq_len(length(which_dups))) + + } + validate_projection( new_projection( tibble::as_tibble(out), diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..a5efdc2 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,33 @@ + + +#' Make sure the lengths of two vectors are the same. +#' +#' Recycle `x` to match length of `to`; throw an error if this is not possible. +#' +#' Copied from `srcsample`. +#' +#' @param x A vector +#' @param to Another vector +#' @param stop_on_fail A logical determining whether or not an error is thrown +#' +#' @return `x` recycled to have a length matching that of `to` +#' @keywords internal +#' @noRd +match_lengths <- function(x, to, stop_on_fail = TRUE) { + stopifnot(is.atomic(x)) + stopifnot(is.atomic(to)) + if (length(x) == length(to)) return(x) + x_name <- deparse(substitute(x)) + to_name <- deparse(substitute(to)) + + if (length(x) == 1) { + x <- rep(x, length(to)) + } else if (stop_on_fail) { + stop(paste0( + "Cannot recycle `", x_name, "` (length ", length(x), ") ", + "to match `", to_name, "` (length ", length(to), ")" + ), call. = FALSE) + } + + x +} diff --git a/man/prj_project.Rd b/man/prj_project.Rd index 0f13248..6ce320b 100644 --- a/man/prj_project.Rd +++ b/man/prj_project.Rd @@ -76,6 +76,35 @@ prj_project(my_tbl, list( `Not V-shaped` = "{signif(p, 2)} ({n})" )) +# With renamed columns +prj_project(my_tbl, list( + `V-Shaped` = c(`V-Shaped \%` = "{signif(p, 2)} ({n})"), + `Not V-shaped` = c(`Not V-Shaped \%` = "{signif(p, 2)} ({n})") +)) + +# With same renamed columns +## Due to duplicate `\%` as column names, these will be incremented +prj_project(my_tbl, list( + `V-Shaped` = c(`\%` = "{signif(p, 2)} ({n})"), + `Not V-shaped` = c(`\%` = "{signif(p, 2)} ({n})") +)) + + +# With multiple renamed columns +prj_project(my_tbl, list( + `V-Shaped` = c(`\%` = "{signif(p, 2)} ({n})", `n` = "{n}"), + `Not V-shaped` = c(`\%` = "{signif(p, 2)} ({n})", `n` = "{n}") +)) + +# A mix of some multiple renamed columns, and not renamed columns +prj_project( + my_tbl, list( + `V-Shaped` = c("{signif(p, 2)} ({n})"), + `Not V-shaped` = c(p = "{signif(p, 2)} ({n})", n = "{n}") + ) +) + + # Produce a `gt` display object out <- prj_gt(my_tbl, list( `V-Shaped` = "{signif(p, 2)} ({n})", @@ -88,4 +117,5 @@ out <- prj_flex(my_tbl, list( `Not V-shaped` = "{signif(p, 2)} ({n})" )) + } diff --git a/man/projectable-package.Rd b/man/projectable-package.Rd index 20224ed..1294f0d 100644 --- a/man/projectable-package.Rd +++ b/man/projectable-package.Rd @@ -20,6 +20,11 @@ Useful links: \author{ \strong{Maintainer}: Kinto Behr \email{kinto.behr@srcentre.com.au} +Authors: +\itemize{ + \item Paddy Tobias \email{paddy.tobias@srcentre.com.au} +} + Other contributors: \itemize{ \item The Social Research Centre [copyright holder] diff --git a/tests/testthat/test-prj_project.R b/tests/testthat/test-prj_project.R index 7b6bf28..3c4590e 100644 --- a/tests/testthat/test-prj_project.R +++ b/tests/testthat/test-prj_project.R @@ -67,6 +67,85 @@ testthat::test_that("prj_project metadata", { ) }) + +testthat::test_that("prj_project handling duplicate column names", { + + + + dat <- prj_tbl_rows(mtcars, + Cylinders = cyl, + Transmission = list(Automatic = am %in% 0, Manual = am %in% 1), + ) + + dat <- prj_tbl_summarise( + prj_tbl_cols(dat, + `V-Shaped` = col_freq(n = vs %in% 1, N = vs %in% 0:1), + `Not V-shaped` = col_freq(n = vs %in% 0, N = vs %in% 0:1) + )) + + testthat::expect_warning( + + testthat::expect_true( + all( + names( + prj_project( + dat, list( + `V-Shaped` = c(p = "{signif(p, 2)} ({n})"), + `Not V-shaped` = c(p = "{signif(p, 2)} ({n})") + ) + ) + )[3:4] == c("p1", "p2") + ) + ) + + ) + + # A mix of multiple columns, and a single column + + all( + names( + prj_project( + dat, list( + `V-Shaped` = c("{signif(p, 2)} ({n})"), + `Not V-shaped` = c(p = "{signif(p, 2)} ({n})", n = "{n}") + ) + ) + )[3:5] == c("V-Shaped", "Not V-shaped.p", "Not V-shaped.n") + ) + + +}) + + +test_that("prj_project formatting retained", { + + options("prj_digits" = NULL) + + dat <- prj_tbl_rows(mtcars, + Cylinders = cyl, + Transmission = list(Automatic = am %in% 0, Manual = am %in% 1), + ) + + dat <- prj_tbl_summarise( + prj_tbl_cols(dat, + `V-Shaped` = col_freq(n = vs %in% 1, N = vs %in% 0:1), + `Not V-shaped` = col_freq(n = vs %in% 0, N = vs %in% 0:1) + )) + + + dat <- prj_project( + dat, list( + `V-Shaped` = c(p = "{dec_dig3(p, 2)}") + ) + ) + + expect_equal(dat[dat$row_spanner == "Cylinders" & dat$rows == 8, 3][[1]], "0.00") + + + +}) + + # proje_gt ---------------------------------------------------------------- y <- prj_tbl_rows(mtcars, cyl) y <- prj_tbl_cols(y, v = col_freq(vs %in% 1, vs %in% 0:1)) @@ -153,3 +232,6 @@ testthat::test_that("prj_flex", { ) }) + + +