Changes from GOSL reporting

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

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.

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,19 +136,42 @@ 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]]))
   }))
   col_spanners[col_spanners == col_labels] <- NA_character_
   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),

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
+}

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", {
   )
 })
 
+
+
+