`%||%` <- function(x, y) {
  if (is.null(x)) y else x
}

.sw_abort <- function(..., call. = FALSE) {
  stop(paste0(...), call. = call.)
}

.require_namespace <- function(package, feature = package) {
  if (!requireNamespace(package, quietly = TRUE)) {
    .sw_abort("Package `", package, "` is required for ", feature, ". Install it with install.packages(\"", package, "\").")
  }
  invisible(TRUE)
}

.within_tol <- function(x, y, tolerance = 1e-7) {
  if (length(x) != length(y)) return(FALSE)
  if (length(x) == 0L) return(TRUE)
  x <- as.numeric(x)
  y <- as.numeric(y)
  ok_na <- is.na(x) == is.na(y)
  if (!all(ok_na)) return(FALSE)
  keep <- !is.na(x) & !is.na(y)
  if (!any(keep)) return(TRUE)
  all(abs(x[keep] - y[keep]) <= tolerance * (1 + pmax(abs(x[keep]), abs(y[keep]))))
}

.max_abs_diff <- function(x, y) {
  if (length(x) != length(y)) return(Inf)
  x <- as.numeric(x)
  y <- as.numeric(y)
  keep <- !is.na(x) & !is.na(y)
  if (!any(keep)) return(0)
  max(abs(x[keep] - y[keep]))
}

.named_overlap <- function(x, y) {
  nms <- intersect(names(x), names(y))
  list(x = x[nms], y = y[nms], names = nms)
}

.resolve_weights <- function(data, weights, weights_expr, weights_missing) {
  if (weights_missing) return(NULL)
  if (is.symbol(weights_expr)) {
    nm <- as.character(weights_expr)
    if (nm %in% names(data)) weights <- data[[nm]]
  }
  if (is.character(weights) && length(weights) == 1L && weights %in% names(data)) {
    weights <- data[[weights]]
  }
  if (is.null(weights)) return(NULL)
  if (!is.numeric(weights)) {
    .sw_abort("`weights` must be NULL, a numeric vector, or the name of a numeric column.")
  }
  if (length(weights) != nrow(data)) {
    .sw_abort("`weights` must have one value per row of `data`.")
  }
  if (any(weights < 0, na.rm = TRUE)) {
    .sw_abort("`weights` cannot contain negative values.")
  }
  weights
}

.has_random_terms <- function(formula) {
  grepl("\\|", paste(deparse(formula), collapse = " "))
}

.is_survival_formula <- function(formula) {
  lhs <- paste(deparse(formula[[2L]]), collapse = "")
  grepl("(^|::)Surv\\s*\\(", lhs)
}

.fixed_formula <- function(formula) {
  if (.has_random_terms(formula)) {
    .require_namespace("reformulas", "mixed-model formula parsing")
    out <- reformulas::nobars(formula)
    environment(out) <- environment(formula)
    return(out)
  }
  formula
}

.detect_method <- function(formula, family = NULL, method = "auto") {
  allowed <- c("auto", "lm", "aov", "glm", "lmer", "glmer", "glmmTMB", "coxph", "survreg")
  method <- match.arg(method, allowed)
  if (method != "auto") return(method)
  if (.is_survival_formula(formula)) return("coxph")
  if (.has_random_terms(formula)) {
    if (is.null(family)) return("lmer")
    return("glmer")
  }
  if (!is.null(family)) return("glm")
  "lm"
}

.call_engine <- function(engine, args) {
  if (!is.function(engine)) .sw_abort("`engine` must be NULL or a function.")
  fmls <- names(formals(engine))
  if (!"..." %in% fmls) args <- args[intersect(names(args), fmls)]
  do.call(engine, args)
}

