Enable passing named vector of col_decimals to summary.gs_design()

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: gsDesign2
 Title: Group Sequential Design with Non-Constant Effect
-Version: 1.1.2.13
+Version: 1.1.2.14
 Authors@R: c(
     person("Keaven", "Anderson", email = "keaven_anderson@merck.com", role = c("aut")),
     person("Yilong", "Zhang", email = "elong0527@gmail.com", role = c("aut")),

R/summary.R

@@ -152,6 +152,9 @@ summary.fixed_design <- function(object, ...) {
 #'   variables you want to be displayed differently than the defaults.
 #' @param col_vars The variables to be displayed.
 #' @param col_decimals The decimals to be displayed for the displayed variables in `col_vars`.
+#'   If the vector is unnamed, it must match the length of `col_vars`. If the
+#'   vector is named, you only have to specify the number of digits for the
+#'   columns you want to be displayed differently than the defaults.
 #' @param bound_names Names for bounds; default is `c("Efficacy", "Futility")`.
 #'
 #' @importFrom dplyr all_of
@@ -240,6 +243,16 @@ summary.fixed_design <- function(object, ...) {
 #'
 #' # Customize the variables to be summarized for each analysis
 #' x_ahr %>% summary(analysis_vars = c("n", "event"), analysis_decimals = c(1, 1))
+#'
+#' # Customize the digits for the columns
+#' x_ahr %>% summary(col_decimals = c(z = 4))
+#'
+#' # Customize the columns to display
+#' x_ahr %>% summary(col_vars = c("z", "~hr at bound", "nominal p"))
+#'
+#' # Customize columns and digits
+#' x_ahr %>% summary(col_vars = c("z", "~hr at bound", "nominal p"),
+#'                   col_decimals = c(4, 2, 2))
 #' }
 #'
 #' # Example 2 ----
@@ -315,60 +328,81 @@ summary.gs_design <- function(object,
 
   # Prepare the columns decimals ----
   if (method == "ahr") {
-    if (is.null(col_vars) && is.null(col_decimals)) {
-      x_decimals <- tibble::tibble(
-        col_vars = c("analysis", "bound", "z", "~hr at bound", "nominal p", "Alternate hypothesis", "Null hypothesis"),
-        col_decimals = c(NA, NA, 2, 4, 4, 4, 4)
-      )
-    } else {
-      x_decimals <- tibble::tibble(col_vars = col_vars, col_decimals = col_decimals)
-    }
-  }
-
-  if (method == "wlr") {
-    if (is.null(col_vars) && is.null(col_decimals)) {
-      x_decimals <- tibble::tibble(
-        col_vars = c("analysis", "bound", "z", "~whr at bound", "nominal p", "Alternate hypothesis", "Null hypothesis"),
-        col_decimals = c(NA, NA, 2, 4, 4, 4, 4)
-      )
-    } else {
-      x_decimals <- tibble::tibble(col_vars = col_vars, col_decimals = col_decimals)
-    }
+    col_vars_default <- c(
+      "analysis", "bound", "z", "~hr at bound", "nominal p",
+      "Alternate hypothesis", "Null hypothesis"
+    )
+    col_decimals_default <- c(NA, NA, 2, 4, 4, 4, 4)
+  } else if (method == "wlr") {
+    col_vars_default <- c(
+      "analysis", "bound", "z", "~whr at bound", "nominal p",
+      "Alternate hypothesis", "Null hypothesis"
+    )
+    col_decimals_default <- c(NA, NA, 2, 4, 4, 4, 4)
+  } else if (method == "combo") {
+    col_vars_default <- c(
+      "analysis", "bound", "z", "nominal p",
+      "Alternate hypothesis", "Null hypothesis"
+    )
+    col_decimals_default <- c(NA, NA, 2, 4, 4, 4)
+  } else if (method == "rd") {
+    col_vars_default <- c(
+      "analysis", "bound", "z", "~risk difference at bound",
+      "nominal p", "Alternate hypothesis", "Null hypothesis"
+    )
+    col_decimals_default <- c(NA, NA, 2, 4, 4, 4, 4)
+  } else {
+    stop("Invalid method: ", method)
   }
 
-  if (method == "combo") {
-    if (is.null(col_vars) && is.null(col_decimals)) {
-      x_decimals <- tibble::tibble(
-        col_vars = c("analysis", "bound", "z", "nominal p", "Alternate hypothesis", "Null hypothesis"),
-        col_decimals = c(NA, NA, 2, 4, 4, 4)
-      )
-    } else {
-      x_decimals <- tibble::tibble(col_vars = col_vars, col_decimals = col_decimals)
+  # Filter columns and update decimal places
+  names(col_decimals_default) <- col_vars_default
+  if (is.null(col_vars) && is.null(col_decimals)) {
+    # Use default values
+    col_vars <- col_vars_default
+    col_decimals <- col_decimals_default
+  } else if (!is.null(col_vars) && is.null(col_decimals)) {
+    # Only drop/rearrange variables
+    col_decimals <- col_decimals_default[
+      match(col_vars, names(col_decimals_default))
+    ]
+  } else if (is.null(col_vars) && !is.null(col_decimals)) {
+    # Only update decimals - must be named vector
+    if (is.null(names(col_decimals))) {
+      stop("summary: col_decimals must be a named vector if col_vars is not provided")
     }
-  }
-
-  if (method == "rd") {
-    if (is.null(col_vars) && is.null(col_decimals)) {
-      x_decimals <- tibble::tibble(
-        col_vars = c(
-          "analysis", "bound", "z", "~risk difference at bound",
-          "nominal p", "Alternate hypothesis", "Null hypothesis"
-        ),
-        col_decimals = c(NA, NA, 2, 4, 4, 4, 4)
-      )
+    col_vars <- col_vars_default
+    col_decimals_tmp <- col_decimals_default
+    col_decimals_tmp[names(col_decimals)] <- col_decimals
+    col_decimals <- col_decimals_tmp
+  } else if (!is.null(col_vars) && !is.null(col_decimals)) {
+    # Update variables and decimals
+    if (is.null(names(col_decimals))) {
+      # vectors must be same length if col_decimals is unnamed
+      if (length(col_vars) != length(col_decimals)) {
+        stop("summary: please input col_vars and col_decimals in pairs!")
+      }
     } else {
-      x_decimals <- tibble::tibble(col_vars = col_vars, col_decimals = col_decimals)
+      col_decimals_tmp <- col_decimals_default
+      col_decimals_tmp[names(col_decimals)] <- col_decimals
+      col_decimals <- col_decimals_tmp
+      col_decimals <- col_decimals[
+        match(col_vars, names(col_decimals))
+      ]
     }
   }
 
   # "bound" is a required column
-  if (!"bound" %in% x_decimals$col_vars) {
-    x_decimals <- rbind(
-      tibble::tibble(col_vars = "bound", col_decimals = NA),
-      x_decimals
-    )
+  if (!"bound" %in% col_vars) {
+    col_vars <- c("bound", col_vars)
+    col_decimals <- c(NA, col_decimals)
   }
 
+  x_decimals <- tibble::tibble(
+    col_vars = col_vars,
+    col_decimals = col_decimals
+  )
+
   # Prepare the analysis summary row ----
   # get the
   # (1) analysis variables to be displayed on the header

tests/testthat/test-developer-summary.R

@@ -150,7 +150,6 @@ test_that("The column 'Bound' is always included in summary.gs_design() output",
   expect_true("Bound" %in% colnames(observed))
 })
 
-
 test_that("The full alpha is correctly carried over", {
   a_level <- 0.02
   x <- gs_power_ahr(
@@ -166,4 +165,125 @@ test_that("The full alpha is correctly carried over", {
   observed <- summary(x)
 
   expect_equal(attributes(observed)$full_alpha, a_level)
-})
+})
+
+# Maintain previous behavior
+test_that("summary.gs_design() accepts same-length vectors for col_vars and col_decimals", {
+  x <- gs_design_ahr()
+
+  # default decimals
+  x_sum <- summary(x)
+  observed <- as.data.frame(x_sum)[, -1:-2]
+  expected <- data.frame(
+    Z = 1.96,
+    `~HR at bound` = 0.795,
+    `Nominal p` = 0.025,
+    `Alternate hypothesis` = 0.9,
+    `Null hypothesis` = 0.025,
+    check.names = FALSE
+  )
+  expect_equal(observed, expected)
+
+  # specify the decimals for each variable
+  x_sum <- summary(
+    x,
+    col_vars = c("z", "~hr at bound", "nominal p", "Alternate hypothesis", "Null hypothesis"),
+    col_decimals = c(0, 0, 0, 0, 0)
+  )
+  observed <- as.data.frame(x_sum)[, -1:-2]
+  expected <- data.frame(
+    Z = 2,
+    `~HR at bound` = 1,
+    `Nominal p` = 0,
+    `Alternate hypothesis` = 1,
+    `Null hypothesis` = 0,
+    check.names = FALSE
+  )
+  expect_equal(observed, expected)
+
+  # Drop variables and also specify the decimals
+  x_sum <- summary(
+    x,
+    col_vars = c("nominal p", "Null hypothesis"),
+    col_decimals = c(0, 0)
+  )
+  observed <- as.data.frame(x_sum)[, -1:-2]
+  expected <- data.frame(`Nominal p` = 0, `Null hypothesis` = 0, check.names = FALSE)
+  expect_equal(observed, expected)
+
+  # Rearrange variables
+  x_sum <- summary(
+    x,
+    col_vars = c("Null hypothesis", "Alternate hypothesis", "nominal p", "~hr at bound", "z"),
+    col_decimals = c(0, 0, 0, 0, 0)
+  )
+  observed <- as.data.frame(x_sum)[, -1:-2]
+  expected <- data.frame(
+    `Null hypothesis` = 0,
+    `Alternate hypothesis` = 1,
+    `Nominal p` = 0,
+    `~HR at bound` = 1,
+    Z = 2,
+    check.names = FALSE
+  )
+  expect_equal(observed, expected)
+
+  # Throw error if unnamed col_decimals does not match length of col_vars
+  expect_error(
+    summary(
+      x,
+      col_vars = c("Null hypothesis", "Alternate hypothesis", "nominal p"),
+      col_decimals = c(0, 0),
+    ),
+    "summary: please input col_vars and col_decimals in pairs!"
+  )
+})
+
+test_that("summary.gs_design() accepts a named vector for col_decimals", {
+  x <- gs_design_ahr()
+
+  # Specify decimals
+  x_sum <- summary(x, col_decimals = c(z = 0, `nominal p` = 0))
+  observed <- as.data.frame(x_sum)[, -1:-2]
+  expected <- data.frame(
+    Z = 2,
+    `~HR at bound` = 0.795,
+    `Nominal p` = 0,
+    `Alternate hypothesis` = 0.9,
+    `Null hypothesis` = 0.025,
+    check.names = FALSE
+  )
+  expect_equal(observed, expected)
+
+  # Specify decimals and also drop some variables
+  x_sum <- summary(
+    x,
+    col_vars = c("z", "nominal p", "Null hypothesis"),
+    col_decimals = c(z = 0, `nominal p` = 0)
+  )
+  observed <- as.data.frame(x_sum)[, -1:-2]
+  expected <- data.frame(Z = 2, `Nominal p` = 0, `Null hypothesis` = 0.025, check.names = FALSE)
+  expect_equal(observed, expected)
+
+  # Specify decimals and rearrange some variables
+  x_sum <- summary(
+    x,
+    col_vars = c("Null hypothesis", "nominal p", "z"),
+    col_decimals = c(z = 0, `nominal p` = 0)
+  )
+  observed <- as.data.frame(x_sum)[, -1:-2]
+  expected <- data.frame(`Null hypothesis` = 0.025, `Nominal p` = 0, Z = 2, check.names = FALSE)
+  expect_equal(observed, expected)
+
+  # Only drop variables
+  x_sum <- summary(x, col_vars = c("z", "nominal p", "Null hypothesis"))
+  observed <- as.data.frame(x_sum)[, -1:-2]
+  expected <- data.frame(Z = 1.96, `Nominal p` = 0.025, `Null hypothesis` = 0.025, check.names = FALSE)
+  expect_equal(observed, expected)
+
+  # Throw error is col_decimals is unnamed
+  expect_error(
+    summary(x, col_decimals = c(4, 4)),
+    "summary: col_decimals must be a named vector if col_vars is not provided"
+  )
+})

vignettes/articles/story-update-boundary.Rmd

@@ -131,13 +131,7 @@ gs_update_ahr(
   x = x,
   alpha = 0.025
   ) |>
-  summary(
-    col_vars = c(
-      "analysis", "bound", "z", "~hr at bound",
-      "nominal p", "Alternate hypothesis", "Null hypothesis"
-    ),
-    col_decimals = c(NA, NA, 4, 4, 4, 4, 4)
-  ) |>
+  summary(col_decimals = c(z = 4)) |>
   as_gt(title = "Updated design",
         subtitle = "For alternate alpha = 0.025")
 ```
@@ -184,13 +178,7 @@ gs_update_ahr(
   ustime = ustime,
   observed_data = list(observed_data_ia, observed_data_fa)
 ) |>
-  summary(
-    col_vars = c(
-      "analysis", "bound", "z", "~hr at bound",
-      "nominal p", "Alternate hypothesis", "Null hypothesis"
-    ),
-    col_decimals = c(NA, NA, 4, 4, 4, 4, 4)
-  ) |>
+  summary(col_decimals = c(z = 4)) |>
   as_gt(title = "Updated design",
         subtitle = paste0("With observed ", sum(observed_data_ia$event),
                           " events at IA and ", sum(observed_data_fa$event),
@@ -267,13 +255,7 @@ gs_update_ahr(
   x = x,
   alpha = 0.025
   ) |>
-  summary(
-    col_vars = c(
-      "analysis", "bound", "z", "~hr at bound",
-      "nominal p", "Alternate hypothesis", "Null hypothesis"
-    ),
-    col_decimals = c(NA, NA, 4, 4, 4, 4, 4)
-  ) |>
+  summary(col_decimals = c(z = 4)) |>
   as_gt(title = "Updated design",
         subtitle = "For alpha = 0.025")
 ```
@@ -294,13 +276,7 @@ gs_update_ahr(
   lstime = ustime, 
   observed_data = list(observed_data_ia, observed_data_fa)
   ) |>
-  summary(
-    col_vars = c(
-      "analysis", "bound", "z", "~hr at bound",
-      "nominal p", "Alternate hypothesis", "Null hypothesis"
-    ),
-    col_decimals = c(NA, NA, 4, 4, 4, 4, 4)
-  ) |>
+  summary(col_decimals = c(z = 4)) |>
   as_gt(title = "Updated design",
         subtitle = paste0("With observed ", sum(observed_data_ia$event),
                           " events at IA and ", sum(observed_data_fa$event),