# Cross-model diagnostic and influence audits ---------------------------------

.test_fixed_design_condition <- function(info) {
  X <- tryCatch(.model_matrix_fixed(info$model), error = function(e) NULL)
  if (is.null(X) || !is.matrix(X) || !ncol(X)) {
    return(.new_test(
      "fixed_design_condition", "Fixed-effect design conditioning", "WARN",
      severity = "warning",
      expected = "A reconstructable fixed-effect design matrix.",
      observed = "The fixed-effect design matrix was unavailable.",
      details = "Conditioning and rank could not be evaluated automatically."
    ))
  }
  q <- qr(X)
  rank <- q$rank
  p <- ncol(X)
  cond <- tryCatch(kappa(X, exact = FALSE), error = function(e) Inf)
  aliased <- p - rank
  issue <- aliased > 0L || !is.finite(cond) || cond > 1e8
  .new_test(
    "fixed_design_condition", "Fixed-effect design conditioning",
    if (issue) "WARN" else "PASS", severity = "warning",
    expected = "Full column rank and no extreme numerical conditioning.",
    observed = paste0("columns = ", p, "; rank = ", rank,
                      "; aliased columns = ", aliased,
                      "; condition number = ", .format_num(cond)),
    details = if (issue) {
      "The fixed-effect design is rank deficient or extremely ill-conditioned; coefficients and omnibus tests may be unstable or non-identifiable."
    } else {
      "No fixed-effect rank deficiency or extreme conditioning was detected."
    }
  )
}

.finite_residuals <- function(model, type = NULL) {
  r <- tryCatch({
    if (is.null(type)) stats::residuals(model) else stats::residuals(model, type = type)
  }, error = function(e) numeric())
  r <- as.numeric(r)
  r[is.finite(r)]
}

.test_residual_shape <- function(info) {
  r <- .finite_residuals(info$model)
  n <- length(r)
  if (n < 8L || stats::sd(r) == 0) {
    return(.new_test(
      "residual_shape", "Residual-shape screening", "WARN", severity = "warning",
      expected = "Enough nonconstant residuals for a shape screen.",
      observed = paste0("usable residuals = ", n),
      details = "Residual shape could not be screened reliably."
    ))
  }
  z <- (r - mean(r)) / stats::sd(r)
  skew <- mean(z^3)
  excess <- mean(z^4) - 3
  issue <- abs(skew) > 2 || excess > 7
  .new_test(
    "residual_shape", "Residual-shape screening",
    if (issue) "WARN" else "PASS", severity = "warning",
    expected = "No extreme residual skewness or tail heaviness.",
    observed = paste0("skewness = ", .format_num(skew),
                      "; excess kurtosis = ", .format_num(excess),
                      "; residuals = ", n),
    details = if (issue) {
      "The residual distribution is strongly asymmetric or heavy-tailed. Inspect residual plots and consider a more appropriate outcome model or robust analysis."
    } else {
      "No extreme residual-shape problem was detected. This screen does not prove normality."
    }
  )
}

.test_residual_variance <- function(info) {
  r <- .finite_residuals(info$model)
  f <- tryCatch(as.numeric(stats::fitted(info$model)), error = function(e) numeric())
  n_common <- min(length(r), length(f))
  if (!n_common) {
    return(.new_test(
      "residual_variance", "Residual-variance screening", "WARN", severity = "warning",
      expected = "Matched residual and fitted-value vectors.",
      observed = "No matched residual/fitted values were available.",
      details = "Residual-variance heterogeneity could not be screened reliably."
    ))
  }
  r <- r[seq_len(n_common)]
  f <- f[seq_len(n_common)]
  keep <- is.finite(r) & is.finite(f)
  r <- r[keep]
  f <- f[keep]
  if (length(r) < 20L || length(unique(f)) < 4L) {
    return(.new_test(
      "residual_variance", "Residual-variance screening", "WARN", severity = "warning",
      expected = "Enough fitted-value variation to compare residual variance.",
      observed = paste0("usable observations = ", length(r),
                        "; unique fitted values = ", length(unique(f))),
      details = "Residual-variance heterogeneity could not be screened reliably."
    ))
  }
  breaks <- unique(stats::quantile(f, probs = seq(0, 1, length.out = 5), na.rm = TRUE))
  if (length(breaks) < 3L) {
    return(.new_test(
      "residual_variance", "Residual-variance screening", "WARN", severity = "warning",
      expected = "At least three fitted-value bins.",
      observed = paste0("distinct quantile breaks = ", length(breaks)),
      details = "Fitted values were too concentrated for the automatic variance screen."
    ))
  }
  bins <- cut(f, breaks = breaks, include.lowest = TRUE, labels = FALSE)
  vars <- vapply(split(r, bins), function(x) if (length(x) >= 3L) stats::var(x) else NA_real_, numeric(1))
  vars <- vars[is.finite(vars) & vars > 0]
  ratio <- if (length(vars) >= 2L) max(vars) / min(vars) else NA_real_
  issue <- is.finite(ratio) && ratio > 4
  .new_test(
    "residual_variance", "Residual-variance screening",
    if (issue) "WARN" else if (is.na(ratio)) "WARN" else "PASS",
    severity = "warning",
    expected = "No large residual-variance differences across fitted-value regions.",
    observed = paste0("largest/smallest binned residual variance ratio = ", .format_num(ratio)),
    details = if (issue) {
      "Residual variance differs substantially across fitted-value regions; inspect heteroskedasticity and group-specific variance."
    } else if (is.na(ratio)) {
      "Too few usable variance bins were available for evaluation."
    } else {
      "No large fitted-value-related variance difference was detected by the screening rule."
    }
  )
}