.default_engine <- function(formula, data, family = NULL, weights = NULL,
                            method = "auto", control = NULL, ...) {
  method <- .detect_method(formula, family, method)
  add_weights <- function(args) {
    if (!is.null(weights)) args$weights <- weights
    args
  }
  if (method == "lm") {
    args <- add_weights(list(formula = formula, data = data,
      na.action = stats::na.omit, model = TRUE, x = TRUE, y = TRUE))
    return(do.call(stats::lm, args))
  }
  if (method == "aov") {
    args <- add_weights(list(formula = formula, data = data, na.action = stats::na.omit))
    return(do.call(stats::aov, args))
  }
  if (method == "glm") {
    args <- add_weights(list(formula = formula, data = data, family = family,
      na.action = stats::na.omit, model = TRUE, x = TRUE, y = TRUE))
    return(do.call(stats::glm, args))
  }
  if (method == "lmer") {
    .require_namespace("lme4", "linear mixed-effects models")
    args <- add_weights(list(formula = formula, data = data, REML = TRUE,
      na.action = stats::na.omit))
    if (!is.null(control)) args$control <- control
    return(do.call(lme4::lmer, args))
  }
  if (method == "glmer") {
    .require_namespace("lme4", "generalized mixed-effects models")
    args <- add_weights(list(formula = formula, data = data, family = family,
      na.action = stats::na.omit))
    if (!is.null(control)) args$control <- control
    return(do.call(lme4::glmer, args))
  }
  if (method == "glmmTMB") {
    .require_namespace("glmmTMB", "glmmTMB models")
    args <- add_weights(list(formula = formula, data = data,
      family = family %||% stats::gaussian(), na.action = stats::na.omit))
    if (!is.null(control)) args$control <- control
    return(do.call(glmmTMB::glmmTMB, args))
  }
  if (method == "coxph") {
    .require_namespace("survival", "Cox proportional-hazards models")
    args <- add_weights(list(formula = formula, data = data,
      na.action = stats::na.omit, model = TRUE, x = TRUE, y = TRUE))
    return(do.call(survival::coxph, args))
  }
  if (method == "survreg") {
    .require_namespace("survival", "parametric survival models")
    args <- add_weights(list(formula = formula, data = data,
      na.action = stats::na.omit, model = TRUE, x = TRUE, y = TRUE))
    return(do.call(survival::survreg, args))
  }
  .sw_abort("Unsupported method: ", method)
}

.fit_analysis <- function(formula, data, family = NULL, weights = NULL,
                          method = "auto", engine = NULL, control = NULL) {
  method <- .detect_method(formula, family, method)
  engine <- engine %||% .default_engine
  model <- .call_engine(engine, list(
    formula = formula, data = data, family = family, weights = weights,
    method = method, control = control
  ))
  supported <- inherits(model, c("lm", "glm", "aov", "merMod", "glmmTMB", "coxph", "survreg"))
  if (!supported) {
    .sw_abort("The fitting engine returned an unsupported model class: ", paste(class(model), collapse = ", "), ".")
  }
  model
}

.refit <- function(info, data, formula = info$formula, weights = info$weights,
                   control = info$control) {
  .fit_analysis(
    formula = formula,
    data = data,
    family = info$family_object,
    weights = weights,
    method = info$method,
    engine = info$engine,
    control = control
  )
}

.format_num <- function(x, digits = 4L) {
  if (length(x) == 0L || is.na(x)) return("NA")
  formatC(x, digits = digits, format = "fg", flag = "#")
}

.test_domain <- function(id) {
  computational <- c(
    "row_order", "formula_order", "model_frame", "prediction_reconstruction",
    "factor_label_invariance", "predictor_rescaling", "focus_reference_reversal",
    "outcome_translation", "outcome_scaling", "known_effect_injection",
    "independent_qr", "binary_outcome_reversal", "likelihood_reconstruction",
    "weight_semantics", "group_label_invariance", "survival_time_scaling",
    "event_coding", "rm_row_order", "rm_id_label", "rm_outcome_translation",
    "rm_outcome_scaling"
  )
  numerical <- c(
    "mixed_convergence", "mixed_singularity", "optimizer_agreement",
    "random_structure", "model_convergence", "fixed_design_condition"
  )
  design <- c(
    "design_support", "anova_cell_audit", "anova_term_order", "mixed_design_adequacy",
    "survival_information", "rm_design_integrity", "rm_sphericity"
  )
  assumptions <- c(
    "residual_shape", "residual_variance", "glm_dispersion",
    "binomial_separation", "cox_ph_assumption", "rm_residual_shape"
  )
  influence <- c(
    "case_influence", "group_influence", "survival_influence", "rm_id_influence"
  )
  if (id %in% computational) return("computational_integrity")
  if (id %in% numerical) return("numerical_stability")
  if (id %in% design) return("design_adequacy")
  if (id %in% assumptions) return("assumption_screening")
  if (id %in% influence) return("influence_stability")
  "other"
}

.new_test <- function(id, label, status, severity = "critical",
                      expected = "", observed = "", details = "",
                      domain = .test_domain(id)) {
  list(id = id, label = label, status = status, severity = severity,
       domain = domain, expected = expected, observed = observed, details = details)
}

.test_to_row <- function(x) {
  data.frame(id = x$id, test = x$label, status = x$status,
             severity = x$severity, domain = x$domain %||% .test_domain(x$id),
             expected = x$expected, observed = x$observed, details = x$details,
             stringsAsFactors = FALSE)
}

.safe_test <- function(expr, id, label) {
  tryCatch(expr, error = function(e) {
    .new_test(id, label, "ERROR", "critical",
              expected = "The validation experiment should run successfully.",
              observed = conditionMessage(e),
              details = "The audit implementation could not complete this test.")
  })
}

.md5_object <- function(x) {
  path <- tempfile(fileext = ".rds")
  on.exit(unlink(path), add = TRUE)
  saveRDS(x, path, version = 3)
  unname(tools::md5sum(path))
}
