Merge branch 'main' of https://github.com/pmsims-package/pmsims

Author: Ridwan Olaniran

DESCRIPTION

@@ -48,7 +48,8 @@ Imports:
     utils,
     glmnet,
     ranger,
-    pec
+    pec,
+    cli
 Suggests:
     testthat (>= 3.0.0),
     covr,

NAMESPACE

@@ -3,17 +3,9 @@
 S3method(plot,pmsims)
 S3method(print,pmsims)
 S3method(summary,pmsims)
-export(calculate_bisection)
-export(calculate_mlpwr_bs)
-export(generate_binary_data)
-export(objective_function)
-export(parse_inputs)
-export(predict_custom)
 export(simulate_binary)
 export(simulate_continuous)
-export(simulate_custom)
 export(simulate_survival)
-export(survival_tuning)
 importFrom(survival,Surv)
 importFrom(utils,setTxtProgressBar)
 importFrom(utils,txtProgressBar)

R/data_generators.R

@@ -61,7 +61,7 @@ generate_continuous_data <- function(
 #'
 #' @return A data frame with one outcome column and n_signal_parameters + noise_parameters predictor columns
 #' @keywords internal
-#' @export
+
 generate_binary_data <- function(
   n,
   mu_lp,
@@ -145,6 +145,12 @@ update_arguments <- function(fn, opts) {
 
 generate_predictors <- function(n, parameters, type, predictor_prop) {
   if (type == "binary") {
+    if (is.null(predictor_prop)) {
+      stop("predictor_prop must be provided when predictor type is binary")
+    }
+    if (predictor_prop < 0 || predictor_prop > 1) {
+      stop("predictor_prop must be between 0 and 1")
+    }
     X <- stats::rbinom(n * parameters, 1, predictor_prop)
   } else if (type == "continuous") {
     X <- stats::rnorm(n * parameters)

R/engines.R

@@ -539,7 +539,7 @@ calculate_mlpwr <- function(
 #' @return A list containing the simulation `results`, performance `summaries`,
 #'   optional tracking `history`, and the `track_bisection` records.
 #' @keywords internal
-#' @export
+
 calculate_bisection <- function(
   data_function = data_function,
   model_function = model_function,
@@ -680,7 +680,7 @@ calculate_bisection <- function(
 #'
 #' @return List containing the combined bisection and mlpwr results (`results`, `summaries`, `min_n`, `perf_n`, and `mlpwr_ds`).
 #' @keywords internal
-#' @export
+
 calculate_mlpwr_bs <- function(
   test_n,
   n_reps_total,

R/input_validation.R

@@ -31,6 +31,9 @@ validate_metric_constraints <- function(metric,
   }
 }
 
+
+
+
 validate_outcome_prevalence <- function(outcome_prevalence) {
   if (is.null(outcome_prevalence)) {
     cli::cli_abort("`outcome_prevalence` must be specified.")
@@ -44,3 +47,53 @@ validate_outcome_prevalence <- function(outcome_prevalence) {
 
   invisible(TRUE)
 }
+
+#' check_pmsims_args - a custom version of the base R match.arg function with improved error message
+#'
+#'@inherit base::match.arg
+#'
+check_pmsims_args <- function(arg, choices, several.ok = FALSE) {
+  if (missing(choices)) {
+    formal.args <- formals(sys.function(sysP <- sys.parent()))
+    choices <- eval(
+      formal.args[[as.character(substitute(arg))]],
+      envir = sys.frame(sysP)
+    )
+  }
+  arg_name <- as.character(substitute(arg))
+
+  if (is.null(arg)) {
+    return(choices[1L])
+  } else if (!is.character(arg)) {
+    stop(paste0(arg_name, " must be NULL or a character vector"))
+  }
+  if (!several.ok) {
+    if (identical(arg, choices)) {
+      return(arg[1L])
+    }
+    if (length(arg) > 1L) {
+      stop(paste0(arg_name, " must be of length 1"))
+    }
+  } else if (length(arg) == 0L) {
+    stop(paste0(arg_name, " must be of length >= 1"))
+  }
+  i <- pmatch(arg, choices, nomatch = 0L, duplicates.ok = TRUE)
+  if (all(i == 0L)) {
+    stop(
+      sprintf(
+        ngettext(
+          length(chs <- unique(choices[nzchar(choices)])),
+          sprintf("'%s' should be %%s", arg_name),
+          sprintf("'%s' should be one of %%s", arg_name)
+        ),
+        paste(dQuote(chs), collapse = ", ")
+      ),
+      domain = NA
+    )
+  }
+  i <- i[i > 0L]
+  if (!several.ok && length(i) > 1) {
+    stop("there is more than one match in 'check_pmsims_args'")
+  }
+  choices[i]
+}

R/metric_generators.R

@@ -65,7 +65,7 @@ default_metric_generator <- function(metric, data_function) {
 }
 
 #' @keywords internal
-#' @export
+
 predict_custom <- function(x, y, fit, model, type = "response") {
   if (model == "glm") {
     stats::predict(fit, newdata = x, type = type)

R/pmsims_objective_function.R

@@ -16,7 +16,6 @@
 #'
 #' @return A single numeric: the objective value at \eqn{n}.
 #' @keywords internal
-#' @export
 #'
 #' @examples
 #' # \dontrun{

R/simulate_custom.R

@@ -20,7 +20,7 @@
 #'
 #' @return An object of class `"pmsims"` containing the estimated minimum sample size and simulation diagnostics.
 #' @keywords internal
-#' @export
+
 simulate_custom <- function(
   data_function = NULL,
   model_function = NULL,
@@ -195,7 +195,7 @@ simulate_custom <- function(
 #' the supplied inputs.
 #'
 #' @keywords internal
-#' @export
+
 parse_inputs <- function(data_spec, metric, model) {
   if (is.null(metric)) {
     stop("metric is missing")

R/simulate_wrappers.R

@@ -29,8 +29,8 @@
 #'   with the outcome (i.e., true signal features).
 #' @param noise_parameters Integer. Number of candidate predictors not
 #'   associated with the outcome (noise features). Default is 0.
-#' @param predictor_type Character string, either `"continuous"` or `"binary"`.
-#'   Specifies the type of simulated candidate predictors. Defaults to `"continuous"`.
+#' @param predictor_type Character string, currently only `"continuous"` supported, which is the default option.
+#'   Specifies the type of simulated candidate predictors.
 #' @param binary_predictor_prevalence Optional numeric in (0, 1). Prevalence of
 #'   the binary predictors when `predictor_type = "binary"`. Ignored otherwise.
 #' @param outcome_prevalence Numeric in (0, 1). Target prevalence of the binary
@@ -78,23 +78,23 @@
 #' }
 #' @export
 simulate_binary <- function(
-  signal_parameters,                  # Predictors
+  signal_parameters, # Predictors
   noise_parameters = 0,
-  predictor_type = c("continuous", "binary"),
+  predictor_type = c("continuous"),
   binary_predictor_prevalence = NULL,
-  outcome_prevalence,                 # Outcome
+  outcome_prevalence, # Outcome
   large_sample_cstatistic,
-  model = c("glm"),                      # Model
+  model = c("glm"), # Model
   metric = c("calibration_slope", "auc"), # Performance
   minimum_acceptable_performance,
-  n_reps_total = 1000,                # Engine control
+  n_reps_total = 1000, # Engine control
   mean_or_assurance = c("assurance", "mean"),
   ...
 ) {
-  predictor_type <-  match.arg(predictor_type)
-  model <- match.arg(model)
-  metric <- match.arg(metric)
-  mean_or_assurance <- match.arg(mean_or_assurance)
+  predictor_type <- check_pmsims_args(predictor_type)
+  model <- check_pmsims_args(model)
+  metric <- check_pmsims_args(metric)
+  mean_or_assurance <- check_pmsims_args(mean_or_assurance)
 
   validate_metric_constraints(
     metric = metric,
@@ -206,7 +206,7 @@ simulate_binary <- function(
 simulate_continuous <- function(
   signal_parameters,
   noise_parameters = 0,
-  predictor_type = c("continuous", "binary"),
+  predictor_type = c("continuous"),
   binary_predictor_prevalence = NULL,
   large_sample_rsquared,
   model = c("lm"),
@@ -216,10 +216,10 @@ simulate_continuous <- function(
   mean_or_assurance = c("assurance", "mean"),
   ...
 ) {
-  predictor_type <-  match.arg(predictor_type)
-  model <- match.arg(model)
-  metric <- match.arg(metric)
-  mean_or_assurance <- match.arg(mean_or_assurance)
+  predictor_type <- check_pmsims_args(predictor_type)
+  model <- check_pmsims_args(model)
+  metric <- check_pmsims_args(metric)
+  mean_or_assurance <- check_pmsims_args(mean_or_assurance)
 
   validate_metric_constraints(
     metric = metric,
@@ -329,7 +329,7 @@ simulate_continuous <- function(
 simulate_survival <- function(
   signal_parameters,
   noise_parameters = 0,
-  predictor_type = c("continuous", "binary"),
+  predictor_type = c("continuous"),
   binary_predictor_prevalence = NULL,
   large_sample_cindex,
   baseline_hazard = 1,
@@ -341,10 +341,10 @@ simulate_survival <- function(
   mean_or_assurance = c("assurance", "mean"),
   ...
 ) {
-  predictor_type <-  match.arg(predictor_type)
-  model <- match.arg(model)
-  metric <- match.arg(metric)
-  mean_or_assurance <- match.arg(mean_or_assurance)
+  predictor_type <- check_pmsims_args(predictor_type)
+  model <- check_pmsims_args(model)
+  metric <- check_pmsims_args(metric)
+  mean_or_assurance <- check_pmsims_args(mean_or_assurance)
 
   validate_metric_constraints(
     metric = metric,

R/survival_tuning.R

@@ -5,7 +5,6 @@
 #' @param tolerance The tolerance in the large sample performance
 #' @return The optimal value for the tuning parameter
 #' @keywords internal
-#' @export
 #'
 #' @examples