.test_model_convergence <- function(info) {
  if (info$model_class == "glm") {
    ok <- isTRUE(info$model$converged) && is.finite(info$model$deviance)
    return(.new_test(
      "model_convergence", "Model convergence audit", if (ok) "PASS" else "WARN",
      severity = "warning",
      expected = "The iterative fit reports convergence and finite deviance.",
      observed = paste0("converged = ", info$model$converged,
                        "; iterations = ", info$model$iter,
                        "; finite deviance = ", is.finite(info$model$deviance)),
      details = if (ok) "The GLM reported successful convergence." else "The GLM did not report a clean converged solution."
    ))
  }
  if (info$model_class %in% c("coxph", "survreg")) {
    beta <- .fixed_coef(info$model)
    finite <- all(is.finite(beta))
    iter <- info$model$iter %||% NA_integer_
    return(.new_test(
      "model_convergence", "Model convergence audit", if (finite) "PASS" else "WARN",
      severity = "warning",
      expected = "Finite fitted coefficients and no reported fitting failure.",
      observed = paste0("finite coefficients = ", finite,
                        "; iterations = ", paste(iter, collapse = ", ")),
      details = if (finite) "No non-finite fitted coefficient was detected." else "At least one coefficient is non-finite; the survival fit requires review."
    ))
  }
  .new_test(
    "model_convergence", "Model convergence audit", "PASS", severity = "warning",
    expected = "A closed-form or directly solved fit without iterative convergence failure.",
    observed = "No model-specific iterative convergence failure applies.",
    details = "This model is not audited through an iterative convergence flag."
  )
}

.test_glm_dispersion <- function(info) {
  r <- .finite_residuals(info$model, type = "pearson")
  df <- tryCatch(stats::df.residual(info$model), error = function(e) NA_real_)
  dispersion <- if (length(r) && is.finite(df) && df > 0) sum(r^2) / df else NA_real_
  high <- is.finite(dispersion) && dispersion > 1.5
  low <- info$family == "poisson" && is.finite(dispersion) && dispersion < 0.5
  issue <- high || low
  .new_test(
    "glm_dispersion", "Generalized-model dispersion audit",
    if (issue) "WARN" else if (!is.finite(dispersion)) "WARN" else "PASS",
    severity = "warning",
    expected = "Pearson dispersion reasonably compatible with the declared mean-variance family.",
    observed = paste0("Pearson dispersion = ", .format_num(dispersion),
                      "; residual df = ", .format_num(df)),
    details = if (high) {
      "Substantial overdispersion was detected; standard errors and the response family may require review."
    } else if (low) {
      "Substantial underdispersion was detected relative to a Poisson model."
    } else if (!is.finite(dispersion)) {
      "Dispersion could not be computed automatically."
    } else {
      "No large dispersion discrepancy was detected."
    }
  )
}

