Merge pull request #172 from atorus-research/gh_issue_146

R/count_bindings.R

@@ -12,6 +12,10 @@
 #' use \code{set_denoms_by()}, and the grouping of \code{add_total_row()} will
 #' be updated accordingly.
 #'
+#' Note that when using \code{add_total_row()} with \code{set_pop_data()}, you
+#' should call \code{add_total_row()} AFTER calling \code{set_pop_data()},
+#' otherwise there is potential for unexpected behaivior with treatment groups.
+#'
 #' @param e A \code{count_layer} object
 #' @param fmt An f_str object used to format the total row. If none is provided,
 #' display is based on the layer formatting.

R/nested.R

@@ -8,14 +8,6 @@ process_nested_count_target <- function(x) {
  assert_that(quo_is_symbol(target_var[[2]]),
  msg = "Inner layers must be data driven variables")
 
- if(quo_is_symbol(target_var[[1]])){
- first_var_length <- length(unique(target[[as_name(target_var[[1]])]]))
- second_var_length <- length(unique(target[[as_name(target_var[[2]])]]))
-
- assert_that(second_var_length >= first_var_length,
- msg = "The number of values of your second variable must be greater than the number of levels in your first variable")
- }
-
  if(is.factor(target[[as_name(target_var[[1]])]])) {
  warning(paste0("Factors are not currently supported in nested count layers",
  " that have two data driven variables. Factors will be coerced into character vectors"),

R/pop_data.R

@@ -36,27 +36,33 @@ build_header_n <- function(table) {
 
 #' Combine existing treatment groups for summary
 #'
-#' Summary tables often present individual treatment groups,
-#' but may additionally have a "Treatment vs. Placebo" or "Total" group added
-#' to show grouped summary statistics or counts. This set of functions offers
-#' an interface to add these groups at a table level and be consumed by
-#' subsequent layers.
+#' Summary tables often present individual treatment groups, but may
+#' additionally have a "Treatment vs. Placebo" or "Total" group added to show
+#' grouped summary statistics or counts. This set of functions offers an
+#' interface to add these groups at a table level and be consumed by subsequent
+#' layers.
 #'
 #' \code{add_treat_grps} allows you to specify specific groupings. This is done
-#' by supplying named arguments, where the name becomes the new treatment group's
-#' name, and those treatment groups are made up of the argument's values.
+#' by supplying named arguments, where the name becomes the new treatment
+#' group's name, and those treatment groups are made up of the argument's
+#' values.
 #'
-#' \code{add_total_group} is a simple wrapper around \code{add_treat_grps}. Instead of
-#' producing custom groupings, it produces a "Total" group by the supplied name, which
-#' defaults to "Total". This "Total" group is made up of all existing treatment
-#' groups within the population dataset.
+#' \code{add_total_group} is a simple wrapper around \code{add_treat_grps}.
+#' Instead of producing custom groupings, it produces a "Total" group by the
+#' supplied name, which defaults to "Total". This "Total" group is made up of
+#' all existing treatment groups within the population dataset.
 #'
-#' The function \code{treat_grps} allows you to see the custom treatment groups available
-#' in your \code{tplyr_table} object
+#' Note that when using \code{add_treat_grps} or \code{add_total_row()} with
+#' \code{set_pop_data()}, you should call \code{add_total_row()} AFTER calling
+#' \code{set_pop_data()}, otherwise there is potential for unexpected behaivior
+#' with treatment groups.
+#'
+#' The function \code{treat_grps} allows you to see the custom treatment groups
+#' available in your \code{tplyr_table} object
 #'
 #' @param table A \code{tplyr_table} object
-#' @param ... A named vector where names will become the new treatment group names,
-#' and values will be used to construct those treatment groups
+#' @param ... A named vector where names will become the new treatment group
+#'  names, and values will be used to construct those treatment groups
 #'
 #' @return The modified table object
 #' @export

R/sort.R

@@ -207,7 +207,7 @@ add_order_columns.count_layer <- function(x) {
 
  # Add the ordering of the pieces in the layer
  formatted_data <- formatted_data %>%
- group_by(.data[[paste0("ord_layer_", formatted_col_index - 1)]]) %>%
+ group_by(.data[[paste0("row_label", formatted_col_index - 1)]]) %>%
  do(add_data_order_nested(., formatted_col_index - 1, numeric_data,
  indentation_length = indentation_length,
  ordering_cols = ordering_cols,
@@ -724,10 +724,11 @@ add_data_order_nested <- function(group_data, final_col, numeric_data, ...) {
  }
 
  present_vars <- unlist(group_data[-1, row_label_vec[length(row_label_vec)]])
+
  ##### Inner nest values #####
  filtered_numeric_data <- numeric_data %>%
  # Only include the parts of the numeric data that is in the current label
- filter(numeric_data$summary_var %in% present_vars, !is.na(!!by[[1]])) %>%
+ filter(numeric_data$summary_var %in% present_vars, !!by[[1]] == outer_value) %>%
  # Remove nesting prefix to prepare numeric data.
  mutate(summary_var := str_sub(summary_var, indentation_length))
 

tests/testthat/_snaps/count.md

@@ -209,11 +209,21 @@
   8 2 ( 50.0%) 0 ( 0.0%) 1 3 1
   9 0 ( 0.0%) 0 ( 0.0%) 1 3 2
 
-# nested count layers will error out if second variable is bigger than the first
+# nested count can accept data if second variable is bigger than the first
 
- i In index: 1.
- Caused by error:
- ! The number of values of your second variable must be greater than the number of levels in your first variable
+ Code
+  x
+ Output
+  row_label1 row_label2 var1_TRT1
+  1 Antiemetics and antinauseants Antiemetics and antinauseants 1 ( 50.0%)
+  2 Antiemetics and antinauseants Promethazine hydrochloride 1 ( 50.0%)
+  3 Psycholeptics Psycholeptics 1 ( 50.0%)
+  4 Psycholeptics Promethazine hydrochloride 1 ( 50.0%)
+  var1_TRT2 ord_layer_index ord_layer_1 ord_layer_2
+  1 0 ( 0.0%) 1 1 Inf
+  2 0 ( 0.0%) 1 1 1
+  3 1 (100.0%) 1 2 Inf
+  4 1 (100.0%) 1 2 1
 
 # set_numeric_threshold works as expected
 

tests/testthat/test-count.R

@@ -722,16 +722,23 @@ test_that("test specific rounding proplem #124", {
  options(tplyr.IBMRounding = FALSE)
 })
 
-test_that("nested count layers will error out if second variable is bigger than the first", {
- mtcars <- mtcars2
- mtcars$grp <- paste0("grp.", as.numeric(mtcars$cyl) + rep(c(0, 0.5), 16))
+test_that("nested count can accept data if second variable is bigger than the first", {
+ test_adcm <- data.frame(
+ SUBJID = c("1", "2", "3"),
+ ATC2 = c("Antiemetics and antinauseants", "Psycholeptics", "Psycholeptics"),
+ CMDECOD = c("Promethazine hydrochloride", "Promethazine hydrochloride", "Promethazine hydrochloride"),
+ TRT101A = c("TRT1", "TRT2", "TRT1")
+ )
 
- t <- tplyr_table(mtcars, gear) %>%
+ x <- test_adcm %>%
+ tplyr_table(TRT101A) %>%
  add_layer(
- group_count(vars(grp, cyl))
- )
+ group_count(vars(ATC2, CMDECOD))
+ ) %>%
+ build() %>%
+ as.data.frame()
 
- expect_snapshot_error(build(t))
+ expect_snapshot(x)
 })
 
 test_that("Posix columns don't cause the build to error out.", {
@@ -898,6 +905,9 @@ test_that("nested count layers error out when you try to add a total row", {
  )
 
  expect_snapshot_error(build(tab))
+
+ # The weird use of mtcars2 makes us have to overwrite this again
+ mtcars <- mtcars2
 })
 
 test_that("Tables with pop_data can accept a layer level where", {