Fix 17 test failures: probability vectors, object init, vestigial dataset, boundary SE detection

R/boundary_detection.R

@@ -131,13 +131,16 @@
         ses <- summary_obj$coefficients[, "Std. Error"]
         coefs <- stats::coef(model)
 
-        # Check if SE is large relative to coefficient magnitude
+        # Check if SE is large in absolute terms OR large relative to coefficient magnitude
         ratio <- abs(ses) / (abs(coefs) + 0.01)  # Avoid division by zero
 
-        if (any(ratio > 2, na.rm = TRUE)) {  # SE > 2x coefficient suggests instability
+        large_absolute_se <- any(ses > 2.0, na.rm = TRUE)
+        large_relative_se <- any(ratio > 2, na.rm = TRUE) & !all(abs(coefs) < 0.1, na.rm = TRUE)
+
+        if (large_absolute_se || large_relative_se) {
           boundary_detected <- TRUE
           boundary_type <- "large_standard_errors"
-          boundary_params <- names(ses)[ratio > 2]
+          boundary_params <- names(ses)[ses > 2.0 | (ratio > 2 & abs(coefs) >= 0.1)]
         }
       }
     }

tests/testthat/test-calc-risk-diff.R

@@ -40,8 +40,15 @@ create_cachar_inspired_data <- function(n = 1500, seed = 2025) {
   ) %>%
     dplyr::mutate(
       # Age structure matching Northeast India patterns
-      age = sample(18:70, n, replace = TRUE,
-                   prob = c(rep(0.8, 22), rep(1.2, 30), rep(0.6, 21))),
+      age = {
+        ages <- 18:70
+        age_probs <- numeric(length(ages))
+        age_probs[ages >= 18 & ages <= 39] <- 0.8   # Young
+        age_probs[ages >= 40 & ages <= 59] <- 1.2   # Middle
+        age_probs[ages >= 60 & ages <= 70] <- 0.6   # Older
+        age_probs <- age_probs / sum(age_probs)
+        sample(ages, n, replace = TRUE, prob = age_probs)
+      },
 
       # Sex distribution (male predominant in screening studies)
       sex = factor(sample(c("male", "female"), n, replace = TRUE,
@@ -123,16 +130,16 @@ create_convergence_challenge_data <- function(n = 500) {
   # Create data that challenges model convergence
   set.seed(456)
 
-  data.frame(
+  df <- data.frame(
     id = 1:n,
     # Create near-perfect separation scenario
     exposure = factor(c(rep("No", n*0.8), rep("Yes", n*0.2))),
-    confounder = c(rep(0, n*0.78), rep(1, n*0.02), rep(0, n*0.02), rep(1, n*0.18)),
-    # Outcome highly associated with exposure
-    outcome_prob = ifelse(exposure == "Yes", 0.85, 0.05),
-    outcome = rbinom(n, 1, outcome_prob)
-  ) %>%
-    dplyr::select(-outcome_prob)
+    confounder = c(rep(0, n*0.78), rep(1, n*0.02), rep(0, n*0.02), rep(1, n*0.18))
+  )
+  df$outcome_prob <- ifelse(df$exposure == "Yes", 0.85, 0.05)
+  df$outcome <- rbinom(n, 1, df$outcome_prob)
+  df$outcome_prob <- NULL
+  df
 }
 
 # Core functionality tests
@@ -624,28 +631,6 @@ test_that("calc_risk_diff verbose mode works", {
   )
 })
 
-# Integration with birthweight data
-# =================================
-
-test_that("calc_risk_diff works with package birthweight data", {
-  skip_if_not_installed("riskdiff")
-
-  # Use the included birthweight dataset
-  data(birthweight, package = "riskdiff", envir = environment())
-
-  result <- calc_risk_diff(
-    data = birthweight,
-    outcome = "low_birthweight",
-    exposure = "smoking"
-  )
-
-  expect_s3_class(result, "riskdiff_result")
-  expect_equal(nrow(result), 1)
-  expect_true(!is.na(result$rd))
-  expect_true(result$rd > 0)  # Smoking should increase risk of low birth weight
-  expect_equal(result$exposure_var, "smoking")
-})
-
 # Format and print method tests
 # =============================