The hardware and bandwidth for this mirror is donated by dogado GmbH, the Webhosting and Full Service-Cloud Provider. Check out our Wordpress Tutorial.
If you wish to report a bug, or if you are interested in having us mirror your free-software or open-source project, please feel free to contact us at mirror[@]dogado.de.
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.
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.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)))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-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.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.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.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)
}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)
}These binaries (installable software) and packages are in development.
They may not be fully stable and should be used with caution. We make no claims about them.
Health stats visible at Monitor.