Add comprehensive variable pre-filtering mechanism with categorical support to br_run and br_pipeline functions

.gitignore

@@ -22,3 +22,6 @@ bregr_models
 .Rapp.history
 *.png
 demo_fix.R
+
+# Test artifacts
+tests/testthat/Rplots.pdf

NAMESPACE

@@ -72,6 +72,7 @@ importFrom(stats,cor)
 importFrom(stats,pchisq)
 importFrom(stats,predict)
 importFrom(stats,quantile)
+importFrom(stats,sd)
 importFrom(survival,Surv)
 importFrom(survival,coxph)
 importFrom(survival,survdiff)

R/00-bregr-package.R

@@ -9,7 +9,7 @@
 #' @importFrom lifecycle deprecated
 #' @importFrom rlang .data .env
 #' @importFrom utils combn packageDescription packageVersion
-#' @importFrom stats cor pchisq quantile predict
+#' @importFrom stats cor pchisq quantile predict sd
 #' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@")
 ## usethis namespace: end
 NULL

R/02-pipeline.R

@@ -55,6 +55,10 @@
 #' For logistic, and Cox-PH regressions models, `exponentiate` is set to `TRUE` at default.
 #' @param model_args A list of arguments passed to `br_set_model()`.
 #' @param run_args A list of arguments passed to `br_run()`.
+#' @param filter_x Logical, whether to enable pre-filtering of focal variables. Default is `FALSE`.
+#' @param filter_na_prop Numeric, maximum proportion of NA values allowed for a variable. Default is `0.8`.
+#' @param filter_sd_min Numeric, minimum standard deviation required for a variable. Default is `1e-6`.
+#' @param filter_var_min Numeric, minimum variance required for a variable. Default is `1e-6`.
 #' @examples
 #' library(bregr)
 #' # 1. Pipeline -------------------------
@@ -97,9 +101,10 @@
 #' )
 #'
 #' # 3. Customized model -----------
+#' \dontrun{
 #' dt <- data.frame(x = rnorm(100))
 #' dt$y <- rpois(100, exp(1 + dt$x))
-#' \donttest{
+#'
 #' m5 <- breg(dt) |>
 #'   br_set_y("y") |>
 #'   br_set_x("x") |>
