Pull recent changes from main into dev branch

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

@@ -381,7 +381,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,
@@ -549,7 +549,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

@@ -30,3 +30,70 @@ validate_metric_constraints <- function(metric,
     }
   }
 }
+
+
+
+
+validate_outcome_prevalence <- function(outcome_prevalence) {
+  if (is.null(outcome_prevalence)) {
+    cli::cli_abort("`outcome_prevalence` must be specified.")
+  }
+
+  if (outcome_prevalence < 0.05) {
+    cli::cli_alert_warning(
+      "Outcome prevalence is very low ({.val {outcome_prevalence}}). Recommended > {.val 0.05}; values below this haven’t been tested, and simulations may take a long time."
+    )
+  }
+
+  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{