# Combined tests from ci/
# Auto-generated by workspace refactor script
# ===== BEGIN ci/test-site-map-tools.R =====
skip_if_not_test_level("ci")
find_package_root <- function() {
source_root <- Sys.getenv("DPMIXGPD_SOURCE_ROOT", unset = "")
if (nzchar(source_root)) {
source_root <- normalizePath(source_root, winslash = "/", mustWork = FALSE)
if (file.exists(file.path(source_root, "DESCRIPTION")) &&
file.exists(file.path(source_root, "tools", "site-map", "extract_site_map.R"))) {
return(source_root)
}
}
current <- normalizePath(getwd(), winslash = "/", mustWork = TRUE)
for (i in 0:8) {
candidate <- current
if (file.exists(file.path(candidate, "DESCRIPTION"))) {
return(candidate)
}
current <- dirname(current)
}
stop("Could not locate package root for site-map tests.")
}
pkg_root <- find_package_root()
source(file.path(pkg_root, "tools", "site-map", "extract_site_map.R"), local = TRUE)
source(file.path(pkg_root, "tools", "site-map", "analyze_site_map.R"), local = TRUE)
write_fixture_file <- function(path, lines) {
dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
writeLines(lines, con = path, useBytes = TRUE)
}
make_workflow_pages <- function(docs_root, break_chain = FALSE) {
for (i in 1:20) {
file_path <- file.path(docs_root, "workflows", sprintf("v%02d-topic.html", i))
link_html <- ""
if (i < 20) {
if (!(break_chain && i == 10)) {
link_html <- sprintf("next", i + 1L)
}
}
write_fixture_file(
file_path,
c(
"",
sprintf("v%02d
", i),
link_html,
""
)
)
}
}
test_that("extract_site_map handles strict internal links and normalization", {
tmp_root <- tempfile("site_map_extract_")
docs_root <- file.path(tmp_root, "docs")
out_root <- file.path(tmp_root, "out")
dir.create(docs_root, recursive = TRUE, showWarnings = FALSE)
write_fixture_file(
file.path(docs_root, "index.html"),
c(
"",
"workflow",
"broken",
"workflows-dir",
"external",
"mail",
"js",
"anchor",
""
)
)
write_fixture_file(
file.path(docs_root, "workflows", "index.html"),
c("", "home", "")
)
write_fixture_file(
file.path(docs_root, "workflows", "v01-start-here.html"),
c(
"",
"back-home",
"next-no-ext",
""
)
)
write_fixture_file(
file.path(docs_root, "workflows", "v02-introduction.html"),
c("", "ok", "")
)
extract_site_map(site_root = docs_root, output_dir = out_root, verbose = FALSE)
edges <- read.csv(file.path(out_root, "website_link_edges.csv"), stringsAsFactors = FALSE)
expect_true(any(edges$href_raw == "missing-page.html" & !as.logical(edges$target_exists)))
expect_true(any(edges$href_raw == "../index.html#intro" & edges$target == "index.html"))
expect_true(any(edges$href_raw == "v02-introduction" & edges$target == "workflows/v02-introduction.html"))
expect_true(any(edges$href_raw == "workflows/" & edges$target == "workflows/index.html"))
# External/anchor hrefs are intentionally ignored by extractor.
expect_false(any(grepl("^https?://", edges$href_raw)))
expect_false(any(grepl("^mailto:", edges$href_raw)))
expect_false(any(grepl("^javascript:", edges$href_raw)))
expect_false(any(grepl("^#", edges$href_raw)))
})
test_that("analyze_site_map gate follows broken-link and workflow-chain policy", {
tmp_root <- tempfile("site_map_analyze_")
docs_root <- file.path(tmp_root, "docs")
out_root <- file.path(tmp_root, "out")
dir.create(docs_root, recursive = TRUE, showWarnings = FALSE)
write_fixture_file(
file.path(docs_root, "index.html"),
c(
"",
"start",
""
)
)
make_workflow_pages(docs_root = docs_root, break_chain = FALSE)
extract_site_map(site_root = docs_root, output_dir = out_root, verbose = FALSE)
ok_result <- analyze_site_map(site_root = docs_root, output_dir = out_root, verbose = FALSE)
expect_true(isTRUE(ok_result$summary$gate_pass))
expect_equal(ok_result$summary$broken_link_count, 0)
expect_equal(ok_result$summary$workflow_chain_break_count, 0)
# Rebuild with a broken chain and a broken link.
unlink(tmp_root, recursive = TRUE, force = TRUE)
dir.create(docs_root, recursive = TRUE, showWarnings = FALSE)
write_fixture_file(
file.path(docs_root, "index.html"),
c(
"",
"start",
"broken",
""
)
)
make_workflow_pages(docs_root = docs_root, break_chain = TRUE)
extract_site_map(site_root = docs_root, output_dir = out_root, verbose = FALSE)
bad_result <- analyze_site_map(site_root = docs_root, output_dir = out_root, verbose = FALSE)
expect_false(isTRUE(bad_result$summary$gate_pass))
expect_gt(bad_result$summary$broken_link_count, 0)
expect_gt(bad_result$summary$workflow_chain_break_count, 0)
})
# ===== END ci/test-site-map-tools.R =====
# ===== BEGIN ci/test-vignette-coverage.R =====
# test-vignette-coverage.R
# =============================================================================
# Tests that exercise code paths from vignettes for coverage
# These tests use short MCMC runs to be fast while still exercising the code
# =============================================================================
# Use package's test level system - these run at "ci" level and above
# They will run during coverage calculation (DPMIXGPD_TEST_LEVEL="ci")
# but skip during R CMD check (DPMIXGPD_TEST_LEVEL="cran")
# Short MCMC settings for fast execution
mcmc_short <- list(niter = 50, nburnin = 10, thin = 1, nchains = 1, seed = 1)
# Helper to suppress MCMC output
quiet_run <- function(expr) {
nullfile <- if (.Platform$OS.type == "windows") "NUL" else "/dev/null"
utils::capture.output(result <- force(expr), file = nullfile)
result
}
# =============================================================================
# Unconditional Models (from v05-v09 vignettes)
# =============================================================================
test_that("unconditional CRP bulk model works (v05 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("nc_pos200_k3", package = "CausalMixGPD")
y <- nc_pos200_k3$y[1:50] # Use subset for speed
bundle <- build_nimble_bundle(
y = y,
backend = "crp",
kernel = "gamma",
GPD = FALSE,
components = 3,
monitor_latent = TRUE,
mcmc = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_bundle")
# Test print and summary
expect_output(print(bundle))
expect_output(print(summary(bundle)))
# Run MCMC
fit <- quiet_run(run_mcmc_bundle_manual(bundle, show_progress = FALSE))
expect_s3_class(fit, "mixgpd_fit")
# Test S3 methods
expect_output(print(fit))
summ <- summary(fit)
expect_s3_class(summ, "mixgpd_summary")
expect_output(print(summ))
# Test params
p <- params(fit)
expect_s3_class(p, "mixgpd_params")
expect_output(print(p))
# Test predict methods
pred_q <- predict(fit, type = "quantile", index = c(0.5, 0.9))
expect_s3_class(pred_q, "mixgpd_predict")
pred_d <- predict(fit, y = y[1:5], type = "density")
expect_s3_class(pred_d, "mixgpd_predict")
pred_s <- predict(fit, y = y[1:5], type = "survival")
expect_s3_class(pred_s, "mixgpd_predict")
})
test_that("unconditional SB bulk model works (v07 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("nc_pos200_k3", package = "CausalMixGPD")
y <- nc_pos200_k3$y[1:50]
bundle <- build_nimble_bundle(
y = y,
backend = "sb",
kernel = "lognormal",
GPD = FALSE,
components = 3,
mcmc = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_bundle")
fit <- quiet_run(run_mcmc_bundle_manual(bundle, show_progress = FALSE))
expect_s3_class(fit, "mixgpd_fit")
# fitted() not supported for unconditional; use predict() only
})
test_that("unconditional SB GPD model works (v09 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("nc_pos200_k3", package = "CausalMixGPD")
y <- nc_pos200_k3$y[1:50]
bundle <- build_nimble_bundle(
y = y,
backend = "sb",
kernel = "gamma",
GPD = TRUE,
components = 3,
mcmc = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_bundle")
fit <- quiet_run(run_mcmc_bundle_manual(bundle, show_progress = FALSE))
expect_s3_class(fit, "mixgpd_fit")
})
# =============================================================================
# Conditional Models (from v10-v13 vignettes)
# =============================================================================
test_that("conditional SB bulk model works (v11 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("nc_posX100_p3_k2", package = "CausalMixGPD")
y <- nc_posX100_p3_k2$y[1:40]
X <- as.matrix(nc_posX100_p3_k2$X[1:40, ])
bundle <- build_nimble_bundle(
y = y,
X = X,
backend = "sb",
kernel = "lognormal",
GPD = FALSE,
components = 3,
mcmc = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_bundle")
fit <- quiet_run(run_mcmc_bundle_manual(bundle, show_progress = FALSE))
expect_s3_class(fit, "mixgpd_fit")
# Test conditional predict
x_new <- X[1:5, , drop = FALSE]
pred_mean <- predict(fit, newdata =x_new, type = "mean", nsim_mean = 20)
expect_s3_class(pred_mean, "mixgpd_predict")
})
test_that("conditional SB GPD model works (v13 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("nc_posX100_p3_k2", package = "CausalMixGPD")
y <- nc_posX100_p3_k2$y[1:40]
X <- as.matrix(nc_posX100_p3_k2$X[1:40, ])
bundle <- build_nimble_bundle(
y = y,
X = X,
backend = "sb",
kernel = "lognormal",
GPD = TRUE,
components = 3,
mcmc = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_bundle")
fit <- quiet_run(run_mcmc_bundle_manual(bundle, show_progress = FALSE))
expect_s3_class(fit, "mixgpd_fit")
})
# =============================================================================
# Causal Models (from v14-v19 vignettes)
# =============================================================================
test_that("causal no-X CRP model works (v14 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("causal_alt_real500_p4_k2", package = "CausalMixGPD")
y <- abs(causal_alt_real500_p4_k2$y[1:80]) + 0.01
T_vec <- causal_alt_real500_p4_k2$A[1:80]
bundle <- build_causal_bundle(
y = y,
A = T_vec,
X = NULL,
kernel = "gamma",
backend = "crp",
PS = FALSE,
GPD = FALSE,
components = 3,
monitor_latent = TRUE,
mcmc_outcome = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_causal_bundle")
expect_output(print(bundle))
expect_output(print(summary(bundle)))
fit <- quiet_run(run_mcmc_causal(bundle, show_progress = FALSE))
expect_s3_class(fit, "causalmixgpd_causal_fit")
# Test causal S3 methods
expect_output(print(fit))
expect_output(print(summary(fit)))
# Test causal params
p <- params(fit)
expect_s3_class(p, "mixgpd_params_pair")
expect_output(print(p))
# Test causal predict
pred <- predict(fit, type = "mean", nsim_mean = 20)
expect_s3_class(pred, "causalmixgpd_causal_predict")
# Test QTE
qte_result <- qte(fit, probs = c(0.5), interval = "credible")
expect_s3_class(qte_result, "causalmixgpd_qte")
expect_output(print(qte_result))
summ_qte <- summary(qte_result)
expect_output(print(summ_qte))
# Test ATE
ate_result <- ate(fit, interval = "credible", nsim_mean = 20)
expect_s3_class(ate_result, "causalmixgpd_ate")
expect_output(print(ate_result))
summ_ate <- summary(ate_result)
expect_output(print(summ_ate))
})
test_that("causal X no-PS SB model works (v15 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("causal_alt_real500_p4_k2", package = "CausalMixGPD")
y <- abs(causal_alt_real500_p4_k2$y[1:80]) + 0.01
T_vec <- causal_alt_real500_p4_k2$A[1:80]
X <- as.matrix(causal_alt_real500_p4_k2$X[1:80, 1:2])
bundle <- build_causal_bundle(
y = y,
A = T_vec,
X = X,
kernel = "lognormal",
backend = "sb",
PS = FALSE,
GPD = FALSE,
components = 3,
mcmc_outcome = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_causal_bundle")
fit <- quiet_run(run_mcmc_causal(bundle, show_progress = FALSE))
expect_s3_class(fit, "causalmixgpd_causal_fit")
# Test causal predict with multiple types
pred_q <- predict(fit, type = "quantile", p = c(0.25, 0.75))
expect_s3_class(pred_q, "causalmixgpd_causal_predict")
pred_d <- predict(fit, newdata =X[1:5, , drop = FALSE], y = y[1:5], type = "density")
expect_s3_class(pred_d, "causalmixgpd_causal_predict")
pred_s <- predict(fit, newdata =X[1:5, , drop = FALSE], y = y[1:5], type = "survival")
expect_s3_class(pred_s, "causalmixgpd_causal_predict")
})
test_that("causal no-X SB model works (v16 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("causal_alt_real500_p4_k2", package = "CausalMixGPD")
y <- abs(causal_alt_real500_p4_k2$y[1:80]) + 0.01
T_vec <- causal_alt_real500_p4_k2$A[1:80]
bundle <- build_causal_bundle(
y = y,
A = T_vec,
X = NULL,
kernel = "lognormal",
backend = "sb",
PS = FALSE,
GPD = FALSE,
components = 3,
mcmc_outcome = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_causal_bundle")
fit <- quiet_run(run_mcmc_causal(bundle, show_progress = FALSE))
expect_s3_class(fit, "causalmixgpd_causal_fit")
# Test QTE with multiple quantiles
qte_result <- qte(fit, probs = c(0.25, 0.5, 0.75), interval = "credible")
expect_s3_class(qte_result, "causalmixgpd_qte")
# Test plot methods for QTE (returns plot objects)
qte_plots <- plot(qte_result)
expect_type(qte_plots, "list")
# Test ATE with HPD interval
ate_result <- ate(fit, interval = "hpd", nsim_mean = 20)
expect_s3_class(ate_result, "causalmixgpd_ate")
# Test plot methods for ATE
ate_plots <- plot(ate_result)
expect_type(ate_plots, "list")
})
test_that("causal with GPD tails works (v17 coverage)", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("causal_alt_real500_p4_k2", package = "CausalMixGPD")
y <- abs(causal_alt_real500_p4_k2$y[1:60]) + 0.01
T_vec <- causal_alt_real500_p4_k2$A[1:60]
bundle <- build_causal_bundle(
y = y,
A = T_vec,
X = NULL,
kernel = "gamma",
backend = "sb",
PS = FALSE,
GPD = TRUE,
components = 3,
mcmc_outcome = mcmc_short
)
expect_s3_class(bundle, "causalmixgpd_causal_bundle")
fit <- quiet_run(run_mcmc_causal(bundle, show_progress = FALSE))
expect_s3_class(fit, "causalmixgpd_causal_fit")
# Test predict with mean type (uses simulation fallback for gamma+GPD)
pred_loc <- predict(fit, type = "mean", nsim_mean = 20L)
expect_s3_class(pred_loc, "causalmixgpd_causal_predict")
})
test_that("causal fit plot method works", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("causal_alt_real500_p4_k2", package = "CausalMixGPD")
y <- abs(causal_alt_real500_p4_k2$y[1:60]) + 0.01
T_vec <- causal_alt_real500_p4_k2$A[1:60]
bundle <- build_causal_bundle(
y = y,
A = T_vec,
X = NULL,
kernel = "gamma",
backend = "crp",
PS = FALSE,
GPD = FALSE,
components = 3,
monitor_latent = TRUE,
mcmc_outcome = mcmc_short
)
fit <- quiet_run(run_mcmc_causal(bundle, show_progress = FALSE))
# Test plot method for causal fit
fit_plots <- plot(fit, arm = "both")
expect_type(fit_plots, "list")
# Test plot for treatment arm only
fit_plots_trt <- plot(fit, arm = "trt")
expect_type(fit_plots_trt, "list")
# Test plot for control arm only
fit_plots_con <- plot(fit, arm = "con")
expect_type(fit_plots_con, "list")
})
test_that("causal predict plot method works", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("causal_alt_real500_p4_k2", package = "CausalMixGPD")
y <- abs(causal_alt_real500_p4_k2$y[1:60]) + 0.01
T_vec <- causal_alt_real500_p4_k2$A[1:60]
bundle <- build_causal_bundle(
y = y,
A = T_vec,
X = NULL,
kernel = "gamma",
backend = "crp",
PS = FALSE,
GPD = FALSE,
components = 3,
monitor_latent = TRUE,
mcmc_outcome = mcmc_short
)
fit <- quiet_run(run_mcmc_causal(bundle, show_progress = FALSE))
# Test predict plot
pred <- predict(fit, type = "quantile", p = 0.5)
pred_plots <- plot(pred)
expect_type(pred_plots, "list")
})
# =============================================================================
# Kernel Coverage (all 7 kernels)
# =============================================================================
test_that("all kernel types work with SB backend", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("nc_pos200_k3", package = "CausalMixGPD")
y_pos <- nc_pos200_k3$y[1:30]
y_real <- y_pos - mean(y_pos) # Center for real-support kernels
# Positive support kernels
for (kernel in c("gamma", "lognormal", "invgauss")) {
bundle <- build_nimble_bundle(
y = y_pos,
backend = "sb",
kernel = kernel,
GPD = FALSE,
components = 2,
mcmc = list(niter = 30, nburnin = 5, thin = 1, nchains = 1, seed = 1)
)
expect_s3_class(bundle, "causalmixgpd_bundle")
fit <- quiet_run(run_mcmc_bundle_manual(bundle, show_progress = FALSE))
expect_s3_class(fit, "mixgpd_fit")
}
# Real support kernels
for (kernel in c("normal", "laplace", "cauchy")) {
bundle <- build_nimble_bundle(
y = y_real,
backend = "sb",
kernel = kernel,
GPD = FALSE,
components = 2,
mcmc = list(niter = 30, nburnin = 5, thin = 1, nchains = 1, seed = 1)
)
expect_s3_class(bundle, "causalmixgpd_bundle")
fit <- quiet_run(run_mcmc_bundle_manual(bundle, show_progress = FALSE))
expect_s3_class(fit, "mixgpd_fit")
}
})
test_that("amoroso kernel works", {
skip_if_not_test_level("ci")
skip_if_not_installed("nimble")
data("nc_pos200_k3", package = "CausalMixGPD")
y <- nc_pos200_k3$y[1:30]
bundle <- build_nimble_bundle(
y = y,
backend = "sb",
kernel = "amoroso",
GPD = FALSE,
components = 2,
mcmc = list(niter = 30, nburnin = 5, thin = 1, nchains = 1, seed = 1)
)
expect_s3_class(bundle, "causalmixgpd_bundle")
fit <- quiet_run(run_mcmc_bundle_manual(bundle, show_progress = FALSE))
expect_s3_class(fit, "mixgpd_fit")
})
# ===== END ci/test-vignette-coverage.R =====