fix summary method

Author: benesom

R/Trial.R

@@ -78,6 +78,7 @@ Trial <- R6::R6Class("Trial", #nolint
       self$info <- as.list(info)
 
       args <- as.list(formals(self$summary))
+
       args[c("...", "estimates")] <- NULL
       private$summary.args_default <- args
 
@@ -131,7 +132,7 @@ Trial <- R6::R6Class("Trial", #nolint
     },
 
     #' @description Get, specify or update the summary.args attribute.
-        #' @param .args (list or character) named list of arguments to update
+    #' @param .args (list or character) named list of arguments to update
     #' or set. A single or subset of arguments can be retrieved by passing the
     #' respective argument names as a character or character vector.
     #' @param .reset (logical or character) Reset all or a subset of previously
@@ -513,15 +514,20 @@ Trial <- R6::R6Class("Trial", #nolint
     #'   the power of both superiority tests (one-sided or two-sided) and
     #'   non-inferiority tests, together with summary statistics of the
     #'   different estimators.
+    #'
+    #' Arguments provided to this method call take precedence over argument
+    #' values that have been previously set via ([Trial$args_summary()][Trial]).
+    #' See the examples for more details.
     #' @param level (numeric) significance level
     #' @param null (numeric) null hypothesis to test
     #' @param ni.margin (numeric) non-inferiority margin
-    #' @param alternative alternative hypothesis (not equal !=, less <,
-    #'   greater >)
+    #' @param alternative (character) alternative hypothesis (not equal !=, less
+    #'   <, greater >)
     #' @param reject.function Optional function calculating whether to reject
     #'   the null hypothesis
-    #' @param true.value Optional true parameter value
-    #' @param nominal.coverage Width of confidence limits
+    #' @param true.value (numeric) Optional true parameter value
+    #' @param nominal.coverage (numeric) Width of confidence limits. The default
+    #' behavior is to calculate the coverage for the 1 - `level` CI.
     #' @param estimates Optional trial.estimates object. When provided, these
     #'   estimates will be used instead of the object's stored estimates. This
     #'   allows calculating summaries for different trial results without
@@ -550,20 +556,37 @@ Trial <- R6::R6Class("Trial", #nolint
     #'
     #' # calculate empirical bias, rmse and coverage for true target parameter
     #' trial$summary(estimates = res, true.value = 0)
+    #'
+    #' # use args_summary to set default values
+    #' trial$args_summary(true.value = 0)
+    #' trial$summary(estimates = res)
+    #' # arguments to method call preceed arguments that have been set via
+    #' # args_summary method
+    #' trial$summary(estimates = res, true.value = 1)
     summary = function(level = .05,
                        null = 0,
                        ni.margin = NULL,
                        alternative = "!=",
                        reject.function = NULL,
                        true.value = NULL,
-                       nominal.coverage = 0.9,
+                       nominal.coverage = NULL,
                        estimates = NULL,
                        ...) {
-    trial_summary(self = self, level = level, null = null,
-      ni.margin = ni.margin, alternative = alternative,
-      reject.function = reject.function, true.value = true.value,
-      nominal.coverage = nominal.coverage, estimates = estimates, ...
-    )
+    mc_supplied <- as.list(match.call(expand.dots = FALSE))[-1]
+    nm_formals_supplied <- setdiff(names(mc_supplied), "...")
+    call_args <- if (length(nm_formals_supplied)) {
+      mget(nm_formals_supplied, inherits = FALSE)
+    } else {
+      list()
+    }
+    if ("..." %in% names(mc_supplied)) call_args <- c(call_args, list(...))
+
+    args <- self$args_summary()
+    args[names(call_args)] <- call_args
+
+    if (!("estimates" %in% names(args))) args <- c(args, list(estimates = NULL))
+
+    do.call(trial_summary, c(list(self = self), args))
     },
 
     #' @description Print method for Trial objects
@@ -714,6 +737,7 @@ trial_summary <- function(self, level, null, ni.margin, alternative,
   if (!(alternative %in% c("!=", "<", ">"))) {
     rlang::abort('alternative should be one of "!=", "<", ">"')
   }
+  if (is.null(nominal.coverage)) nominal.coverage <- 1 - level
 
   alternative <- gsub(" ", "", tolower(alternative[1]))
   q_alpha_cov <- qnorm(1 - (1 - nominal.coverage) / 2) # quantile for

inst/tinytest/test_Trial.R

@@ -312,7 +312,7 @@ test_args_summary <- function() {
     alternative = "!=",
     reject.function = NULL,
     true.value = NULL,
-    nominal.coverage = 0.9
+    nominal.coverage = NULL
   )
 
   # arguments are set correctly when using summary.args / test getter
@@ -683,11 +683,15 @@ test_summary <- function() {
   expect_true(s[1, "power"] < s2[1, "power"])
 
   # test that nominal coverage around true.value is correctly calculated
-  s3 <- m$summary(true.value = -.25, nominal.coverage = 0.9)
-  expect_equal(s3[, "coverage"], 0.9, tolerance = 0.05)
+  # default behavior is to obtain the coverage for 1 - level
+  s3 <- m$summary(true.value = -.25)
+  expect_equal((ss <- s3[, "coverage"]), 0.95, tolerance = 0.05)
+  s3 <- m$summary(true.value = -.25, nominal.coverage = 0.95)
+  expect_equal(ss, s3[, "coverage"])
   s3 <- m$summary(true.value = -.25, nominal.coverage = 0.5)
   expect_equal(s3[, "coverage"], 0.5, tolerance = 0.05)
 
+
   # test ni.margin; expect power around 5% since true value is -0.25
   s <- m$summary(ni.margin = -.25, alternative = ">")
   expect_equal(s[1, "power"], 0.05, tolerance = 0.1)
@@ -723,8 +727,8 @@ test_summary <- function() {
   s <- m$summary()
   expect_equal(rownames(s), c("est1", "est2"))
 
-  # Add new test block for estimates parameter
-  # Test that providing estimates directly works the same as using stored estimates
+  # Test that providing estimates directly works the same as using stored
+  # estimates
   res2 <- m$run(n = 100, R = 100, p = c(0.5, 0.25))
   s1 <- m$summary()
   s2 <- m$summary(estimates = res2)
@@ -734,7 +738,6 @@ test_summary <- function() {
   s3 <- m$summary(estimates = res2, level = 0.1)
   expect_false(identical(s2, s3))
 
-
   # Test that providing estimates doesn't modify the object's stored estimates
   original_estimates <- m$estimates
   m$summary(estimates = res2)
@@ -744,5 +747,30 @@ test_summary <- function() {
   different_res <- m$run(n = 200, R = 100, p = c(0.5, 0.25))  # Different n
   s3 <- m$summary(estimates = different_res)
   expect_false(identical(s1, s3))  # Should be different due to different n
+
+  # tests for setting default values for summary method with args_summary method
+  outcome <- function(data, p = c(0.5, 0.25)) {
+    a <- rbinom(nrow(data), 1, 0.5)
+    data.frame(a = a, y = rbinom(nrow(data), 1, p[1] * (1 - a) + p[2] * a)
+    )
+  }
+  trial <- Trial$new(outcome, estimators = est_glm())
+  trial$args_summary(level = 0)
+  trial$run(n = 100, R = 10)
+  # verify that method picks up arguments that are set via args_summary
+  expect_equal(trial$summary()[1, "power"], 0) # needs to be 0 because level = 0
+  # verify that arguments to method take precedence over set arguments
+  expect_equal(
+    (pp <- trial$summary(level = 1)[1, "power"]),
+    1
+  ) # needs to be 0 because level = 0
+  # verify that default value of argument can be used
+  expect_true(pp != trial$summary(level = 0.05)[1, "power"])
+  # also works with do.call
+  expect_equal(
+    pp,
+    do.call(trial$summary, list(level = 1))[1, "power"]
+  )
+
 }
 test_summary()