.test_binomial_separation <- function(info) {
  beta <- .fixed_coef(info$model)
  V <- tryCatch(.fixed_vcov(info$model), error = function(e) matrix(NA_real_, 0, 0))
  se <- if (length(V)) sqrt(diag(V)) else rep(NA_real_, length(beta))
  fitted <- tryCatch(.model_response_prediction(info$model), error = function(e) numeric())
  extreme <- if (length(fitted)) mean(fitted < 1e-8 | fitted > 1 - 1e-8, na.rm = TRUE) else NA_real_
  issue <- any(!is.finite(beta)) || any(abs(beta) > 20, na.rm = TRUE) ||
    any(se > 10, na.rm = TRUE) || (is.finite(extreme) && extreme > 0.25)
  max_beta <- if (any(is.finite(beta))) max(abs(beta[is.finite(beta)])) else Inf
  max_se <- if (any(is.finite(se))) max(se[is.finite(se)]) else Inf
  .new_test(
    "binomial_separation", "Binomial separation screening",
    if (issue) "WARN" else "PASS", severity = "warning",
    expected = "Finite, moderately scaled coefficients without widespread boundary probabilities.",
    observed = paste0("maximum |coefficient| = ", .format_num(max_beta),
                      "; maximum SE = ", .format_num(max_se),
                      "; boundary-probability fraction = ", .format_num(extreme)),
    details = if (issue) {
      "The fit shows signs compatible with complete/quasi separation or weakly identified binomial effects. Confirm with a dedicated separation diagnostic."
    } else {
      "No strong numerical sign of binomial separation was detected."
    }
  )
}

.test_case_influence <- function(info) {
  cd <- tryCatch(stats::cooks.distance(info$model), error = function(e) numeric())
  cd <- as.numeric(cd)
  cd <- cd[is.finite(cd)]
  n <- length(cd)
  if (!n) {
    return(.new_test(
      "case_influence", "Case-level influence screening", "WARN", severity = "warning",
      expected = "Available case-deletion influence diagnostics.",
      observed = "Cook's distance was unavailable.",
      details = "Case-level influence could not be screened automatically for this fitted object."
    ))
  }
  threshold <- 4 / n
  n_flag <- sum(cd > threshold)
  max_cd <- max(cd)
  issue <- max_cd > 1 || n_flag > max(2L, ceiling(0.05 * n))
  .new_test(
    "case_influence", "Case-level influence screening",
    if (issue) "WARN" else "PASS", severity = "warning",
    expected = "No single case with Cook's distance above 1 and no large concentration above 4/n.",
    observed = paste0("maximum Cook's distance = ", .format_num(max_cd),
                      "; cases above 4/n = ", n_flag, " of ", n),
    details = if (issue) {
      "Potentially influential observations were detected; inspect case-deletion estimates and data quality."
    } else {
      "No strong case-level influence signal was detected by Cook's-distance screening."
    }
  )
}

.random_slope_map <- function(formula) {
  if (!.has_random_terms(formula)) return(list())
  .require_namespace("reformulas", "mixed-model design inspection")
  bars <- reformulas::findbars(formula)
  out <- list()
  for (bar in bars) {
    groups <- all.vars(bar[[3L]])
    slopes <- all.vars(bar[[2L]])
    for (g in groups) out[[g]] <- unique(c(out[[g]], slopes))
  }
  out
}

.test_mixed_design_adequacy <- function(info) {
  slope_map <- .random_slope_map(info$formula)
  findings <- character()
  for (g in info$random_groups) {
    if (!g %in% names(info$data)) next
    slopes <- slope_map[[g]] %||% character()
    candidates <- setdiff(info$simple_predictors, c(g, slopes))
    for (v in candidates) {
      split_values <- split(info$data[[v]], info$data[[g]], drop = TRUE)
      varies <- vapply(split_values, function(x) length(unique(stats::na.omit(x))) > 1L, logical(1))
      proportion <- if (length(varies)) mean(varies) else 0
      if (proportion >= 0.5) {
        findings <- c(findings, paste0(v, " varies within ", g,
                                      " for ", round(100 * proportion),
                                      "% of groups but has no registered random slope"))
      }
    }
  }
  issue <- length(findings) > 0L
  .new_test(
    "mixed_design_adequacy", "Random-effects design audit",
    if (issue) "WARN" else "PASS", severity = "warning",
    expected = "Within-cluster predictors are identified and compared with the specified random-slope structure.",
    observed = if (issue) paste(findings, collapse = "; ") else "No obvious omitted within-group slope candidate was detected.",
    details = if (issue) {
      "This is a design review item, not an automatic instruction to add every possible random slope. Compare scientifically defensible random-effects structures."
    } else {
      "The automatic design screen found no simple within-group predictor omitted from all corresponding random-slope terms."
    }
  )
}

.focus_snapshot <- function(info, conf_level = 0.95) {
  out <- tryCatch(.primary_result(info, conf_level), error = function(e) NULL)
  if (is.null(out)) return(NULL)
  if (out$kind == "term") {
    list(kind = "term", statistic = out$statistic, p_value = out$p_value)
  } else {
    list(kind = "coefficient", estimate = out$estimate, p_value = out$p_value)
  }
}