@@ -123,7 +128,12 @@ br_pipeline <- function(
     group_by = NULL,
     n_workers = 1L, run_parallel = lifecycle::deprecated(),
     model_args = list(),
-    run_args = list()) {
+    run_args = list(),
+    filter_x = FALSE,
+    filter_na_prop = 0.8,
+    filter_sd_min = 1e-6,
+    filter_var_min = 1e-6,
+    filter_min_levels = 2) {
   if (lifecycle::is_present(run_parallel)) {
     lifecycle::deprecate_warn("1.1.0", "bregr::br_run(run_parallel = )", "bregr::br_run(n_workers = )")
     n_workers <- run_parallel
@@ -134,7 +144,13 @@ br_pipeline <- function(
     br_set_x(x) |>
     br_set_x2(x2) |>
     br_set_model(method = method, !!!model_args) |>
-    br_run(group_by = group_by, n_workers = n_workers, !!!run_args)
+    br_run(
+      group_by = group_by, n_workers = n_workers,
+      filter_x = filter_x, filter_na_prop = filter_na_prop,
+      filter_sd_min = filter_sd_min, filter_var_min = filter_var_min,
+      filter_min_levels = filter_min_levels,
+      !!!run_args
+    )
 }
 
 #' @describeIn pipeline Set dependent variables for model construction.
@@ -272,12 +288,28 @@ br_set_model <- function(obj, method, ...) {
 }
 
 #' @describeIn pipeline Run the regression analysis in batch.
+#' @param filter_x Logical, whether to enable pre-filtering of focal variables. Default is `FALSE`.
+#' @param filter_na_prop Numeric, maximum proportion of NA values allowed for a variable. Default is `0.8`.
+#' @param filter_sd_min Numeric, minimum standard deviation required for a variable. Default is `1e-6`.
+#' @param filter_var_min Numeric, minimum variance required for a variable. Default is `1e-6`.
+#' @param filter_min_levels Numeric, minimum number of unique levels required for categorical variables. Default is `2`.
 #' @export
 br_run <- function(obj, ...,
                    group_by = NULL, n_workers = 1L,
-                   run_parallel = lifecycle::deprecated()) {
+                   run_parallel = lifecycle::deprecated(),
+                   filter_x = FALSE,
+                   filter_na_prop = 0.8,
+                   filter_sd_min = 1e-6,
+                   filter_var_min = 1e-6,
+                   filter_min_levels = 2) {
   assert_breg_obj(obj)
   assert_character(group_by, allow_na = FALSE, allow_null = TRUE)
+  if (br_get_n_x(obj) < 1) {
+    cli::cli_abort("{.fn br_set_x} must run before {.fn br_run}")
+  }
+  if (length(br_get_y(obj)) < 1) {
+    cli::cli_abort("{.fn br_set_y} must run before {.fn br_run}")
+  }
   on.exit(invisible(gc()))
 
   if (lifecycle::is_present(run_parallel)) {
@@ -306,6 +338,69 @@ br_run <- function(obj, ...,
     )
   }
 
+  # Apply variable filtering if enabled
+  original_x <- obj@x
+  if (filter_x) {
+    assert_logical(filter_x, allow_na = FALSE)
+    assert_number_decimal(filter_na_prop, min = 0, max = 1)
+    assert_number_decimal(filter_sd_min, min = 0)
+    assert_number_decimal(filter_var_min, min = 0)
+    assert_number_whole(filter_min_levels, min = 1)
+
+    filter_result <- filter_variables_x(
+      obj@data, obj@x,
+      filter_na_prop = filter_na_prop,
+      filter_sd_min = filter_sd_min,
+      filter_var_min = filter_var_min,
+      filter_min_levels = filter_min_levels
+    )
+
+    obj@x <- filter_result$filtered_x
+
+    # Inform user about filtering results
+    if (filter_result$filter_summary$filtered > 0) {
+      cli::cli_inform(
+        "Pre-filtering removed {filter_result$filter_summary$filtered} out of {filter_result$filter_summary$total} focal variables ({round(filter_result$filter_summary$prop_filtered * 100, 1)}%)"
+      )
+      if (length(filter_result$filtered_out) <= 10) {
+        cli::cli_inform("Filtered variables: {.val {filter_result$filtered_out}}")
+      } else {
+        cli::cli_inform("Filtered variables (showing first 10): {.val {filter_result$filtered_out[1:10]}} ...")
+      }
+    } else {
+      cli::cli_inform("Pre-filtering: no variables were filtered out")
+    }
+
+    # Update models to reflect filtered variables
+    if (length(obj@x) > 0) {
+      config <- br_get_config(obj)
+
+      # Get the proper method configuration
+      if (!rlang::is_list(config$method)) {
+        method_config <- br_avail_method_config(config$method)
+      } else {
+        method_config <- config$method
+      }
+
+      models <- gen_template(
+        obj@y, obj@x, obj@x2,
+        method_config$f_call,
+        method_config$f_cnst_y,
+        method_config$args_method,
+        paste0(
+          method_config$args_data,
+          ", ",
+          config$extra
+        )
+      ) |>
+        as.list()
+      names(models) <- obj@x
+      obj@models <- models
+    } else {
+      cli::cli_abort("All focal variables were filtered out. Consider relaxing filtering criteria.")
+    }
+  }
+
   ms <- br_get_models(obj)
   config <- br_get_config(obj)
   dots <- rlang::list2(...)

R/04-show.R

@@ -656,7 +656,7 @@ br_show_survival_curves <- function(breg,
 
   # Clean group names while preserving factor level order
   plot_data$group <- gsub(".*=", "", plot_data$group)
-  
+
   # Convert back to factor with the same level order as the original group_labels
   # to ensure correct legend ordering
   plot_data$group <- factor(plot_data$group, levels = group_labels)

R/98-utils.R

@@ -183,3 +183,108 @@ geom_segment_straight <- function(...) {
 utils::globalVariables(
   c("xend", "yend")
 )
+
+# Variable filtering functions for br_run pre-filtering
+filter_variables_x <- function(data, x, filter_na_prop = 0.8, filter_sd_min = 1e-6, filter_var_min = 1e-6, filter_min_levels = 2) {
+  if (length(x) == 0) {
+    return(list(
+      filtered_x = character(0),
+      filtered_out = character(0),
+      filter_summary = list(total = 0, kept = 0, filtered = 0, prop_filtered = 0)
+    ))
+  }
+
+  # Get variable names from terms (handle complex terms like I(x^2))
+  x_vars <- sapply(x, get_vars)
+  x_simple <- x_vars[sapply(x_vars, function(v) length(v) == 1)]
+
+  # For complex terms with multiple variables, we keep them for now
+  # Only filter simple single-variable terms
+  complex_terms <- x[sapply(x_vars, function(v) length(v) != 1)]
+  simple_terms <- x[sapply(x_vars, function(v) length(v) == 1)]
+  simple_vars <- x_simple
+
+  if (length(simple_vars) == 0) {
+    return(list(
+      filtered_x = x,
+      filtered_out = character(0),
+      filter_summary = list(total = length(x), kept = length(x), filtered = 0, prop_filtered = 0)
+    ))
+  }
+
+  # Check which variables are available in data
+  available_vars <- intersect(simple_vars, colnames(data))
+  if (length(available_vars) == 0) {
+    return(list(
+      filtered_x = x,
+      filtered_out = character(0),
+      filter_summary = list(total = length(x), kept = length(x), filtered = 0, prop_filtered = 0)
+    ))
+  }
+
+  # Filter based on criteria
+  filtered_out_vars <- character(0)
+
+  for (var in available_vars) {
+    var_data <- data[[var]]
+
+    # Check NA proportion (applies to all variable types)
+    na_prop <- sum(is.na(var_data)) / length(var_data)
+    if (na_prop > filter_na_prop) {
+      filtered_out_vars <- c(filtered_out_vars, var)
+      next
+    }
+
+    # Get non-NA values for further checks
+    non_na_values <- var_data[!is.na(var_data)]
+    if (length(non_na_values) < 2) {
+      filtered_out_vars <- c(filtered_out_vars, var)
+      next
+    }
+
+    # Handle numeric variables
+    if (is.numeric(var_data)) {
+      # Check standard deviation
+      var_sd <- sd(non_na_values, na.rm = TRUE)
+      if (is.na(var_sd) || var_sd < filter_sd_min) {
+        filtered_out_vars <- c(filtered_out_vars, var)
+        next
+      }
+
+      # Check variance
+      var_var <- var(non_na_values, na.rm = TRUE)
+      if (is.na(var_var) || var_var < filter_var_min) {
+        filtered_out_vars <- c(filtered_out_vars, var)
+        next
+      }
+    }
+    # Handle categorical variables (character, factor, logical)
+    else if (is.character(var_data) || is.factor(var_data) || is.logical(var_data)) {
+      # Check number of unique levels
+      n_unique_levels <- length(unique(non_na_values))
+      if (n_unique_levels < filter_min_levels) {
+        filtered_out_vars <- c(filtered_out_vars, var)
+        next
+      }
+    }
+    # For other variable types, keep them (e.g., Date, POSIXt, etc.)
+  }
+
+  # Map filtered variables back to terms
+  filtered_out_terms <- simple_terms[simple_vars %in% filtered_out_vars]
+  kept_terms <- setdiff(x, filtered_out_terms)
+
+  # Create summary
+  filter_summary <- list(
+    total = length(x),
+    kept = length(kept_terms),
+    filtered = length(filtered_out_terms),
+    prop_filtered = length(filtered_out_terms) / length(x)
+  )
+
+  list(
+    filtered_x = kept_terms,
+    filtered_out = filtered_out_terms,
+    filter_summary = filter_summary
+  )
+}