Example scripts: learned postprocessing
Source:vignettes/examples-postprocessing.Rmd
examples-postprocessing.RmdLearn a postprocessor between model training and VA calibration,
using separate B/P/C data roles. The examples cover holdouts, inner
ensembles, pairwise OvO and full prediction compositions. Install the
optional workflow and assessment packages used in each script; Tailor
examples additionally use tailor and
probably.
Start with vignette("workflows", package = "vennabers")
for the step-by-step guide. ?vennabers_examples indexes all
four example collections.
Choose an example
- Binary Sigmoid holdouts
- Binary Tailor holdouts
- Shared multiclass Tailor holdouts
- Regression Tailor holdouts
- Regression isotonic holdouts
- Binary postprocessing ensembles
- Shared multiclass postprocessing ensembles
- Regression postprocessing ensembles
- Pairwise OvO postprocessing
- Full-model postprocessing compositions
Running an example
Each heading below names an installed script. To inspect and run one:
script <- system.file("examples", "sigmoid-holdout.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 Sigmoid holdouts
sigmoid-holdout.R: Compare probability and GLM-link
inputs with Inductive/Cross calibration, native resampling and final
assessment.
# Run with an installed vennabers and its optional tidymodels dependencies.
# B learns the recipe/engine, P learns Sigmoid, and C learns VA. Every outer
# assessment A stays outside all three learning roles.
if (all(vapply(c("vennabers", "tune", "yardstick", "recipes"),
requireNamespace, logical(1), quietly = TRUE))) local({
d <- data.frame(x = sin(1:240), row_id = 1:240,
truth = factor(rep(c("yes", "no", "no", "yes"), 60)))
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ x, d) |> recipes::step_normalize(x)) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
# prop is P's fraction of each Q, not B's fraction. Both B and P need both
# classes and at least two P rows. Constant inputs are allowed.
# Invalid splits, nonfinite inputs or failed convergence
# fail the fit; there are no retries, size corrections or fallback methods.
outer <- withr::with_seed(74, rsample::vfold_cv(d, v = 2, repeats = 2, strata = truth, pool = 0))
metrics <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
audit <- function(result, plans, event) {
predictions <- tune::collect_predictions(result, summarize = FALSE)
scores <- tune::collect_metrics(result, summarize = FALSE)
stopifnot(nrow(tune::collect_notes(result)) == 0L, all(is.finite(scores$.estimate)),
nrow(scores) == 2L * nrow(plans))
ids <- setdiff(names(plans), "splits")
if (inherits(result, "last_fit")) for (id in ids) scores[[id]] <- plans[[id]][1L]
expected <- do.call(rbind, lapply(seq_len(nrow(plans)), function(i) {
rows <- as.integer(plans$splits[[i]], "assessment")
cbind(as.data.frame(plans[rep(i, length(rows)), ids, drop = FALSE]),
.row = rows, .config = "pre0_mod0_post0")
}))
keys <- c(ids, ".row", ".config")
stopifnot(!anyDuplicated(predictions[keys]), nrow(predictions) == nrow(expected),
nrow(merge(predictions[keys], expected, by = keys)) == nrow(expected),
!anyDuplicated(scores[c(ids, ".metric", ".config")]))
for (i in seq_len(nrow(plans))) {
matches <- function(x) Reduce(`&`, lapply(ids, function(id) x[[id]] == plans[[id]][i]))
p <- predictions[matches(predictions), ]
m <- scores[matches(scores), ]
column <- paste0(".pred_", levels(d$truth)[if (event == "first") 1L else 2L])
values <- c(brier_class = yardstick::brier_class_vec(p$truth, p[[column]], event_level = event),
mn_log_loss = yardstick::mn_log_loss_vec(p$truth, p[[column]], event_level = event))
stopifnot(all(abs(m$.estimate - values[m$.metric]) <= 1e-10))
}
}
for (input in c("probability", "glm_link")) for (method in c("inductive", "cross")) for (event in c("first", "second")) {
post <- list(method = "sigmoid", strategy = "holdout", prop = .3, sigmoid_input = input)
spec <- vennabers::calibrated_workflow(base, "truth", method = method, event_level = event,
seed = 42, postprocessing = post)
fitted <- generics::fit(spec, d)
details <- vennabers::venn_abers_details(fitted, d[c("x", "row_id")])
stopifnot(identical(details$prediction, predict(fitted, d, type = "prob")),
all(details$details$postprocessing_method == "sigmoid"))
result <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine,
event_level = event, allow_par = FALSE))
audit(result, outer, event)
states <- tune::collect_extracts(result)$.extracts
for (i in seq_along(states)) {
local <- rsample::analysis(outer$splits[[i]])
A <- rsample::assessment(outer$splits[[i]])$row_id
for (plan in states[[i]]$postprocessing) {
stopifnot(!any(local$row_id[c(plan$B, plan$P, plan$C)] %in% A),
!length(intersect(plan$B, plan$P)), !length(intersect(plan$Q, plan$C)))
}
}
split <- rsample::make_splits(list(analysis = 1:180, assessment = 181:240), d)
last <- tune::last_fit(spec, split, metrics = metrics,
control = tune::control_last_fit(event_level = event))
audit(last, rsample::manual_rset(list(split), "train/test split"), event)
# Changing A changes evaluation, never the fitted state or predictions.
changed <- d; changed$x[181:240] <- 1000; changed$truth[181:240] <- "yes"
changed_split <- rsample::make_splits(list(analysis = 1:180, assessment = 181:240), changed)
other <- tune::last_fit(spec, changed_split, metrics = metrics,
control = tune::control_last_fit(event_level = event))
original <- workflows::extract_fit_engine(last$.workflow[[1]])
after <- workflows::extract_fit_engine(other$.workflow[[1]])
stopifnot(identical(original$postprocessing, after$postprocessing),
identical(predict(last$.workflow[[1]], d, type = "prob"), predict(other$.workflow[[1]], d, type = "prob")))
}
})Binary Tailor holdouts
tailor-holdout.R: Learn logistic postprocessing on
separate data and inspect diagnostics, resampling and last_fit
results.
# Run with an installed vennabers and its optional tidymodels, tailor and
# probably dependencies. B learns the recipe/engine, P learns Tailor, and C
# learns VA. Every outer assessment A stays outside all three learning roles.
if (all(vapply(c("vennabers", "tailor", "probably", "tune", "yardstick", "recipes"),
requireNamespace, logical(1), quietly = TRUE))) local({
d <- data.frame(x = sin(1:240), row_id = 1:240,
truth = factor(rep(c("yes", "no", "no", "yes"), 60)))
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ x, d) |> recipes::step_normalize(x)) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
# prop is P's fraction of each Q, not B's fraction. Both B and P need both
# classes. Logistic P needs at least 3 rows and a full-rank two-column design.
# Invalid splits, rank deficiency, failed convergence or a switch to none
# fail the fit; there are no retries, size corrections or fallback methods.
post <- list(method = "tailor_logistic", strategy = "holdout", prop = .3)
outer <- withr::with_seed(74, rsample::vfold_cv(d, v = 2, repeats = 2, strata = truth, pool = 0))
metrics <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
audit <- function(result, plans, event) {
predictions <- tune::collect_predictions(result, summarize = FALSE)
scores <- tune::collect_metrics(result, summarize = FALSE)
stopifnot(nrow(tune::collect_notes(result)) == 0L, all(is.finite(scores$.estimate)),
nrow(scores) == 2L * nrow(plans))
ids <- setdiff(names(plans), "splits")
if (inherits(result, "last_fit")) for (id in ids) scores[[id]] <- plans[[id]][1L]
expected <- do.call(rbind, lapply(seq_len(nrow(plans)), function(i) {
rows <- as.integer(plans$splits[[i]], "assessment")
cbind(as.data.frame(plans[rep(i, length(rows)), ids, drop = FALSE]),
.row = rows, .config = "pre0_mod0_post0")
}))
keys <- c(ids, ".row", ".config")
stopifnot(!anyDuplicated(predictions[keys]), nrow(predictions) == nrow(expected),
nrow(merge(predictions[keys], expected, by = keys)) == nrow(expected),
!anyDuplicated(scores[c(ids, ".metric", ".config")]))
for (i in seq_len(nrow(plans))) {
matches <- function(x) Reduce(`&`, lapply(ids, function(id) x[[id]] == plans[[id]][i]))
p <- predictions[matches(predictions), ]
m <- scores[matches(scores), ]
column <- paste0(".pred_", levels(d$truth)[if (event == "first") 1L else 2L])
values <- c(brier_class = yardstick::brier_class_vec(p$truth, p[[column]], event_level = event),
mn_log_loss = yardstick::mn_log_loss_vec(p$truth, p[[column]], event_level = event))
stopifnot(all(abs(m$.estimate - values[m$.metric]) <= 1e-10))
}
}
for (method in c("inductive", "cross")) for (event in c("first", "second")) {
spec <- vennabers::calibrated_workflow(base, "truth", method = method, event_level = event,
seed = 42, postprocessing = post)
fitted <- generics::fit(spec, d)
details <- vennabers::venn_abers_details(fitted, d[c("x", "row_id")])
stopifnot(identical(details$prediction, predict(fitted, d, type = "prob")),
all(details$details$postprocessing_method == "tailor_logistic"))
result <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine,
event_level = event, allow_par = FALSE))
audit(result, outer, event)
states <- tune::collect_extracts(result)$.extracts
for (i in seq_along(states)) {
local <- rsample::analysis(outer$splits[[i]])
A <- rsample::assessment(outer$splits[[i]])$row_id
for (plan in states[[i]]$postprocessing) {
stopifnot(!any(local$row_id[c(plan$B, plan$P, plan$C)] %in% A),
!length(intersect(plan$B, plan$P)), !length(intersect(plan$Q, plan$C)))
}
}
split <- rsample::make_splits(list(analysis = 1:180, assessment = 181:240), d)
last <- tune::last_fit(spec, split, metrics = metrics,
control = tune::control_last_fit(event_level = event))
audit(last, rsample::manual_rset(list(split), "train/test split"), event)
# Changing A changes evaluation, never the fitted state or predictions.
changed <- d; changed$x[181:240] <- 1000; changed$truth[181:240] <- "yes"
changed_split <- rsample::make_splits(list(analysis = 1:180, assessment = 181:240), changed)
other <- tune::last_fit(spec, changed_split, metrics = metrics,
control = tune::control_last_fit(event_level = event))
original <- workflows::extract_fit_engine(last$.workflow[[1]])
after <- workflows::extract_fit_engine(other$.workflow[[1]])
stopifnot(identical(original$postprocessing, after$postprocessing),
identical(predict(last$.workflow[[1]], d, type = "prob"), predict(other$.workflow[[1]], d, type = "prob")))
}
})Shared multiclass Tailor holdouts
tailor-multiclass-holdout.R: Use logistic postprocessing
for two classes and multinomial postprocessing for three or more, with
encoded names and native evaluation.
# Installed example: shared OvO/OvR retains full workflows trained on B, with
# one Tailor step learned on disjoint P, before VA calibration on held-out C.
# Choose logistic explicitly for two classes, multinomial for three or more.
# Multinomial P uses probably/nnet's default 100 iterations, independently of
# the B engine. Weakly informative probabilities may fail with fold/pair/B/P
# context, without retry or method switch; postprocessing has no maxit option.
packages <- c("vennabers", "workflows", "tailor", "probably", "recipes", "nnet", "tune", "yardstick")
cases <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
source(system.file("examples", "assertions.R", package = "vennabers"), local = TRUE)
audit <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), audit)
for (k in 2:4) for (method in c("inductive", "cross")) for (classification in c("ovo", "ovr")) {
original <- withr::with_seed(123, {
truth <- factor(rep(c("z z", "a.a", "a a", ".pred_class")[seq_len(k)], length.out = 480),
levels = c("z z", "a.a", "a a", ".pred_class")[seq_len(k)])
data.frame(x = rnorm(480, sd = 2) + c(-1, 1, -1, 1)[truth],
z = rnorm(480, sd = 2) + c(-1, -1, 1, 1)[truth],
w = rnorm(480, sd = 2) + c(1, -1, -1, 1)[truth], truth = truth)
})
names(original) <- c("input value", "input.value", "other value", ".pred_class")
schema <- vennabers::venn_abers_schema(original, ".pred_class", classification = classification)
d <- vennabers::venn_abers_encode(original, schema)
outcome <- schema$encoded_outcome
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(reformulate(setdiff(names(d), outcome), outcome), d) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(if (k == 2L) parsnip::logistic_reg(engine = "glm") else
parsnip::multinom_reg(penalty = .1) |> parsnip::set_engine("nnet", trace = FALSE))
# Both B and P need all k classes, P needs at least k+1 rows and the actual
# Tailor design must have rank k. Failed convergence is an error, not fallback.
post <- list(method = if (k == 2L) "tailor_logistic" else "tailor_multinomial", strategy = "holdout", prop = .4)
spec <- vennabers::calibrated_workflow(base, outcome, schema = schema, method = method,
seed = 24, postprocessing = post)
split <- rsample::make_splits(list(analysis = 1:384, assessment = 385:480), d)
metrics <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
result <- tune::last_fit(spec, split, metrics = metrics)
fit <- result$.workflow[[1]]
native <- vennabers::venn_abers_details(fit, d[385:480, setdiff(names(d), outcome)])
decoded <- vennabers::venn_abers_decode(native, schema)
predictions <- tune::collect_predictions(result)
scores <- tune::collect_metrics(result)
assert_conditions(nrow(tune::collect_notes(result)) == 0L, identical(predictions$.row, 385:480),
!anyDuplicated(predictions$.row), all(predictions$.config == "pre0_mod0_post0"),
nrow(scores) == 2L, all(is.finite(scores$.estimate)),
identical(as.matrix(predictions[names(native$prediction)]), as.matrix(native$prediction)),
identical(colnames(decoded$probability), schema$class_levels),
identical(decoded$postprocessing[[1]]$classes, schema$class_levels),
identical(decoded$postprocessing[[1]]$columns, names(original)),
all(native$details$postprocessing_method == post$method),
abs(scores$.estimate[scores$.metric == "brier_class"] -
vennabers::brier_score(original[[schema$outcome]][385:480], decoded$probability) / 2) <= 1e-10)
if (k > 2L) {
coefficients <- decoded$postprocessing[[1]]$coefficients
assert_conditions(identical(rownames(coefficients), schema$class_levels[-1L]),
all(colnames(coefficients)[-1L] %in% paste0(".pred_", schema$class_levels)))
}
outer <- withr::with_seed(74, rsample::vfold_cv(d, v = 2, repeats = 2))
resampled <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine, allow_par = FALSE))
audit$check_encoded_evaluation(resampled, outer, schema)
states <- tune::collect_extracts(resampled)$.extracts
for (i in seq_along(states)) for (plan in states[[i]]$postprocessing) {
Q <- as.integer(outer$splits[[i]], "analysis")
A <- as.integer(outer$splits[[i]], "assessment")
assert_conditions(!any(Q[c(plan$B, plan$P, plan$C)] %in% A),
!length(intersect(plan$B, plan$P)), !length(intersect(plan$Q, plan$C)),
plan$observed_base_fits == 1L, plan$observed_postprocessor_fits == 1L)
}
# Changing outer A never changes the learned state.
changed <- d; changed[385:480, 1L] <- 1000
changed[[outcome]][385:480] <- levels(changed[[outcome]])[1L]
other <- tune::last_fit(spec, rsample::make_splits(list(analysis = 1:384, assessment = 385:480), changed), metrics = metrics)
assert_conditions(identical(workflows::extract_fit_engine(fit)$postprocessing,
workflows::extract_fit_engine(other$.workflow[[1]])$postprocessing),
identical(predict(fit, d, type = "prob"), predict(other$.workflow[[1]], d, type = "prob")))
cases[[paste(k, method, classification)]] <- list(fit = fit, schema = schema,
new = d[setdiff(names(d), outcome)])
}
}Regression Tailor holdouts
tailor-regression-holdout.R: Learn a linear adjustment
before IVAR/CVAR and evaluate the complete procedure.
# Installed example: B learns the recipe/engine, disjoint P learns Tailor's
# linear adjustment, and held-out C learns IVAR/CVAR. Outer A learns nothing.
packages <- c("vennabers", "workflows", "tailor", "probably", "recipes", "tune", "yardstick")
cases <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
source(system.file("examples", "assertions.R", package = "vennabers"), local = TRUE)
audit <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), audit)
original <- data.frame("input value" = sin(1:240), "input.value" = cos(1:240),
".pred" = 10 + 3 * sin(1:240) + cos(1:240) + sin((1:240) / 3), check.names = FALSE)
schema <- vennabers::venn_abers_schema(original, ".pred")
d <- vennabers::venn_abers_encode(original, schema)
outcome <- schema$encoded_outcome
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(reformulate(setdiff(names(d), outcome), outcome), d) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::linear_reg(engine = "lm"))
# prop reserves P's fraction of Q. P needs at least three rows and an actual
# full-rank intercept/prediction design. smooth=FALSE is fixed; finite input,
# learned method and convergence are checked. No fallback or refit at predict.
# Automatic B/P plans are unstratified, including numeric 0/1 outcomes.
post <- list(method = "tailor_linear", strategy = "holdout", prop = .3)
metrics <- yardstick::metric_set(yardstick::rmse, yardstick::mae)
for (method in c("inductive", "cross")) {
spec <- vennabers::calibrated_workflow(base, outcome, schema = schema,
method = method, m = 1, seed = 42, postprocessing = post)
outer <- withr::with_seed(74, 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))
audit$check_encoded_evaluation(result, outer, schema)
states <- tune::collect_extracts(result)$.extracts
for (i in seq_along(states)) for (plan in states[[i]]$postprocessing) {
Q <- as.integer(outer$splits[[i]], "analysis")
A <- as.integer(outer$splits[[i]], "assessment")
assert_conditions(!any(Q[c(plan$B, plan$P, plan$C)] %in% A),
!length(intersect(plan$B, plan$P)), !length(intersect(plan$Q, plan$C)),
plan$observed_base_fits == 1L, plan$observed_postprocessor_fits == 1L)
}
split <- rsample::make_splits(list(analysis = 1:180, assessment = 181:240), d)
last <- tune::last_fit(spec, split, metrics = metrics)
fit <- last$.workflow[[1L]]
native <- vennabers::venn_abers_details(fit, d[181:240, setdiff(names(d), outcome)])
decoded <- vennabers::venn_abers_decode(native, schema)
predictions <- tune::collect_predictions(last)
scores <- tune::collect_metrics(last)
truth <- original[[schema$outcome]][181:240]
reference <- c(rmse = yardstick::rmse_vec(truth, decoded$prediction),
mae = yardstick::mae_vec(truth, decoded$prediction))
assert_conditions(nrow(tune::collect_notes(last)) == 0L, identical(predictions$.row, 181:240),
!anyDuplicated(predictions$.row), all(predictions$.config == "pre0_mod0_post0"),
nrow(scores) == 2L, setequal(scores$.metric, names(reference)), all(is.finite(scores$.estimate)),
all(abs(scores$.estimate - reference[scores$.metric]) <= 1e-10),
identical(predictions$.pred, native$prediction$.pred),
identical(decoded$postprocessing[[1L]]$columns, names(original)),
all(native$details$postprocessing_method == "tailor_linear"),
all(native$details$postprocessing_input == "numeric"))
# Predictor-only and truth-only outer A mutations leave all learned state fixed.
for (column in c(names(d)[1L], outcome)) {
changed <- d; changed[181:240, column] <- changed[181:240, column] + 1000
other <- tune::last_fit(spec, rsample::make_splits(list(analysis = 1:180, assessment = 181:240), changed), metrics = metrics)
before <- workflows::extract_fit_engine(fit)
after <- workflows::extract_fit_engine(other$.workflow[[1L]])
assert_conditions(identical(before$postprocessing, after$postprocessing),
identical(before$calibrator, after$calibrator),
identical(predict(fit, d), predict(other$.workflow[[1L]], d)))
for (id in names(before$models)) assert_conditions(
identical(workflows::extract_recipe(before$models[[id]])$steps, workflows::extract_recipe(after$models[[id]])$steps),
identical(coef(workflows::extract_fit_engine(before$models[[id]])), coef(workflows::extract_fit_engine(after$models[[id]]))))
}
cases[[method]] <- list(fit = fit, schema = schema, new = d[setdiff(names(d), outcome)])
}
}Regression isotonic holdouts
isotonic-regression-holdout.R: Learn reference numeric
isotonic postprocessing on separate P data before IVAR/CVAR.
# B trains the full recipe/engine. Disjoint P trains numeric isotonic
# calibration; C trains IVAR/CVAR. Outer assessment A is evaluation only.
packages <- c("vennabers", "workflows", "recipes", "rsample", "tune", "yardstick")
cases <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
source(system.file("examples", "assertions.R", package = "vennabers"), local = TRUE)
original <- data.frame("input value" = sin(1:120),
"target y" = 10 + 3 * sin(1:120) + cos(1:120) + sin((1:120) / 4), check.names = FALSE)
schema <- vennabers::venn_abers_schema(original, "target y")
d <- vennabers::venn_abers_encode(original, schema)
outcome <- schema$encoded_outcome
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(reformulate(setdiff(names(d), outcome), outcome), d) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::linear_reg(engine = "lm"))
metrics <- yardstick::metric_set(yardstick::rmse, yardstick::mae)
post <- list(method = "isotonic_numeric", strategy = "holdout", prop = .3)
outer <- withr::with_seed(74, rsample::vfold_cv(d, v = 2))
split <- rsample::make_splits(list(analysis = 1:90, assessment = 91:120), d)
for (method in c("inductive", "cross")) {
options <- if (method == "inductive") list(m = 1) else list(epsilon = .5)
spec <- do.call(vennabers::calibrated_workflow, c(list(workflow = base,
outcome = outcome, schema = schema, method = method, seed = 42,
postprocessing = post), options))
resampled <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine, allow_par = FALSE))
assert_conditions(nrow(tune::collect_notes(resampled)) == 0L,
nrow(tune::collect_predictions(resampled)) == 120L)
for (i in seq_along(outer$splits)) {
state <- tune::collect_extracts(resampled)$.extracts[[i]]
Q <- as.integer(outer$splits[[i]], "analysis")
A <- as.integer(outer$splits[[i]], "assessment")
for (plan in state$postprocessing) assert_conditions(
!any(Q[c(plan$B, plan$P, plan$C)] %in% A),
!length(intersect(plan$B, plan$P)), !length(intersect(plan$Q, plan$C)),
plan$observed_base_fits == 1L, plan$observed_postprocessor_fits == 1L)
}
last <- tune::last_fit(spec, split, metrics = metrics)
assert_conditions(nrow(tune::collect_notes(last)) == 0L)
fit <- last$.workflow[[1L]]
new <- d[91:120, setdiff(names(d), outcome), drop = FALSE]
native <- vennabers::venn_abers_details(fit, new)
decoded <- vennabers::venn_abers_decode(native, schema)
collected <- tune::collect_predictions(last)
assert_conditions(identical(collected$.row, 91:120),
identical(collected$.pred, native$prediction$.pred),
all(native$details$postprocessing_method == "isotonic_numeric"),
all(native$details$postprocessing_input == "numeric"),
all(is.finite(decoded$prediction)))
before <- workflows::extract_fit_engine(fit)
for (column in c(names(d)[1L], outcome)) {
changed <- d
changed[91:120, column] <- changed[91:120, column] + 100
other <- tune::last_fit(spec, rsample::make_splits(list(analysis = 1:90, assessment = 91:120), changed),
metrics = metrics)$.workflow[[1L]]
after <- workflows::extract_fit_engine(other)
assert_conditions(identical(before$postprocessing, after$postprocessing),
identical(before$calibrator, after$calibrator),
identical(predict(fit, new), predict(other, new)))
for (id in names(before$models)) assert_conditions(
identical(before$models[[id]]$isotonic, after$models[[id]]$isotonic),
identical(coef(workflows::extract_fit_engine(before$models[[id]]$workflow)),
coef(workflows::extract_fit_engine(after$models[[id]]$workflow))))
}
cases[[method]] <- list(fit = fit, new = new, schema = schema)
}
}Binary postprocessing ensembles
binary-ensemble.R: Average complete inner
model/postprocessor predictions before VA calibration on held-out C
data.
# Run with an installed vennabers and its optional tidymodels dependencies.
# Each inner B/P pair learns a complete workflow and postprocessor. Equal
# pair means train VA on C; outer assessment A stays outside all learning.
if (all(vapply(c("vennabers", "tune", "yardstick", "recipes", "tailor", "probably"),
requireNamespace, logical(1), quietly = TRUE))) local({
d <- data.frame(x = sin(1:240), row_id = 1:240,
truth = factor(rep(c("yes", "no", "no", "yes"), 60)))
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ x, d) |> recipes::step_normalize(x)) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
# P folds partition each local Q exactly once; each B is the complement.
# J=3 complete pairs are retained per VA fold. No inner VA is fitted.
outer <- withr::with_seed(74, rsample::vfold_cv(d, v = 2, repeats = 2, strata = truth, pool = 0))
metrics <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
audit <- function(result, plans, event) {
predictions <- tune::collect_predictions(result, summarize = FALSE)
scores <- tune::collect_metrics(result, summarize = FALSE)
stopifnot(nrow(tune::collect_notes(result)) == 0L, all(is.finite(scores$.estimate)),
nrow(scores) == 2L * nrow(plans))
ids <- setdiff(names(plans), "splits")
if (inherits(result, "last_fit")) for (id in ids) scores[[id]] <- plans[[id]][1L]
expected <- do.call(rbind, lapply(seq_len(nrow(plans)), function(i) {
rows <- as.integer(plans$splits[[i]], "assessment")
cbind(as.data.frame(plans[rep(i, length(rows)), ids, drop = FALSE]),
.row = rows, .config = "pre0_mod0_post0")
}))
keys <- c(ids, ".row", ".config")
stopifnot(!anyDuplicated(predictions[keys]), nrow(predictions) == nrow(expected),
nrow(merge(predictions[keys], expected, by = keys)) == nrow(expected),
!anyDuplicated(scores[c(ids, ".metric", ".config")]))
for (i in seq_len(nrow(plans))) {
matches <- function(x) Reduce(`&`, lapply(ids, function(id) x[[id]] == plans[[id]][i]))
p <- predictions[matches(predictions), ]
m <- scores[matches(scores), ]
column <- paste0(".pred_", levels(d$truth)[if (event == "first") 1L else 2L])
values <- c(brier_class = yardstick::brier_class_vec(p$truth, p[[column]], event_level = event),
mn_log_loss = yardstick::mn_log_loss_vec(p$truth, p[[column]], event_level = event))
stopifnot(all(abs(m$.estimate - values[m$.metric]) <= 1e-10))
}
}
for (kind in c("tailor_logistic", "probability", "glm_link")) for (method in c("inductive", "cross")) for (event in c("first", "second")) {
post <- list(method = if (kind == "tailor_logistic") kind else "sigmoid", strategy = "ensemble", v = 3L)
if (kind != "tailor_logistic") post$sigmoid_input <- kind
spec <- vennabers::calibrated_workflow(base, "truth", method = method, event_level = event,
seed = 42, postprocessing = post)
fitted <- generics::fit(spec, d)
details <- vennabers::venn_abers_details(fitted, d[c("x", "row_id")])
stopifnot(identical(details$prediction, predict(fitted, d, type = "prob")),
all(details$details$postprocessing_method == post$method),
all(lengths(details$details$inner_fold) == 3L))
result <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine,
event_level = event, allow_par = FALSE))
audit(result, outer, event)
states <- tune::collect_extracts(result)$.extracts
for (i in seq_along(states)) {
local <- rsample::analysis(outer$splits[[i]])
A <- rsample::assessment(outer$splits[[i]])$row_id
for (ensemble in states[[i]]$postprocessing) for (plan in ensemble$inner_folds) {
stopifnot(!any(local$row_id[c(plan$B, plan$P, plan$C)] %in% A),
!length(intersect(plan$B, plan$P)), !length(intersect(plan$Q, plan$C)))
}
}
split <- rsample::make_splits(list(analysis = 1:180, assessment = 181:240), d)
last <- tune::last_fit(spec, split, metrics = metrics,
control = tune::control_last_fit(event_level = event))
audit(last, rsample::manual_rset(list(split), "train/test split"), event)
# Changing either A predictors or truth changes evaluation, never learning.
for (variable in c("x", "truth")) {
changed <- d
if (variable == "x") changed$x[181:240] <- 1000 else changed$truth[181:240] <- "yes"
changed_split <- rsample::make_splits(list(analysis = 1:180, assessment = 181:240), changed)
other <- tune::last_fit(spec, changed_split, metrics = metrics,
control = tune::control_last_fit(event_level = event))
original <- workflows::extract_fit_engine(last$.workflow[[1]])
after <- workflows::extract_fit_engine(other$.workflow[[1]])
stopifnot(identical(original$postprocessing, after$postprocessing),
identical(predict(last$.workflow[[1]], d, type = "prob"), predict(other$.workflow[[1]], d, type = "prob")))
}
}
})Shared multiclass postprocessing ensembles
multiclass-ensemble.R: Average finished class vectors
with equal inner-pair weights, preserving encoded names and outer
assessment identities.
# Installed example: shared OvO/OvR retains J complete B/P workflows per VA
# fold. Their full probability vectors are averaged equally before VA on C.
# Choose logistic explicitly for two classes, multinomial for three or more.
# Multinomial P uses probably/nnet's default 100 iterations, independently of
# the B engine. Any unconverged pair fails the whole ensemble with fold/pair/B/P
# context, without retry or method switch; postprocessing has no maxit option.
packages <- c("vennabers", "workflows", "tailor", "probably", "recipes", "nnet", "tune", "yardstick")
cases <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
source(system.file("examples", "assertions.R", package = "vennabers"), local = TRUE)
audit <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), audit)
for (k in 2:4) for (method in c("inductive", "cross")) for (classification in c("ovo", "ovr")) {
original <- withr::with_seed(123, {
truth <- factor(rep(c("z z", "a.a", "a a", ".pred_class")[seq_len(k)], length.out = 480),
levels = c("z z", "a.a", "a a", ".pred_class")[seq_len(k)])
data.frame(x = rnorm(480, sd = 2) + c(-1, 1, -1, 1)[truth],
z = rnorm(480, sd = 2) + c(-1, -1, 1, 1)[truth],
w = rnorm(480, sd = 2) + c(1, -1, -1, 1)[truth], truth = truth)
})
names(original) <- c("input value", "input.value", "other value", ".pred_class")
schema <- vennabers::venn_abers_schema(original, ".pred_class", classification = classification)
d <- vennabers::venn_abers_encode(original, schema)
outcome <- schema$encoded_outcome
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(reformulate(setdiff(names(d), outcome), outcome), d) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(if (k == 2L) parsnip::logistic_reg(engine = "glm") else
parsnip::multinom_reg(penalty = .1) |> parsnip::set_engine("nnet", trace = FALSE))
# Both B and P need all k classes, P needs at least k+1 rows and the actual
# Tailor design must have rank k. Failed convergence is an error, not fallback.
post <- list(method = if (k == 2L) "tailor_logistic" else "tailor_multinomial", strategy = "ensemble", v = 3L)
spec <- vennabers::calibrated_workflow(base, outcome, schema = schema, method = method,
seed = 24, postprocessing = post)
split <- rsample::make_splits(list(analysis = 1:384, assessment = 385:480), d)
metrics <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
result <- tune::last_fit(spec, split, metrics = metrics)
fit <- result$.workflow[[1]]
native <- vennabers::venn_abers_details(fit, d[385:480, setdiff(names(d), outcome)])
decoded <- vennabers::venn_abers_decode(native, schema)
predictions <- tune::collect_predictions(result)
scores <- tune::collect_metrics(result)
assert_conditions(nrow(tune::collect_notes(result)) == 0L, identical(predictions$.row, 385:480),
!anyDuplicated(predictions$.row), all(predictions$.config == "pre0_mod0_post0"),
nrow(scores) == 2L, all(is.finite(scores$.estimate)),
identical(as.matrix(predictions[names(native$prediction)]), as.matrix(native$prediction)),
identical(colnames(decoded$probability), schema$class_levels),
identical(decoded$postprocessing[[1]]$inner_folds[[1]]$classes, schema$class_levels),
identical(decoded$postprocessing[[1]]$inner_folds[[1]]$columns, names(original)),
all(native$details$postprocessing_method == post$method),
all(lengths(native$details$inner_fold) == 3L),
abs(scores$.estimate[scores$.metric == "brier_class"] -
vennabers::brier_score(original[[schema$outcome]][385:480], decoded$probability) / 2) <= 1e-10)
if (k > 2L) {
coefficients <- decoded$postprocessing[[1]]$inner_folds[[1]]$coefficients
assert_conditions(identical(rownames(coefficients), schema$class_levels[-1L]),
all(colnames(coefficients)[-1L] %in% paste0(".pred_", schema$class_levels)))
}
outer <- withr::with_seed(74, rsample::vfold_cv(d, v = 2, repeats = 2))
resampled <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine, allow_par = FALSE))
audit$check_encoded_evaluation(resampled, outer, schema)
states <- tune::collect_extracts(resampled)$.extracts
for (i in seq_along(states)) for (ensemble in states[[i]]$postprocessing) for (plan in ensemble$inner_folds) {
Q <- as.integer(outer$splits[[i]], "analysis")
A <- as.integer(outer$splits[[i]], "assessment")
assert_conditions(!any(Q[c(plan$B, plan$P, plan$C)] %in% A),
!length(intersect(plan$B, plan$P)), !length(intersect(plan$Q, plan$C)),
plan$observed_base_fits == 1L, plan$observed_postprocessor_fits == 1L)
}
# Change A predictors and truth separately: neither can affect learning.
for (variable in c(names(d)[1L], outcome)) {
changed <- d
if (variable == outcome) changed[[outcome]][385:480] <- levels(d[[outcome]])[1L] else
changed[385:480, variable] <- 1000
other <- tune::last_fit(spec, rsample::make_splits(list(analysis = 1:384, assessment = 385:480), changed), metrics = metrics)
assert_conditions(identical(workflows::extract_fit_engine(fit)$postprocessing,
workflows::extract_fit_engine(other$.workflow[[1]])$postprocessing),
identical(predict(fit, d, type = "prob"), predict(other$.workflow[[1]], d, type = "prob")))
}
cases[[paste(k, method, classification)]] <- list(fit = fit, schema = schema,
new = d[setdiff(names(d), outcome)])
}
}Regression postprocessing ensembles
regression-ensemble.R: Compare linear and isotonic
numeric ensembles and check that held-out data stay outside
learning.
# Each inner pair learns its complete recipe/engine on B_j and its numeric
# postprocessor on disjoint P_j. P folds partition Q; B_j is Q minus P_j.
# Average finished numeric pair predictions equally, then calibrate VA on C.
# CVAR averages outer fold points and bounds separately: these bounds are
# descriptive VA bounds, not confidence or prediction intervals.
packages <- c("vennabers", "workflows", "tailor", "probably", "recipes", "rsample", "tune", "yardstick")
cases <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
source(system.file("examples", "assertions.R", package = "vennabers"), local = TRUE)
audit <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), audit)
original <- data.frame("input value" = sin(1:120),
"target y" = 10 + 3 * sin(1:120) + cos(1:120) + sin((1:120) / 4), check.names = FALSE)
schema <- vennabers::venn_abers_schema(original, "target y")
d <- vennabers::venn_abers_encode(original, schema)
outcome <- schema$encoded_outcome
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(reformulate(setdiff(names(d), outcome), outcome), d) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::linear_reg(engine = "lm"))
metrics <- yardstick::metric_set(yardstick::rmse, yardstick::mae)
outer <- withr::with_seed(74, rsample::vfold_cv(d, v = 2, repeats = 2))
split <- rsample::make_splits(list(analysis = 1:90, assessment = 91:120), d)
for (post_method in c("tailor_linear", "isotonic_numeric")) for (method in c("inductive", "cross")) {
# Linear requires >=3 P rows and rank two; isotonic requires >=2 finite
# P rows and permits constant inputs/truths. Failed pairs abort the fit.
post <- list(method = post_method, strategy = "ensemble", v = 3L)
options <- if (method == "inductive") list(m = 1) else list(epsilon = .5, v = 3L)
spec <- do.call(vennabers::calibrated_workflow, c(list(workflow = base,
outcome = outcome, schema = schema, method = method, seed = 42,
postprocessing = post), options))
resampled <- tune::fit_resamples(spec, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine, allow_par = FALSE))
audit$check_encoded_evaluation(resampled, outer, schema)
states <- tune::collect_extracts(resampled)$.extracts
for (i in seq_along(states)) for (ensemble in states[[i]]$postprocessing) {
assert_conditions(ensemble$observed_base_fits == 3L, ensemble$observed_postprocessor_fits == 3L,
identical(sort(unlist(lapply(ensemble$inner_folds, `[[`, "P"), use.names = FALSE)), sort(ensemble$Q)))
for (plan in ensemble$inner_folds) {
Q <- as.integer(outer$splits[[i]], "analysis")
A <- as.integer(outer$splits[[i]], "assessment")
assert_conditions(!any(Q[c(plan$B, plan$P, plan$C)] %in% A),
!length(intersect(plan$B, plan$P)), !length(intersect(plan$Q, plan$C)),
plan$observed_base_fits == 1L, plan$observed_postprocessor_fits == 1L)
}
}
last <- tune::last_fit(spec, split, metrics = metrics)
fit <- last$.workflow[[1L]]
new <- d[91:120, setdiff(names(d), outcome), drop = FALSE]
native <- vennabers::venn_abers_details(fit, new)
decoded <- vennabers::venn_abers_decode(native, schema)
collected <- tune::collect_predictions(last, summarize = FALSE)
scores <- tune::collect_metrics(last)
expected <- c(rmse = yardstick::rmse_vec(original[[schema$outcome]][91:120], decoded$prediction),
mae = yardstick::mae_vec(original[[schema$outcome]][91:120], decoded$prediction))
assert_conditions(nrow(tune::collect_notes(last)) == 0L, identical(collected$.row, 91:120),
!anyDuplicated(collected$.row), all(collected$.config == "pre0_mod0_post0"),
nrow(scores) == 2L, all(abs(scores$.estimate - expected[scores$.metric]) <= 1e-10),
identical(collected$.pred, native$prediction$.pred), all(is.finite(decoded$prediction)),
all(native$details$postprocessing_method == post_method),
all(native$details$postprocessing_input == "numeric"), all(lengths(native$details$inner_fold) == 3L),
identical(decoded$postprocessing[[1]]$inner_folds[[1]]$columns, names(original)))
# Mutate A predictors and truth separately: neither may affect any learning.
before <- workflows::extract_fit_engine(fit)
for (column in c(names(d)[1L], outcome)) {
changed <- d; changed[91:120, column] <- changed[91:120, column] + 100
other <- tune::last_fit(spec, rsample::make_splits(list(analysis = 1:90, assessment = 91:120), changed), metrics = metrics)
assert_conditions(nrow(tune::collect_notes(other)) == 0L)
other_fit <- other$.workflow[[1L]]; after <- workflows::extract_fit_engine(other_fit)
assert_conditions(identical(before$postprocessing, after$postprocessing),
identical(before$calibrator, after$calibrator), identical(predict(fit, new), predict(other_fit, new)))
for (id in names(before$models)) for (j in names(before$models[[id]]$models)) {
left <- before$models[[id]]$models[[j]]; right <- after$models[[id]]$models[[j]]
if (post_method == "isotonic_numeric") {
assert_conditions(identical(left$isotonic, right$isotonic))
left <- left$workflow; right <- right$workflow
}
assert_conditions(identical(coef(workflows::extract_fit_engine(left)), coef(workflows::extract_fit_engine(right))),
identical(workflows::extract_recipe(left)$steps, workflows::extract_recipe(right)$steps))
}
}
cases[[paste(post_method, method)]] <- list(fit = fit, new = new, schema = schema)
}
}Pairwise OvO postprocessing
pairwise-postprocessing.R: Distinguish class pairs from
inner B/P pairs and evaluate complete holdout or ensemble
compositions.
# Class pairs (pair_N) and inner B/P model/postprocessor pairs are different:
# each class pair owns its VA folds, and each VA fold retains its own B/P paths.
source(system.file("examples", "assertions.R", package = "vennabers"))
packages <- c("vennabers", "workflows", "recipes", "rsample", "tune", "yardstick", "tailor", "probably")
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
library(vennabers)
raw <- data.frame(x = sin(1:360), z = cos(1:360),
truth = factor(rep(c("class", "a b", "class", "a.b", "a b", "class"), 60),
levels = c("class", "a b", "a.b")))
names(raw) <- c("input value", "a.b", ".pred_class")
schema <- venn_abers_schema(raw, ".pred_class", classification = "ovo")
d <- venn_abers_encode(raw, schema); outcome <- schema$encoded_outcome
predictors <- setdiff(names(d), outcome)
base <- workflows::workflow() |> workflows::add_recipe(
recipes::recipe(reformulate(predictors, outcome), d) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
outer <- withr::with_seed(41, rlang::inject(rsample::vfold_cv(d, v = 2, repeats = 2, strata = !!outcome, pool = 0)))
split <- rsample::make_splits(list(analysis = 1:270, assessment = 271:360), d)
metrics <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
checker <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), checker)
cases <- list()
for (kind in c("tailor_logistic", "probability", "glm_link")) for (strategy in c("holdout", "ensemble"))
for (method in c("inductive", "cross")) {
post <- list(method = if (kind == "tailor_logistic") kind else "sigmoid", strategy = strategy)
if (kind != "tailor_logistic") post$sigmoid_input <- kind
if (strategy == "holdout") post$prop <- .3 else post$v <- 2L
args <- list(base, outcome, schema = schema, model_training = "pairwise", method = method,
seed = 42, postprocessing = post)
if (method == "cross") args$v <- 2L
model <- do.call(calibrated_workflow, args)
result <- tune::fit_resamples(model, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine, allow_par = FALSE))
checker$check_encoded_evaluation(result, outer, schema)
states <- tune::collect_extracts(result)$.extracts
for (i in seq_along(states)) {
local <- rsample::analysis(outer$splits[[i]])
analysis_rows <- as.integer(outer$splits[[i]], "analysis")
A <- as.integer(outer$splits[[i]], "assessment")
for (component in states[[i]]$pair_models) for (diagnostic in component$postprocessing) {
members <- if (strategy == "ensemble") diagnostic$inner_folds else list(diagnostic)
for (p in members) assert_conditions(
all(as.character(local[[outcome]][component$rows]) %in% component$class_levels),
identical(p$pair_id, component$pair_id), identical(p$classes, component$class_levels),
!any(analysis_rows[component$rows[c(p$B, p$P, p$C)]] %in% A),
!length(intersect(p$B, p$P)), !length(intersect(p$Q, p$C)))
}
}
last <- tune::last_fit(model, split, metrics = metrics)
native <- tune::collect_predictions(last); scores <- tune::collect_metrics(last)
decoded <- venn_abers_decode(native, schema)
values <- c(brier_class = yardstick::brier_class_vec(decoded$truth, decoded$probability),
mn_log_loss = yardstick::mn_log_loss_vec(decoded$truth, decoded$probability))
fit <- tune::extract_workflow(last)
new <- d[271:360, predictors]
assert_conditions(nrow(tune::collect_notes(last)) == 0L, identical(native$.row, 271:360),
!anyDuplicated(native$.row), all(native$.config == "pre0_mod0_post0"),
identical(native[[outcome]], d[[outcome]][271:360]), nrow(scores) == 2L,
setequal(scores$.metric, names(values)), all(is.finite(scores$.estimate)),
all(abs(scores$.estimate - values[scores$.metric]) <= 1e-10),
all(abs(as.matrix(native[paste0(".pred_", schema$classes)]) - as.matrix(predict(fit, new, type = "prob"))) <= 1e-10))
state <- workflows::extract_fit_engine(fit)
details <- venn_abers_details(fit, new)
cost <- sum(vapply(state$pair_models, function(p) sum(vapply(p$postprocessing, `[[`, 1L, "observed_base_fits")), 1L))
stopifnot(cost == 3L * (if (method == "cross") 2L else 1L) * (if (strategy == "ensemble") 2L else 1L),
identical(details$prediction, predict(fit, new, type = "prob")))
# A truth and predictor changes affect assessment only, never any class pair.
for (column in c(predictors[1], outcome)) {
changed <- d
if (column == outcome) changed[[column]][271:360] <- schema$classes[1] else changed[[column]][271:360] <- 1000
other <- tune::last_fit(model, rsample::make_splits(list(analysis = 1:270, assessment = 271:360), changed), metrics = metrics)
other_fit <- tune::extract_workflow(other)
stopifnot(identical(venn_abers_details(fit, new), venn_abers_details(other_fit, new)))
}
cases[[paste(kind, strategy, method)]] <- list(fit = fit, new = new, schema = schema)
cat(kind, strategy, method, ": 3 class pairs;", cost, "retained model/postprocessor pairs.\n")
}
}Full-model postprocessing compositions
full-postprocessing.R: Exercise all 80 fixed
compositions through native evaluation and last_fit, with separate
full-composition B/P plans.
# Full means an additional complete B/P composition on F (each local class
# pair for pairwise OvO), not an engine fitted on every F row. F gets its own
# holdout/inner folds. Held C predictions and VA calibrators stay unchanged;
# after success only F workflows remain, alongside all source diagnostics.
# Transfer to F changes the predictor distribution: split-calibration guarantees
# do not automatically transfer. CVAR bounds remain descriptive VA bounds.
source(system.file("examples", "assertions.R", package = "vennabers"))
packages <- c("vennabers", "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)
# Ten domain/method choices x two strategies x two VA methods x two sources.
domains <- data.frame(path = c("binary", "binary", "pairwise", "pairwise",
"ovo3", "ovr3", "ovo2", "ovr2", "regression", "regression"),
post = c("sigmoid", "tailor_logistic", "sigmoid", "tailor_logistic",
"tailor_multinomial", "tailor_multinomial", "tailor_logistic", "tailor_logistic",
"isotonic_numeric", "tailor_linear"))
for (i in seq_len(nrow(domains))) {
path <- domains$path[i]; kind <- domains$post[i]
regression <- path == "regression"; pairwise <- path == "pairwise"
classification <- if (pairwise) "ovo" else if (path %in% c("binary", "regression")) "binary" else substr(path, 1, 3)
k <- if (pairwise || path %in% c("ovo3", "ovr3")) 3L else 2L
raw <- withr::with_seed(123, {
cl <- factor(rep(c("a a", "a.a", "class")[seq_len(k)], length.out = 480),
levels = c("a a", "a.a", "class")[seq_len(k)])
x <- rnorm(480, sd = 2) + c(-1, 1, -1)[cl]
z <- rnorm(480, sd = 2) + c(-1, -1, 1)[cl]
w <- rnorm(480, sd = 2) + c(1, -1, -1)[cl]
data.frame(x = x, z = z, w = w, truth = if (regression) 10 + 2*x + z + rnorm(480) else cl)
})
names(raw) <- c("input value", "input.value", "other value", ".pred_class")
schema <- if (regression) venn_abers_schema(raw, ".pred_class") else
venn_abers_schema(raw, ".pred_class", classification = classification)
d <- venn_abers_encode(raw, schema); outcome <- schema$encoded_outcome
predictors <- setdiff(names(d), outcome)
engine <- if (regression) parsnip::linear_reg(engine = "lm") else
if (pairwise || k == 2L) parsnip::logistic_reg(engine = "glm") else
parsnip::multinom_reg(penalty = .1) |> parsnip::set_engine("nnet", trace = FALSE, maxit = 1000)
# maxit = 1000 controls only B. Tailor multinomial P still uses probably's
# default 100 iterations. Any unconverged pair fails the whole composition
# with fold/pair/B/P context, without retry, method switch or partial ensemble.
base <- workflows::workflow() |> workflows::add_recipe(
recipes::recipe(reformulate(predictors, outcome), d) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |> workflows::add_model(engine)
# Repeated outer folds: identities are checked on (id, id2, .row, .config).
# Small nested data: with seed 44 one pairwise Tailor P of 25 rows stops
# unconverged and that resample fails (no retry, no switch to none); seeds
# 43 and 45 keep a converged separable pairwise B engine with its retained
# glm warning, a tune note. This example uses 42, whose evaluation has none.
outer <- withr::with_seed(42, rsample::vfold_cv(d, v = 2, repeats = 2))
split <- rsample::make_splits(list(analysis = 1:384, assessment = 385:480), d)
metrics <- if (regression) yardstick::metric_set(yardstick::rmse, yardstick::mae) else
yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
for (strategy in c("holdout", "ensemble")) for (method in c("inductive", "cross"))
for (mode in c("matched", "full")) {
post <- list(method = kind, strategy = strategy)
if (kind == "sigmoid") post$sigmoid_input <- "probability"
if (strategy == "holdout") post$prop <- .3 else post$v <- 3L
args <- list(base, outcome, schema = schema, method = method,
prediction_model = mode, seed = 24, postprocessing = post)
if (method == "cross") args$v <- 2L
if (pairwise) args$model_training <- "pairwise"
model <- do.call(calibrated_workflow, args)
result <- tune::fit_resamples(model, outer, metrics = metrics,
control = tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine, allow_par = FALSE))
checker$check_encoded_evaluation(result, outer, schema)
states <- checker$check_outer_identities(result, outer, metrics = 2L)$extracts
for (h in seq_along(states)) {
components <- if (pairwise) states[[h]]$pair_models else list(states[[h]])
F_rows <- as.integer(outer$splits[[h]], "analysis"); A_rows <- as.integer(outer$splits[[h]], "assessment")
for (component in components) {
rows <- if (pairwise) component$rows else seq_along(F_rows)
for (diagnostic in component$postprocessing) {
members <- if (strategy == "ensemble") diagnostic$inner_folds else list(diagnostic)
for (p in members) assert_conditions(!any(F_rows[rows[c(p$B, p$P, p$C)]] %in% A_rows),
!length(intersect(p$B, p$P)), !length(intersect(p$Q, p$C)),
p$observed_base_fits == 1L, p$observed_postprocessor_fits == 1L)
}
if (mode == "full") stopifnot(identical(names(component$models), "Full1"),
identical(component$postprocessing$Full1$Q, seq_along(rows)))
}
}
last <- tune::last_fit(model, split, metrics = metrics)
fit <- tune::extract_workflow(last); new <- d[385:480, predictors]
native <- tune::collect_predictions(last)
decoded <- venn_abers_decode(native, schema)
values <- if (regression) c(rmse = yardstick::rmse_vec(decoded$truth, decoded$prediction),
mae = yardstick::mae_vec(decoded$truth, decoded$prediction)) else {
p <- decoded$probability
if (ncol(p) == 2L) p <- p[, 1L]
c(brier_class = yardstick::brier_class_vec(decoded$truth, p),
mn_log_loss = yardstick::mn_log_loss_vec(decoded$truth, p))
}
scores <- tune::collect_metrics(last)
assert_conditions(nrow(tune::collect_notes(last)) == 0L, identical(native$.row, 385:480),
!anyDuplicated(native$.row), all(native$.config == "pre0_mod0_post0"),
identical(native[[outcome]], d[[outcome]][385:480]), nrow(scores) == 2L,
setequal(scores$.metric, names(values)), all(is.finite(scores$.estimate)),
all(abs(scores$.estimate - values[scores$.metric]) <= 1e-10))
prediction <- predict(fit, new, type = if (regression) "numeric" else "prob")
stopifnot(identical(as.matrix(native[names(prediction)]), as.matrix(prediction)))
if (mode == "full") for (column in c(predictors[1L], outcome)) {
changed <- d
if (column != outcome || regression) changed[[column]][385:480] <- changed[[column]][385:480] + 100 else
changed[[column]][385:480] <- rev(changed[[column]][385:480])
other <- tune::last_fit(model, rsample::make_splits(list(analysis = 1:384, assessment = 385:480), changed), metrics = metrics)
stopifnot(nrow(tune::collect_notes(other)) == 0L,
identical(venn_abers_details(fit, new), venn_abers_details(tune::extract_workflow(other), new)))
}
cases[[paste(path, kind, strategy, method, mode)]] <- list(fit = fit, new = new, schema = schema)
cat(path, kind, strategy, method, mode, ": native evaluation complete.\n")
}
}
stopifnot(length(cases) == 80L)
}