.test_group_influence <- function(info, variable, conf_level = 0.95, max_groups = 30L) {
  groups <- unique(stats::na.omit(info$data[[variable]]))
  if (length(groups) < 3L) {
    return(.new_test(
      "group_influence", paste0("Group-deletion influence: ", variable), "WARN",
      severity = "warning",
      expected = "At least three groups for deletion-based influence screening.",
      observed = paste0("groups = ", length(groups)),
      details = "Group-deletion influence was not evaluated."
    ))
  }
  if (length(groups) > max_groups) {
    return(.new_test(
      "group_influence", paste0("Group-deletion influence: ", variable), "WARN",
      severity = "warning",
      expected = paste0("At most ", max_groups, " groups in the selected audit level."),
      observed = paste0("groups = ", length(groups)),
      details = "The complete leave-one-group-out audit was skipped to control computation; use audit_level = 'thorough' to raise the limit."
    ))
  }
  base <- .focus_snapshot(info, conf_level)
  if (is.null(base)) {
    return(.new_test("group_influence", paste0("Group-deletion influence: ", variable), "WARN",
      severity = "warning", expected = "A reproducible primary focus result.",
      observed = "The primary result could not be reconstructed for influence analysis.",
      details = "Group-deletion influence was not evaluated."))
  }
  changes <- numeric()
  pvals <- numeric()
  reversals <- logical()
  failures <- 0L
  labels <- character()
  for (g in groups) {
    keep <- !is.na(info$data[[variable]]) & info$data[[variable]] != g
    d2 <- info$data[keep, , drop = FALSE]
    w2 <- if (is.null(info$weights)) NULL else info$weights[keep]
    snap <- tryCatch({
      m2 <- .refit(info, d2, weights = w2)
      focus_arg <- if (info$focus_kind == "term") info$focus_term else info$focus_coef
      info2 <- .inspect_analysis(m2, info$formula, d2, focus_arg, w2,
                                info$engine, info$method, info$control)
      .focus_snapshot(info2, conf_level)
    }, error = function(e) NULL)
    if (is.null(snap)) {
      failures <- failures + 1L
      next
    }
    labels <- c(labels, as.character(g))
    pvals <- c(pvals, snap$p_value)
    if (base$kind == "coefficient") {
      denom <- max(abs(base$estimate), 1e-8)
      changes <- c(changes, abs(snap$estimate - base$estimate) / denom)
      reversals <- c(reversals, sign(snap$estimate) != sign(base$estimate))
    } else {
      denom <- max(abs(base$statistic), 1e-8)
      changes <- c(changes, abs(snap$statistic - base$statistic) / denom)
      reversals <- c(reversals, (snap$p_value < 0.05) != (base$p_value < 0.05))
    }
  }
  if (!length(changes)) {
    return(.new_test("group_influence", paste0("Group-deletion influence: ", variable), "WARN",
      severity = "warning", expected = "At least one successful leave-one-group-out refit.",
      observed = paste0("failed refits = ", failures),
      details = "No group-deletion refit completed successfully."))
  }
  idx <- which.max(changes)
  issue <- any(reversals) || max(changes) > 0.5
  .new_test(
    "group_influence", paste0("Group-deletion influence: ", variable),
    if (issue) "WARN" else "PASS", severity = "warning",
    expected = "The focus result remains directionally/decisionally stable and changes by no more than 50% after deleting one group.",
    observed = paste0("largest relative focus change = ", .format_num(max(changes)),
                      " after deleting ", labels[[idx]],
                      "; conclusion reversals = ", sum(reversals),
                      "; failed refits = ", failures),
    details = if (issue) {
      "The focus result is sensitive to at least one grouping level; inspect leave-one-group-out estimates and that group's data."
    } else {
      "No single grouping level caused a large focus change or decision reversal."
    }
  )
}

.test_survival_information <- function(info) {
  parts <- .surv_response_parts(info$formula)
  if (length(parts) < 2L || !parts[[2L]] %in% names(info$data)) {
    return(.new_test(
      "survival_information", "Survival information audit", "WARN", severity = "warning",
      expected = "An identifiable event indicator.",
      observed = "Event counts could not be reconstructed.",
      details = "The amount of event information per fitted coefficient was not evaluated."
    ))
  }
  event <- info$data[[parts[[2L]]]]
  events <- sum(event == 1, na.rm = TRUE)
  p <- sum(is.finite(.fixed_coef(info$model)))
  ratio <- if (p > 0) events / p else NA_real_
  issue <- is.finite(ratio) && ratio < 5
  .new_test(
    "survival_information", "Survival information audit",
    if (issue) "WARN" else "PASS", severity = "warning",
    expected = "Enough observed events to support the fitted coefficient count.",
    observed = paste0("events = ", events, "; fitted coefficients = ", p,
                      "; events per coefficient = ", .format_num(ratio)),
    details = if (issue) {
      "Very limited event information was detected relative to model size; estimates may be unstable. This is a screening threshold, not a universal sample-size rule."
    } else {
      "No very low event-to-parameter ratio was detected by the screening rule."
    }
  )
}

