Select recipe, model and calibration settings using local searches,
then assess the complete procedure on independent data. Install the
optional workflow packages plus tune, dials
and yardstick; postprocessing examples also use the
dependencies named in their scripts.
Start with vignette("tuning", package = "vennabers") for
the step-by-step guide. ?vennabers_examples indexes all
four example collections.
Running an example
Each heading below names an installed script. To inspect and run one:
script <- system.file("examples", "binary-grid.R", package = "vennabers")
file.show(script)
source(script)Replace the filename to run another script. The listings below show the complete code without executing it during documentation builds. Sourcing a script runs its fits and checks; resampling, tuning and composition matrices can take longer than the introductory guides.
Binary Grid selection
binary-grid.R: Compare joint and two-stage selection
while preserving independent assessment data.
# Binary grid selection. Every callback sees only its current local data.
library(vennabers)
set.seed(19)
data <- data.frame(x = stats::rnorm(600))
data$truth <- factor(ifelse(stats::runif(600) < stats::plogis(data$x), "yes", "no"),
levels = c("yes", "no"))
development <- data[1:400, ]
validation <- data[401:500, ]
assessment <- data[501:600, ]
recipe <- recipes::recipe(truth ~ x, development) |>
recipes::step_poly(x, degree = tune::tune("degree"))
base <- workflows::workflow() |>
workflows::add_recipe(recipe) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
for (strategy in c("joint", "two_stage")) {
config <- list(strategy = strategy, selection_prop = .3,
model = list(method = "grid", grid = data.frame(degree = c(1L, 2L)),
resamples = function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)),
calibration = list(method = "grid",
grid = data.frame(va_loss = c("log", "brier"), va_rounding = c("none", "-2")),
resamples = function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0),
primary_metric = yardstick::brier_class))
outer <- calibrated_workflow(base, "truth", seed = 31,
loss = tune::tune("va_loss"), precision = tune::tune("va_rounding"), tuning = config)
fitted <- generics::fit(outer, development)
choices <- venn_abers_tuning(fitted)
stopifnot(!length(intersect(choices$calibration$selection_rows,
choices$calibration$final_rows)))
print(c(strategy = strategy, calibration = choices$calibration$chosen,
model = choices$models$Inductive1$chosen))
print(head(predict(fitted, assessment, type = "prob")))
}
# Narrow loss-only choice after an already fixed fit: no refitting.
fixed <- workflows::workflow() |>
workflows::add_formula(truth ~ x) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
fitted_fixed <- generics::fit(calibrated_workflow(fixed, "truth", seed = 31), development)
losses <- vapply(c("log", "brier"), function(loss) {
probability <- predict(fitted_fixed, validation, type = "prob", loss = loss)$.pred_yes
yardstick::mn_log_loss_vec(validation$truth, probability, event_level = "first")
}, numeric(1))
chosen_loss <- c("log", "brier")[which.min(losses)]
print(head(predict(fitted_fixed, assessment, type = "prob", loss = chosen_loss)))Shared multiclass Grid selection
shared-multiclass-grid.R: Select complete shared OvO/OvR
procedures using joint or two-stage Grid searches.
# Run after installation: Rscript inst/examples/shared-multiclass-grid.R
library(vennabers)
data <- iris
names(data)[5L] <- "truth"
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ ., data) |>
recipes::step_poly(Sepal.Length, degree = tune::tune("degree"))) |>
workflows::add_model(parsnip::multinom_reg(engine = "nnet"))
for (classification in c("ovo", "ovr")) for (strategy in c("joint", "two_stage")) {
tuning <- list(strategy = strategy, selection_prop = .4,
model = list(method = "grid", grid = data.frame(degree = c(1L, 2L)),
resamples = function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)),
calibration = list(method = "grid", grid = data.frame(va_loss = c("log", "brier")),
resamples = function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)))
fitted <- calibrated_workflow(base, "truth", classification = classification,
method = "cross", v = 2L, prediction_model = "full",
loss = tune::tune("va_loss"), tuning = tuning, seed = 19) |>
generics::fit(data)
selection <- venn_abers_tuning(fitted)
probability <- predict(fitted, data[1:3, ], type = "prob")
stopifnot(identical(names(probability), paste0(".pred_", levels(data$truth))),
max(abs(rowSums(probability) - 1)) < 1e-8,
"Full1" %in% names(selection$models))
print(c(classification = classification, strategy = strategy,
calibration = selection$calibration$chosen,
full_model = selection$models$Full1$chosen))
print(probability)
}Shared multiclass Bayes selection
shared-multiclass-bayes.R: Select complete OvO/OvR class
matrices with local stepwise Bayes searches.
# Run after installation: Rscript inst/examples/shared-multiclass-bayes.R
library(vennabers)
data <- iris
names(data)[5L] <- "truth"
base <- workflows::workflow() |>
workflows::add_formula(truth ~ Sepal.Length + Petal.Length) |>
workflows::add_model(parsnip::decision_tree(tree_depth = tune::tune("depth"),
mode = "classification", engine = "rpart"))
folds <- function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)
model_params <- dials::parameters(dials::new_quant_param(type = "integer",
range = c(1L, 8L), inclusive = c(TRUE, TRUE), label = c(depth = "Depth")))
calibration_params <- dials::parameters(dials::new_qual_param(type = "character",
values = c("log", "brier"), label = c(va_loss = "Loss")))
for (classification in c("ovo", "ovr")) for (strategy in c("joint", "two_stage")) {
tuning <- list(strategy = strategy, selection_prop = .4,
model = list(method = "bayes", initial = 4L, iter = 1L,
param_info = model_params, resamples = folds,
control = tune::control_bayes(seed = 4, save_pred = TRUE)),
calibration = list(method = "bayes", initial = 2L, iter = 1L,
param_info = calibration_params, resamples = folds,
control = tune::control_bayes(seed = 5, save_pred = TRUE)))
fitted <- calibrated_workflow(base, "truth", classification = classification,
method = "cross", v = 2L, prediction_model = "full",
loss = tune::tune("va_loss"), tuning = tuning, seed = 19) |>
generics::fit(data)
selection <- venn_abers_tuning(fitted)
probability <- predict(fitted, data[1:3, ], type = "prob")
stopifnot(identical(names(probability), paste0(".pred_", levels(data$truth))),
max(abs(rowSums(probability) - 1)) < 1e-8,
"Full1" %in% names(selection$models))
print(c(classification = classification, strategy = strategy,
calibration = selection$calibration$chosen,
full_model = selection$models$Full1$chosen))
print(probability)
}Pairwise OvO Grid selection
pairwise-grid.R: Search local class-pair grids and
select using coupled class predictions.
# Run after installation: Rscript inst/examples/pairwise-grid.R
library(vennabers)
# Three overlapping classes: unlike iris, no class pair is separable in its
# small local splits, so the base GLMs converge.
data <- withr::with_seed(5, {
truth <- factor(rep(c("setosa", "versicolor", "virginica"), 50))
data.frame(Sepal.Length = stats::rnorm(150, c(5.4, 5.9, 6.4)[truth], .7), truth = truth)
})
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ Sepal.Length, data) |>
recipes::step_poly(Sepal.Length, degree = tune::tune("degree"))) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
for (strategy in c("joint", "two_stage")) {
tuning <- list(strategy = strategy, selection_prop = .6,
model = list(method = "grid", grid = data.frame(degree = c(1L, 2L))),
calibration = list(method = "grid",
grid = data.frame(va_loss = c("log", "brier"),
rounding = c("none", "-2")),
resamples = function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)))
if (strategy == "two_stage") tuning$model$resamples <- function(d)
rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)
outer <- if (strategy == "joint")
calibrated_workflow(base, "truth", classification = "ovo", model_training = "pairwise",
loss = tune::tune("va_loss"), precision = tune::tune("rounding"),
tuning = tuning, seed = 19) else
calibrated_workflow(base, "truth", classification = "ovo", model_training = "pairwise",
method = "cross", v = 2L, prediction_model = "full",
loss = tune::tune("va_loss"), precision = tune::tune("rounding"),
tuning = tuning, seed = 19)
fitted <- generics::fit(outer, data)
selection <- venn_abers_tuning(fitted)
probability <- predict(fitted, data[1:3, ], type = "prob")
stopifnot(identical(names(probability), paste0(".pred_", levels(data$truth))),
max(abs(rowSums(probability) - 1)) < 1e-8,
identical(names(selection$models), paste0("pair_", 1:3)),
if (strategy == "two_stage")
all(vapply(selection$models, function(pair) "Full1" %in% names(pair), TRUE)) else
nrow(selection$joint$candidates) == 16L)
print(c(strategy = strategy, calibration = selection$calibration$chosen))
print(if (strategy == "joint") selection$joint$selected$pairs else
lapply(selection$models, function(pair) vapply(pair, `[[`, "", "chosen")))
print(probability)
}Pairwise OvO Bayes selection
pairwise-bayes.R: Run local pair searches and assess the
complete coupled predictor.
# Run after installation: Rscript inst/examples/pairwise-bayes.R
library(vennabers)
# Three overlapping classes: unlike iris, no class pair is separable in its
# small local splits, so the base GLMs converge.
data <- withr::with_seed(5, {
truth <- factor(rep(c("setosa", "versicolor", "virginica"), 50))
data.frame(Sepal.Length = stats::rnorm(150, c(5.4, 5.9, 6.4)[truth], .7), truth = truth)
})
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ Sepal.Length, data) |>
recipes::step_poly(Sepal.Length, degree = tune::tune("degree"))) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
folds <- function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)
tuning <- list(strategy = "joint", selection_prop = .6,
model = list(method = "bayes", initial = 2L, iter = 1L,
param_info = dials::parameters(dials::new_quant_param(type = "integer",
range = c(1L, 2L), inclusive = c(TRUE, TRUE), label = c(degree = "Degree"))),
resamples = folds, control = tune::control_bayes(seed = 9, save_pred = TRUE)),
calibration = list(method = "bayes", initial = 2L, iter = 1L,
param_info = dials::parameters(dials::new_qual_param(type = "character",
values = c("log", "brier"), label = c(va_loss = "Loss"))),
resamples = folds, control = tune::control_bayes(seed = 10, save_pred = TRUE)))
fitted <- calibrated_workflow(base, "truth", classification = "ovo",
model_training = "pairwise", prediction_model = "full",
loss = tune::tune("va_loss"), tuning = tuning, seed = 11) |>
generics::fit(data)
selection <- venn_abers_tuning(fitted)
stopifnot(identical(names(selection$models), paste0("pair_", 1:3)),
selection$calibration$chosen %in% selection$calibration$candidates$id)
print(vapply(selection$models, function(pair) pair$Full1$chosen, ""))
print(predict(fitted, data[1:3, ], type = "prob"))Regression Grid selection
regression-grid.R: Select IVAR/CVAR model and moderation
settings with joint or two-stage searches.
# IVAR/CVAR grid selection: local learning, independent assessment.
library(vennabers)
set.seed(19)
data <- data.frame(x = stats::rnorm(360))
data$truth <- data$x^2 + stats::rnorm(360, sd = .3)
development <- data[1:300, ]
assessment <- data[301:360, ]
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ x, development) |>
recipes::step_poly(x, degree = tune::tune("degree"))) |>
workflows::add_model(parsnip::linear_reg(engine = "lm"))
for (strategy in c("joint", "two_stage")) for (method in c("inductive", "cross")) {
config <- list(strategy = strategy, selection_prop = .5,
model = list(method = "grid", grid = data.frame(degree = c(1L, 2L)),
resamples = function(d) rsample::vfold_cv(d, v = 2)),
calibration = list(method = "grid", grid = data.frame(moderation = c(.4, .6)),
resamples = function(d) rsample::vfold_cv(d, v = 2),
report_metrics = list(yardstick::mae)))
args <- list(workflow = base, outcome = "truth", method = method,
prediction_model = "full", epsilon = tune::tune("moderation"),
tuning = config, seed = 31)
if (method == "cross") args$v <- 2L
fitted <- generics::fit(do.call(calibrated_workflow, args, quote = TRUE), development)
choices <- venn_abers_tuning(fitted)
stopifnot(!length(intersect(choices$calibration$selection_rows,
choices$calibration$final_rows)), "Full1" %in% names(choices$models))
print(c(strategy = strategy, method = method,
epsilon = choices$calibration$selected$moderation,
full_degree = choices$models$Full1$selected$degree))
prediction <- predict(fitted, assessment)$.pred
stopifnot(all(is.finite(prediction)))
print(c(rmse = sqrt(mean((assessment$truth - prediction)^2)),
mae = mean(abs(assessment$truth - prediction))))
print(choices$fit_roles)
}
# To search m instead, use m = tune::tune("moderation") and a positive integer
# grid, for example c(1L, 2L), omitting epsilon. Every inner calibration size k
# must support 1 <= m <= floor((k-1)/2); invalid candidates are recorded/excluded.
# S selects moderation, F fits the final predictor; assessment stays untouched.
# Joint scores complete calibrated predictions, two_stage scores raw fits first.
# RMSE is the default selection metric; MAE above is an independent report only.
# Full1 chooses its own model parameters; it does not inherit a fold's choice.
# CVAR averages fold points and each bound separately, with equal weights.
# These bounds describe regularized conditional means, not prediction intervals.Regression Bayes selection
regression-bayes.R: Search IVAR/CVAR settings locally
while keeping assessment observations untouched.
# IVAR/CVAR Bayes selection on development data; assessment remains untouched.
library(vennabers)
set.seed(19)
data <- data.frame(x = stats::rnorm(240))
data$truth <- data$x^2 + stats::rnorm(240, sd = .3)
development <- data[1:200, ]
assessment <- data[201:240, ]
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ x, development) |>
recipes::step_poly(x, degree = tune::tune("degree"))) |>
workflows::add_model(parsnip::linear_reg(engine = "lm"))
model_params <- dials::parameters(dials::new_quant_param(
type = "integer", range = c(1L, 3L), inclusive = c(TRUE, TRUE),
label = c(degree = "Degree")))
moderation_params <- dials::parameters(dials::new_quant_param(
type = "double", range = c(.3, .4), inclusive = c(TRUE, TRUE),
label = c(moderation = "Moderation")))
for (strategy in c("joint", "two_stage")) for (method in c("inductive", "cross")) {
search <- function(params, seed) list(method = "bayes", initial = 3L, iter = 1L,
param_info = params, resamples = function(d) rsample::vfold_cv(d, v = 2),
control = tune::control_bayes(seed = seed, save_pred = TRUE, no_improve = 2L))
config <- list(strategy = strategy, selection_prop = .5,
model = search(model_params, 3), calibration = search(moderation_params, 4))
args <- list(workflow = base, outcome = "truth", method = method,
prediction_model = "full", epsilon = tune::tune("moderation"),
tuning = config, seed = 31)
if (method == "cross") args$v <- 2L else args$calibration_prop <- .5
fitted <- generics::fit(do.call(calibrated_workflow, args, quote = TRUE), development)
choices <- venn_abers_tuning(fitted)
stopifnot(!length(intersect(choices$calibration$selection_rows,
choices$calibration$final_rows)), "Full1" %in% names(choices$models))
prediction <- predict(fitted, assessment)$.pred
print(c(strategy = strategy, method = method,
epsilon = choices$calibration$selected$moderation,
full_degree = choices$models$Full1$selected$degree,
rmse = sqrt(mean((assessment$truth - prediction)^2))))
}
# To search m instead, use m = tune::tune("moderation") and an integer
# dials range such as 1:2, omitting epsilon. Every inner calibration size
# must support the proposed moderation value. Joint scores complete calibrated
# predictions; two_stage selects the raw fit first. Full1 chooses locally.Grid selection with postprocessing
postprocessing-grid.R: Run separate B-local searches for
classification and regression compositions, excluding P, C and
assessment data.
# Grid selection with learned postprocessing. Every engine/recipe search runs
# inside its own B: each VA source, each inner ensemble pair and each full F
# composition searches separately. P, C, the outer assessment A and a reserved
# option-selection share S never enter a search. Joint candidates are complete
# fixed compositions (no nested search); the first two-stage step scores the raw
# engine/recipe without postprocessor or VA.
source(system.file("examples", "assertions.R", package = "vennabers"))
packages <- c("vennabers", "parsnip", "withr", "workflows", "recipes", "rsample", "tune", "yardstick", "tailor", "probably", "nnet")
cases <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
library(vennabers)
checker <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), checker)
stratified <- function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)
plain <- function(d) rsample::vfold_cv(d, v = 2)
grid <- function(n) list(method = "grid", grid = data.frame(degree = seq_len(n)))
classes <- withr::with_seed(7, {
truth <- factor(rep(c("a", "b", "c"), 800))
data.frame(x = stats::rnorm(2400, sd = 3) + c(-1, 1, -1)[truth],
z = stats::rnorm(2400, sd = 3) + c(-1, -1, 1)[truth], truth = truth)
})
binary <- withr::with_seed(8, {
x <- stats::rnorm(1200, sd = 1.5)
data.frame(x = x, z = stats::rnorm(1200),
truth = factor(ifelse(stats::runif(1200) < stats::plogis(x - .4 * x^2 + .5), "yes", "no")))
})
numeric <- withr::with_seed(9, {
x <- stats::rnorm(1200)
data.frame(x = x, z = stats::rnorm(1200), truth = 3 + x - .5 * x^2 + stats::rnorm(1200, sd = .5))
})
base <- function(d, engine) workflows::workflow() |> workflows::add_recipe(
recipes::recipe(truth ~ x + z, d) |> recipes::step_poly(x, degree = tune::tune("degree"))) |>
workflows::add_model(engine)
glm <- parsnip::logistic_reg(engine = "glm")
nnet <- parsnip::multinom_reg(penalty = .1) |> parsnip::set_engine("nnet", trace = FALSE, maxit = 1000)
specs <- list(
# The v0.9 benchmark case: binary full ensemble, two stages, four candidates per local search.
binary_sigmoid_ensemble = list(data = binary, spec = calibrated_workflow(base(binary, glm), "truth",
method = "cross", v = 2, prediction_model = "full", seed = 3,
tuning = list(strategy = "two_stage", model = c(grid(4), list(resamples = stratified))),
postprocessing = list(method = "sigmoid", sigmoid_input = "probability", strategy = "ensemble", v = 3))),
pairwise_tailor_joint = list(data = classes[c("x", "z", "truth")], spec = calibrated_workflow(base(classes, glm), "truth",
classification = "ovo", model_training = "pairwise", seed = 4,
tuning = list(strategy = "joint", model = c(grid(2), list(resamples = stratified)), joint_resamples = stratified),
postprocessing = list(method = "tailor_logistic", strategy = "holdout", prop = .3))),
ovr_multinomial_options = list(data = classes, spec = calibrated_workflow(base(classes, nnet), "truth",
classification = "ovr", seed = 5, loss = tune::tune("va_loss"),
tuning = list(strategy = "two_stage", selection_prop = .5,
model = c(grid(2), list(resamples = stratified)),
calibration = list(method = "grid", grid = data.frame(va_loss = c("log", "brier")), resamples = stratified)),
postprocessing = list(method = "tailor_multinomial", strategy = "holdout", prop = .3))),
regression_isotonic_joint = list(data = numeric, spec = calibrated_workflow(base(numeric, parsnip::linear_reg()), "truth",
method = "cross", v = 2, prediction_model = "full", seed = 6,
tuning = list(strategy = "joint", model = c(grid(2), list(resamples = plain))),
postprocessing = list(method = "isotonic_numeric", strategy = "holdout", prop = .3))),
regression_linear_ensemble = list(data = numeric, spec = calibrated_workflow(base(numeric, parsnip::linear_reg()), "truth",
seed = 7, tuning = list(strategy = "two_stage", model = c(grid(2), list(resamples = plain))),
postprocessing = list(method = "tailor_linear", strategy = "ensemble", v = 2))))
# Every local search with its inner B/P plan and, for pairwise, its pair rows.
searches <- function(state) {
parts <- if (is.null(state$pair_models)) list(state) else state$pair_models
unlist(lapply(parts, function(part) {
local <- if (is.null(part$pair_id)) state$tuning$models else state$tuning$models[[part$pair_id]]
unlist(lapply(names(part$postprocessing), function(path) {
post <- part$postprocessing[[path]]
inner <- if (is.null(post$inner_folds)) list(Holdout1 = post) else post$inner_folds
lapply(names(inner), function(j) list(pair = part$rows, plan = inner[[j]], search = local[[path]][[j]]))
}), recursive = FALSE)
}), recursive = FALSE)
}
for (name in names(specs)) {
d <- specs[[name]]$data
spec <- specs[[name]]$spec
regression <- is.numeric(d$truth)
metrics <- if (regression) yardstick::metric_set(yardstick::rmse) else yardstick::metric_set(yardstick::mn_log_loss)
# Repeated outer folds: exact (id, id2, .row, .config) coverage, no notes.
outer <- withr::with_seed(11, rsample::vfold_cv(d, v = 2, repeats = 2))
result <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine, allow_par = FALSE))
states <- checker$check_outer_identities(result, outer, metrics = 1L)$extracts
for (h in seq_along(states)) {
state <- states[[h]]
F_rows <- as.integer(outer$splits[[h]], "analysis"); A_rows <- as.integer(outer$splits[[h]], "assessment")
# Final rows after an optional option-selection share S.
final <- if (is.null(state$tuning$calibration)) F_rows else F_rows[state$tuning$calibration$final_rows]
S_rows <- if (is.null(state$tuning$calibration)) integer() else F_rows[state$tuning$calibration$selection_rows]
for (local in searches(state)) {
rows <- if (is.null(local$pair)) final else final[local$pair]
B <- rows[local$plan$B]
search <- local$search
collected <- tune::collect_predictions(search$native)
assert_conditions(identical(search$B, local$plan$B), identical(local$plan$selected, search$selected),
!any(B %in% c(A_rows, S_rows, rows[local$plan$P])),
identical(sort(unique(collected$.row)), seq_along(B)),
search$chosen %in% search$candidates$id[search$candidates$status == "eligible"])
}
}
n <- nrow(d); A <- seq.int(.8 * n + 1, n)
split <- rsample::make_splits(list(analysis = seq_len(.8 * n), assessment = A), d)
last <- tune::last_fit(spec, split, metrics = metrics)
fit <- tune::extract_workflow(last)
new <- d[A, setdiff(names(d), "truth")]
changed <- d
changed$truth[A] <- if (regression) changed$truth[A] + 100 else rev(changed$truth[A])
other <- tune::last_fit(spec, rsample::make_splits(list(analysis = seq_len(.8 * n), assessment = A), changed), metrics = metrics)
stopifnot(identical(venn_abers_details(fit, new), venn_abers_details(tune::extract_workflow(other), new)))
tuning <- venn_abers_tuning(fit)
cat(name, ": searches", length(searches(workflows::extract_fit_engine(fit))),
"; observed base fits", tuning$cost$observed_base_fits, "\n")
cases[[name]] <- list(fit = fit, new = new)
}
stopifnot(length(cases) == 5L)
}Bayes selection with postprocessing
postprocessing-bayes.R: Inspect local search budgets,
complete candidate histories and recorded failures across learned
compositions.
# Stepwise Bayes selection with learned postprocessing. As with Grid, every
# engine/recipe search runs inside its own B (each VA source, inner ensemble
# pair and full F composition, per class pair for pairwise OvO); P, C, the outer
# assessment A and a reserved option-selection share S never enter it. Only
# complete valid candidates feed the next GP. Failed candidates stay in the
# history with their reasons and spend budget; too few valid initial points stop
# the fit with a clear error, never a switch to Grid.
source(system.file("examples", "assertions.R", package = "vennabers"))
packages <- c("vennabers", "parsnip", "rlang", "withr", "workflows", "recipes", "rsample", "tune", "dials",
"yardstick", "tailor", "probably", "nnet")
cases <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
library(vennabers)
checker <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), checker)
stratified <- function(d) rsample::vfold_cv(d, v = 2, strata = truth, pool = 0)
plain <- function(d) rsample::vfold_cv(d, v = 2)
bayes <- function(upper, resamples, initial = 3L, iter = 3L) list(method = "bayes", initial = initial, iter = iter,
param_info = dials::parameters(dials::new_quant_param(type = "integer", range = c(1L, upper),
inclusive = c(TRUE, TRUE), label = c(degree = "Degree"))),
resamples = resamples, control = tune::control_bayes(seed = 4, save_pred = TRUE, no_improve = 3L))
classes <- withr::with_seed(7, {
truth <- factor(rep(c("a", "b", "c"), 800))
data.frame(x = stats::rnorm(2400, sd = 3) + c(-1, 1, -1)[truth],
z = stats::rnorm(2400, sd = 3) + c(-1, -1, 1)[truth], truth = truth)
})
# z has four distinct values: step_poly(z) fails for degree >= 4 in every B.
binary <- withr::with_seed(8, {
x <- stats::rnorm(1200, sd = 1.5)
z <- sample(1:4, 1200, TRUE)
data.frame(x = x, z = z, truth = factor(ifelse(stats::runif(1200) < stats::plogis(x - .3 * z + .5), "yes", "no")))
})
numeric <- withr::with_seed(9, {
x <- stats::rnorm(1200)
data.frame(x = x, z = stats::rnorm(1200), truth = 3 + x - .5 * x^2 + stats::rnorm(1200, sd = .5))
})
base <- function(d, engine, term = "x") workflows::workflow() |> workflows::add_recipe(
recipes::recipe(truth ~ x + z, d) |> recipes::step_poly(!!rlang::sym(term), degree = tune::tune("degree"))) |>
workflows::add_model(engine)
glm <- parsnip::logistic_reg(engine = "glm")
nnet <- parsnip::multinom_reg(penalty = .1) |> parsnip::set_engine("nnet", trace = FALSE, maxit = 1000)
sigmoid <- list(method = "sigmoid", sigmoid_input = "probability", strategy = "holdout", prop = .3)
specs <- list(
# Budget and failure case: degrees 4 to 6 fail in every B, initial or proposed.
binary_sigmoid_joint = list(data = binary, spec = calibrated_workflow(base(binary, glm, "z"), "truth",
prediction_model = "full", seed = 3, tuning = list(strategy = "joint", model = bayes(6L, stratified)),
postprocessing = sigmoid)),
pairwise_tailor_two_stage = list(data = classes[c("x", "z", "truth")], spec = calibrated_workflow(base(classes, glm), "truth",
classification = "ovo", model_training = "pairwise", seed = 4,
tuning = list(strategy = "two_stage", model = bayes(2L, stratified, initial = 2L)),
postprocessing = list(method = "tailor_logistic", strategy = "ensemble", v = 2))),
ovr_multinomial_options = list(data = classes, spec = calibrated_workflow(base(classes, nnet), "truth",
classification = "ovr", seed = 5, loss = tune::tune("va_loss"),
tuning = list(strategy = "two_stage", selection_prop = .5,
model = bayes(2L, stratified, initial = 2L),
calibration = list(method = "bayes", initial = 2L, iter = 1L, resamples = stratified,
param_info = dials::parameters(dials::new_qual_param(type = "character", values = c("log", "brier"),
label = c(va_loss = "Loss"))), control = tune::control_bayes(seed = 5, save_pred = TRUE))),
postprocessing = list(method = "tailor_multinomial", strategy = "holdout", prop = .3))),
regression_linear_joint = list(data = numeric, spec = calibrated_workflow(base(numeric, parsnip::linear_reg()), "truth",
method = "cross", v = 2, seed = 6, tuning = list(strategy = "joint", model = bayes(3L, plain)),
postprocessing = list(method = "tailor_linear", strategy = "holdout", prop = .3))))
# Every local search with its inner B/P plan and, for pairwise, its pair rows.
searches <- function(state) {
parts <- if (is.null(state$pair_models)) list(state) else state$pair_models
unlist(lapply(parts, function(part) {
local <- if (is.null(part$pair_id)) state$tuning$models else state$tuning$models[[part$pair_id]]
unlist(lapply(names(part$postprocessing), function(path) {
post <- part$postprocessing[[path]]
inner <- if (is.null(post$inner_folds)) list(Holdout1 = post) else post$inner_folds
lapply(names(inner), function(j) list(pair = part$rows, plan = inner[[j]], search = local[[path]][[j]]))
}), recursive = FALSE)
}), recursive = FALSE)
}
for (name in names(specs)) {
d <- specs[[name]]$data
spec <- specs[[name]]$spec
regression <- is.numeric(d$truth)
metrics <- if (regression) yardstick::metric_set(yardstick::rmse) else yardstick::metric_set(yardstick::mn_log_loss)
# Repeated outer folds: exact (id, id2, .row, .config) coverage, no notes.
outer <- withr::with_seed(11, rsample::vfold_cv(d, v = 2, repeats = 2))
result <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine, allow_par = FALSE))
states <- checker$check_outer_identities(result, outer, metrics = 1L)$extracts
for (h in seq_along(states)) {
state <- states[[h]]
F_rows <- as.integer(outer$splits[[h]], "analysis"); A_rows <- as.integer(outer$splits[[h]], "assessment")
# Final rows after an optional option-selection share S.
final <- if (is.null(state$tuning$calibration)) F_rows else F_rows[state$tuning$calibration$final_rows]
S_rows <- if (is.null(state$tuning$calibration)) integer() else F_rows[state$tuning$calibration$selection_rows]
for (local in searches(state)) {
rows <- if (is.null(local$pair)) final else final[local$pair]
B <- rows[local$plan$B]
search <- local$search
eligible <- search$candidates$status == "eligible"
# The GP only saw complete valid candidates, all on rows of this B.
assert_conditions(identical(search$B, local$plan$B), identical(local$plan$selected, search$selected),
!any(B %in% c(A_rows, S_rows, rows[local$plan$P])),
identical(sort(unique(tune::collect_predictions(search$native)$.row)), seq_along(B)),
search$chosen %in% search$candidates$id[eligible], !anyDuplicated(search$candidates$id),
setequal(unique(tune::collect_metrics(search$native)$degree), search$candidates$degree[eligible]),
search$cost$candidate_evaluations == search$attempts * length(search$resamples))
if (name == "binary_sigmoid_joint") {
# Failed initial and continuation candidates keep their IDs and reasons.
assert_conditions(any(!eligible), identical(!eligible, search$candidates$degree >= 4L),
grepl("must be less than number of unique points", paste(search$notes$note, collapse = " ")))
}
}
}
n <- nrow(d); A <- seq.int(.8 * n + 1, n)
split <- rsample::make_splits(list(analysis = seq_len(.8 * n), assessment = A), d)
last <- tune::last_fit(spec, split, metrics = metrics)
fit <- tune::extract_workflow(last)
new <- d[A, setdiff(names(d), "truth")]
changed <- d
changed$truth[A] <- if (regression) changed$truth[A] + 100 else rev(changed$truth[A])
other <- tune::last_fit(spec, rsample::make_splits(list(analysis = seq_len(.8 * n), assessment = A), changed), metrics = metrics)
stopifnot(identical(venn_abers_details(fit, new), venn_abers_details(tune::extract_workflow(other), new)))
local <- searches(workflows::extract_fit_engine(fit))
cat(name, ": searches", length(local),
"; attempts", paste(vapply(local, function(x) x$search$attempts, 1L), collapse = "/"),
"; stop", paste(unique(vapply(local, function(x) x$search$stop_reason, "")), collapse = "/"),
"; excluded", sum(vapply(local, function(x) x$search$cost$excluded_candidates, 1L)),
"; observed base fits", venn_abers_tuning(fit)$cost$observed_base_fits, "\n")
cases[[name]] <- list(fit = fit, new = new)
}
# Two initial points (2 and 5) leave one valid candidate: a clear error, no Grid fallback.
short <- calibrated_workflow(base(binary, glm, "z"), "truth", seed = 3,
tuning = list(strategy = "joint", model = bayes(6L, stratified, initial = 2L)), postprocessing = sigmoid)
failure <- tryCatch({
generics::fit(short, binary)
""
}, error = conditionMessage)
assert_conditions(grepl("Bayes needs at least 2 complete initial model candidates; found 1", failure),
grepl("must be less than number of unique points", failure))
stopifnot(length(cases) == 4L)
}