.test_survival_influence <- function(info) {
  d <- tryCatch(stats::residuals(info$model, type = "dfbeta"), error = function(e) NULL)
  if (is.null(d)) {
    return(.new_test(
      "survival_influence", "Survival influence screening", "WARN", severity = "warning",
      expected = "Available DFBETA residuals.", observed = "DFBETA residuals were unavailable.",
      details = "Observation-level survival influence could not be screened automatically."
    ))
  }
  d <- as.matrix(d)
  n <- nrow(d)
  threshold <- if (n > 0) 2 / sqrt(n) else NA_real_
  max_d <- max(abs(d), na.rm = TRUE)
  n_flag <- sum(apply(abs(d), 1L, max, na.rm = TRUE) > threshold)
  issue <- is.finite(max_d) && max_d > max(0.5, threshold * 3)
  .new_test(
    "survival_influence", "Survival influence screening",
    if (issue) "WARN" else "PASS", severity = "warning",
    expected = "No observation with an unusually large DFBETA profile.",
    observed = paste0("maximum |DFBETA| = ", .format_num(max_d),
                      "; rows above 2/sqrt(n) = ", n_flag, " of ", n),
    details = if (issue) "At least one observation may strongly influence a survival coefficient." else "No extreme DFBETA influence signal was detected."
  )
}

.domain_status <- function(test_rows) {
  if (!nrow(test_rows)) return("NOT EVALUATED")
  if (any(test_rows$status %in% c("FAIL", "ERROR") & test_rows$severity == "critical")) return("FAILED")
  if (any(test_rows$status %in% c("WARN", "FAIL", "ERROR"))) return("REVIEW")
  "PASSED"
}

.domain_summary <- function(tests) {
  domains <- c(
    "computational_integrity", "numerical_stability", "design_adequacy",
    "assumption_screening", "influence_stability"
  )
  extra <- setdiff(unique(tests$domain), domains)
  domains <- c(domains, extra)
  out <- do.call(rbind, lapply(domains, function(d) {
    x <- tests[tests$domain == d, , drop = FALSE]
    data.frame(
      domain = d,
      status = .domain_status(x),
      passed = sum(x$status == "PASS"),
      review = sum(x$status %in% c("WARN", "FAIL", "ERROR")),
      stringsAsFactors = FALSE
    )
  }))
  rownames(out) <- NULL
  out
}

.test_design_support <- function(info) {
  n <- tryCatch(.model_nobs(info$model), error = function(e) NA_integer_)
  beta <- tryCatch(.fixed_coef(info$model), error = function(e) numeric())
  p <- sum(is.finite(beta))
  rdf <- tryCatch(stats::df.residual(info$model), error = function(e) NA_real_)
  min_level <- Inf
  level_label <- NA_character_
  if (length(info$factor_predictors)) {
    for (v in info$factor_predictors) {
      tab <- table(info$data[[v]], useNA = "no")
      if (length(tab) && min(tab) < min_level) {
        min_level <- min(tab)
        level_label <- v
      }
    }
  }
  if (!is.finite(min_level)) min_level <- NA_real_
  severe <- (is.finite(n) && p > 0L && n <= p) ||
    (is.finite(rdf) && rdf <= 0) ||
    (is.finite(min_level) && min_level < 2)
  .new_test(
    "design_support", "Basic design-support audit",
    if (severe) "WARN" else "PASS", severity = "warning",
    expected = "More analysed observations than estimable fixed coefficients and no singleton fixed-factor level.",
    observed = paste0("observations = ", n,
                      "; estimable fixed coefficients = ", p,
                      "; residual df = ", .format_num(rdf),
                      "; smallest fixed-factor level = ", .format_num(min_level),
                      if (!is.na(level_label)) paste0(" (", level_label, ")") else ""),
    details = if (severe) {
      "The fitted design has extremely limited information, nonpositive residual degrees of freedom, or a singleton factor level."
    } else {
      "No severe basic design-support problem was detected. This is not a formal power or sample-size assessment."
    }
  )
}
