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.
Train complete tidymodels workflows, preserve names with explicit
schemas, or calibrate already fitted workflows. Install the optional
workflow dependencies listed in DESCRIPTION; individual
examples also identify their engine and assessment dependencies.
Start with vignette("workflows", 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", "calibrated-workflow.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.
calibrated-workflow.R: Retain local preprocessing,
models and calibration together, then inspect predictions and learning
diagnostics.
# Installed example: optional integration; failures propagate when available.
source(system.file("examples", "assertions.R", package = "vennabers"))
packages <- c("parsnip", "workflows", "recipes", "rsample", "hardhat", "generics",
"rlang", "tibble", "tidyselect", "withr")
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) local({
library(vennabers)
# Development data are available for training and calibration. Assessment
# observations below are untouched by either learning step or parameter choice.
set.seed(12)
data <- data.frame(x = stats::rnorm(250))
data$truth <- factor(ifelse(stats::runif(250) < stats::plogis(data$x), "yes", "no"),
levels = c("yes", "no"))
development <- data[1:200, ]
assessment <- data[201:250, ]
recipe <- recipes::recipe(truth ~ x, development) |>
recipes::step_impute_median(recipes::all_numeric_predictors()) |>
recipes::step_normalize(recipes::all_numeric_predictors())
base <- workflows::workflow() |>
workflows::add_recipe(recipe) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
calibrated <- calibrated_workflow(base, outcome = "truth", seed = 42)
fitted <- generics::fit(calibrated, development)
# Prediction needs predictors only; assessment truth is used later for scoring.
new_data <- assessment["x"]
probability <- predict(fitted, new_data, type = "prob")
class <- predict(fitted, new_data, type = "class")
details <- venn_abers_details(fitted, new_data)
state <- workflows::extract_fit_engine(fitted)
assert_conditions(identical(probability, details$prediction), nrow(class) == 50L,
length(state$models) == 1L, state$event_class == "yes",
state$folds$Inductive1$training_size + state$folds$Inductive1$calibration_size == 200L)
# Prediction-time loss changes neither the fitted model nor its stored default.
brier <- predict(fitted, new_data, type = "prob", loss = "brier")
stopifnot(identical(brier, venn_abers_details(fitted, new_data, loss = "brier")$prediction),
workflows::extract_fit_engine(fitted)$loss == "log")
print(head(probability))
print(head(details$details))
print(brier_score(assessment$truth == "yes", probability$.pred_yes))
# Local recipe statistics are inspectable through the full stored workflow.
print(workflows::extract_recipe(state$models$Inductive1))
# This split cannot undo earlier tuning or transformations that used calibration
# or assessment observations. IID data and a model fixed independently of its
# calibration observations remain assumptions; VA bounds are not confidence
# intervals and calibration need not improve scores on a particular test set.
})
if (all(vapply(c(packages, "nnet"), requireNamespace, logical(1), quietly = TRUE))) local({
# A shared multiclass workflow is trained once per fold complement. This R
# plan does not establish parity with Python's separate pair-model training.
data <- iris
names(data)[5L] <- "truth"
split <- withr::with_seed(33, rsample::initial_split(data, .8, strata = truth))
development <- rsample::analysis(split)
assessment <- rsample::assessment(split)
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ ., development) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::multinom_reg(engine = "nnet"))
for (classification in c("ovo", "ovr")) {
fitted <- generics::fit(vennabers::calibrated_workflow(base, "truth", method = "cross",
classification = classification, seed = 33, precision = 2, loss = "brier"), development)
p <- predict(fitted, assessment, type = "prob")
cls <- predict(fitted, assessment, type = "class")
details <- vennabers::venn_abers_details(fitted, assessment)
state <- workflows::extract_fit_engine(fitted)
stopifnot(identical(p, details$prediction), nrow(cls) == nrow(assessment),
length(state$models) == 5L, setequal(details$details$fold, names(state$models)))
# Each diagnostic row is a binary fold result: aggregate across folds first,
# then couple OvO pairs or normalize OvR classes. No multiclass intervals.
print(head(details$details))
matrix_p <- as.matrix(p)
colnames(matrix_p) <- state$class_levels
print(c(brier = vennabers::brier_score(assessment$truth, matrix_p),
log_loss = vennabers::log_loss(assessment$truth, matrix_p)))
}
})encoded-binary.R: Preserve reserved predictor and class
names through encoding, native resampling and decoded predictions.
source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), local = TRUE)
if (all(vapply(c("parsnip", "workflows", "hardhat", "rsample", "recipes", "rlang", "tibble",
"withr", "generics", "tidyselect", "tune", "yardstick"),
requireNamespace, logical(1), quietly = TRUE))) {
development <- data.frame(x = sin(1:80), y = factor(rep(c("class", ".pred_yes", ".pred_yes", "class"), 20),
levels = c("class", ".pred_yes")))
names(development) <- c("vaV0001", ".pred_class")
schema <- vennabers::venn_abers_schema(development, outcome = ".pred_class", event_level = "second")
encoded <- vennabers::venn_abers_encode(development, schema)
# Build formulas/recipes explicitly in the encoded namespace.
formula <- reformulate(setdiff(names(encoded), schema$encoded_outcome), schema$encoded_outcome)
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(formula, encoded) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
model <- vennabers::calibrated_workflow(base, schema$encoded_outcome, schema = schema, seed = 42)
fitted <- generics::fit(model, encoded)
new_data <- vennabers::venn_abers_encode(development[1:3, "vaV0001", drop = FALSE], schema)
probability <- vennabers::venn_abers_decode(predict(fitted, new_data, type = "prob"), schema)$probability
class <- vennabers::venn_abers_decode(predict(fitted, new_data, type = "class"), schema)$class
details <- vennabers::venn_abers_decode(vennabers::venn_abers_details(fitted, new_data), schema)$details
stopifnot(identical(colnames(probability), c("class", ".pred_yes")), length(class) == 3L)
# Preserve prescribed memberships and repeat/fold IDs when rebuilding on encoded data.
original_outer <- withr::with_seed(41, rsample::vfold_cv(development, v = 2, repeats = 2))
outer <- rsample::manual_rset(lapply(original_outer$splits, function(s) {
rsample::make_splits(list(analysis = as.integer(s, data = "analysis"),
assessment = as.integer(s, data = "assessment")), encoded)
}), original_outer[c("id", "id2")])
control <- tune::control_resamples(save_pred = TRUE, extract = workflows::extract_fit_engine,
event_level = schema$event_level, parallel_over = "resamples", allow_par = FALSE, pkgs = c("vennabers", "stats"))
evaluation <- withr::with_seed(43, tune::fit_resamples(model, outer,
metrics = yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss), control = control))
checked <- check_encoded_evaluation(evaluation, outer, schema)
# Truth and original outcome never overwrite .pred_class or the outer IDs.
stopifnot(identical(checked$decoded$outcome, ".pred_class"), nrow(checked$decoded$identity) == 160L,
all(vapply(tune::collect_extracts(evaluation)$.extracts, function(s) identical(s$schema, schema), logical(1))))
}encoded-multiclass-regression.R: Use explicit schemas
for shared OvO/OvR and regression with Inductive/Cross calibration and
native evaluation.
# Installed examples: shared OvO/OvR and regression, Inductive and Cross.
source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), local = TRUE)
if (all(vapply(c("parsnip", "workflows", "hardhat", "rsample", "recipes", "rlang", "tibble",
"withr", "generics", "tidyselect", "tune", "yardstick", "nnet"),
requireNamespace, logical(1), quietly = TRUE))) {
examples <- list()
for (classification in c("ovo", "ovr", "regression")) {
regression <- classification == "regression"
development <- data.frame(x = sin(1:120), y = if (regression) 3 + sin(1:120) + cos(1:120) else
factor(rep(c("class", ".pred_yes", "ümlaut"), 40), levels = c("ümlaut", "class", ".pred_yes")))
names(development) <- c("vaV0001", if (regression) ".pred" else ".pred_class")
schema <- if (regression) vennabers::venn_abers_schema(development, ".pred") else
vennabers::venn_abers_schema(development, ".pred_class", classification = classification)
encoded <- vennabers::venn_abers_encode(development, schema)
formula <- reformulate(names(encoded)[1], schema$encoded_outcome)
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(formula, encoded) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(if (regression) parsnip::linear_reg(engine = "lm") else
parsnip::multinom_reg(engine = "nnet", penalty = .01))
# Rebuild prescribed outer memberships and IDs on the encoded data.
original_outer <- withr::with_seed(41, rsample::vfold_cv(development, v = 2, repeats = 2))
outer <- rsample::manual_rset(lapply(original_outer$splits, function(s) {
rsample::make_splits(list(analysis = as.integer(s, data = "analysis"),
assessment = as.integer(s, data = "assessment")), encoded)
}), original_outer[c("id", "id2")])
scoring <- if (regression) yardstick::metric_set(yardstick::rmse, yardstick::mae) else
yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
control <- tune::control_resamples(save_pred = TRUE, extract = identity, allow_par = FALSE,
parallel_over = "resamples", pkgs = c("vennabers", "stats", "nnet"))
for (method in c("inductive", "cross")) {
model <- vennabers::calibrated_workflow(base, schema$encoded_outcome, schema = schema,
method = method, seed = 42)
fitted <- generics::fit(model, encoded)
new <- vennabers::venn_abers_encode(development[1:3, "vaV0001", drop = FALSE], schema)
native <- predict(fitted, new, type = if (regression) "numeric" else "prob")
decoded <- vennabers::venn_abers_decode(native, schema)
details <- vennabers::venn_abers_decode(vennabers::venn_abers_details(fitted, new), schema)
if (!regression) {
class <- vennabers::venn_abers_decode(predict(fitted, new, type = "class"), schema)$class
stopifnot(identical(colnames(decoded$probability), schema$class_levels), identical(levels(class), schema$class_levels))
} else stopifnot(is.double(decoded$prediction), is.null(decoded$probability), is.null(decoded$class))
evaluation <- withr::with_seed(43, tune::fit_resamples(model, outer, metrics = scoring, control = control))
checked <- check_encoded_evaluation(evaluation, outer, schema)
stopifnot(nrow(checked$decoded$identity) == 2L * nrow(development), is.null(checked$decoded$details))
examples[[paste(classification, method)]] <- list(schema = schema, data = encoded, base = base,
model = model, fit = fitted, outer = outer, evaluation = evaluation, decoded = decoded, details = details)
}
}
}reference-splits.R: Illustrate ordered holdouts and
explicit fold complements on synthetic data, without claiming paper
benchmark reproduction.
# Reference-style row partitions; no downloads or new splitter API.
# Inspired by the binary, multiclass and regression applications of the
# Venn-Abers papers. These small synthetic examples illustrate roles, not
# reproductions of paper benchmarks.
library(vennabers)
source(system.file("examples", "assertions.R", package = "vennabers"))
# Calibration gets ceiling(n * calibration_prop) rows; training gets the
# preceding n - ceiling(n * calibration_prop). Never sort, shuffle or stratify.
ordered_holdout <- function(data, calibration_prop = .25) {
assert_conditions(is.numeric(calibration_prop), length(calibration_prop) == 1L,
is.finite(calibration_prop), calibration_prop > 0, calibration_prop < 1)
n <- nrow(data)
cut <- n - ceiling(n * calibration_prop)
stopifnot(cut >= 1L, cut < n)
rsample::make_splits(list(analysis = seq_len(cut),
assessment = seq.int(cut + 1L, n)), data)
}
if (all(vapply(c("parsnip", "workflows", "rsample", "recipes", "nnet", "withr"),
requireNamespace, logical(1), quietly = TRUE))) {
# A small known membership, including rounding of 11 * .25 to 3 held rows.
small <- data.frame(x = 11:1)
stopifnot(identical(as.integer(ordered_holdout(small), data = "analysis"), 1:8),
identical(as.integer(ordered_holdout(small), data = "assessment"), 9:11))
# Non-shuffled, stratified three-fold reference assignment. Class order is
# first appearance (b, a, c); class counts are 3, 4, 4. Remainders are spread
# across folds (sizes 4, 4, 3). Positions within each class keep their order.
small$truth <- factor(c("b", "b", "a", "a", "a", "c", "c", "c", "c", "b", "a"))
stratified_held <- list(c(1L, 3L, 4L, 6L), c(2L, 5L, 7L, 8L), 9:11)
stratified <- rsample::manual_rset(lapply(stratified_held, function(h) {
rsample::make_splits(list(analysis = setdiff(1:11, h), assessment = h), small)
}), c("First", "Second", "Third"))
stopifnot(identical(sort(unlist(stratified_held)), 1:11))
# All eight trainable paths: binary, shared OvO/OvR, and moderated regression,
# each with an ordered holdout and ordinary non-shuffled Cross folds.
reference_results <- list()
for (kind in c("binary", "ovo", "ovr", "regression")) {
data <- data.frame(x = sin(1:72), z = cos(1:72))
data$truth <- if (kind == "regression") 10 + 2 * data$x + data$z else
factor(rep(if (kind == "binary") c("working", "fault") else c("soil", "road", "water"),
length.out = nrow(data)))
# Final assessment is excluded from model learning AND calibration.
development <- data[1:60, ]
assessment <- data[61:72, ]
spec <- switch(kind, regression = parsnip::linear_reg(engine = "lm"),
binary = parsnip::logistic_reg(engine = "glm"),
parsnip::multinom_reg(engine = "nnet", penalty = .1))
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ ., development) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(spec)
# These are literal local positions, not forward validation. In particular,
# the first Cross model trains on later rows 21:60.
cross <- rsample::manual_rset(lapply(list(1:20, 21:40, 41:60), function(h) {
rsample::make_splits(list(analysis = setdiff(1:60, h), assessment = h), development)
}), c("Early", "Middle", "Late"))
for (method in c("inductive", "cross")) {
plan <- if (method == "inductive") ordered_holdout(development) else cross
resolve <- local_calibration_splits(list(plan), names(development))
options <- if (kind == "regression") list(m = 1L) else list(classification = kind)
model <- do.call(calibrated_workflow, c(list(workflow = base, outcome = "truth",
method = method, splits = resolve, seed = 42), options))
fit <- generics::fit(model, development)
p <- predict(fit, assessment)
score <- if (kind == "regression") {
c(rmse = sqrt(mean((p$.pred - assessment$truth)^2)))
} else {
p <- predict(fit, assessment, type = "prob")
probability <- as.matrix(p)
colnames(probability) <- sub("^\\.pred_", "", colnames(probability))
c(brier = brier_score(assessment$truth, probability),
log_loss = log_loss(assessment$truth, probability))
}
state <- workflows::extract_fit_engine(fit)
reference_results[[paste(kind, method, sep = "_")]] <- list(
model = model, fit = fit, development = development, assessment = assessment,
prediction = p, score = score, folds = state$folds)
stopifnot(all(is.finite(score)), identical(names(state$folds), names(state$models)))
}
}
# For mixed plans, use splits = NULL with seed, or a seeded initial_split()/
# vfold_cv() callback. Automatic classification stratifies by outcome unless
# strata = FALSE; regression does not stratify. Same seed requires the same
# R RNGkind, package/engine versions and model settings for reproducibility.
# R/Python seeds alone do not prove equal assignments or model outputs.
#
# Machine-failure detection is classification, not a failure-time forecast.
# Temperature forecast correction is regression; its subject does not make
# these partitions time-series validation. No rolling window, horizon, embargo,
# grouping or online update is introduced. Cross uses exact fold complements.
# Scores may get worse. VA bounds are not individual confidence/prediction
# intervals; neither dependent data nor Cross aggregates gain universal coverage.
}inductive-sizes.R: Request 50 training and 20
calibration rows out of 100, leaving 30 unassigned rows that only a
full-model refit learns from, then resolve the same sizes on every class
pair of a pairwise multiclass fit.
# Independent Inductive training and calibration sizes, as in sklearn's
# train_size/test_size. Rows in neither set form the unassigned set U: the
# matched source model and the Venn-Abers calibrator never see them, while a
# full-model refit (Full1) learns on all local rows, including C and U.
library(vennabers)
source(system.file("examples", "assertions.R", package = "vennabers"))
if (all(vapply(c("parsnip", "workflows", "rsample", "withr"),
requireNamespace, logical(1), quietly = TRUE))) {
data <- data.frame(x = sin(1:120) + rep(c(1, 0, 0, 1), 30),
truth = factor(rep(c("yes", "no", "no", "yes"), 30)))
development <- data[1:100, ]
assessment <- data[101:120, ]
base <- workflows::workflow() |>
workflows::add_formula(truth ~ x) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
# 100 local rows: 50 train the source model, 20 calibrate, 30 stay unassigned.
# Whole numbers are exact row counts; a value in (0, 1) is a proportion
# (training rounds down, calibration rounds up). Classification draws are
# stratified by outcome with exact totals unless strata = FALSE.
fits <- list()
for (mode in c("matched", "full")) {
fits[[mode]] <- generics::fit(calibrated_workflow(base, "truth", seed = 42,
training_size = 50, calibration_size = 20, prediction_model = mode), development)
state <- workflows::extract_fit_engine(fits[[mode]])
print(state)
roles <- state$folds$Inductive1
assert_conditions(length(roles$analysis) == 50L, length(roles$assessment) == 20L,
length(roles$unassigned) == 30L, identical(state$calibration$Inductive1$row, roles$assessment))
stopifnot(identical(sort(c(roles$analysis, roles$assessment, roles$unassigned)), 1:100),
identical(unname(state$sources), if (mode == "full") "Full1" else "Inductive1"))
}
# Both modes calibrate on the same 20 rows; only the prediction model differs.
stopifnot(identical(workflows::extract_fit_engine(fits$matched)$folds,
workflows::extract_fit_engine(fits$full)$folds))
for (mode in names(fits)) {
p <- predict(fits[[mode]], assessment, type = "prob")
probability <- as.matrix(p)
colnames(probability) <- sub("^\\.pred_", "", colnames(probability))
print(c(mode = mode, brier = round(brier_score(assessment$truth, probability), 4)))
}
# A single size takes the complement, so U is empty: 70 training rows, 30 C.
complement <- workflows::extract_fit_engine(generics::fit(calibrated_workflow(base, "truth",
seed = 42, training_size = .7), development))
stopifnot(lengths(complement$folds$Inductive1[c("analysis", "assessment", "unassigned")]) == c(70L, 30L, 0L))
# Sizes are checked strictly against the local rows and never shrunk.
message <- tryCatch(generics::fit(calibrated_workflow(base, "truth", seed = 42,
training_size = 80, calibration_size = 30), development), error = conditionMessage)
stopifnot(grepl("request 110 rows, but only the 100 local rows are available", message, fixed = TRUE))
# Pairwise multiclass resolves the sizes on each class pair's rows, with U
# per pair. Classes of 40, 30 and 20 rows give pairs of 70, 60 and 50 rows:
# half of each pair trains, 10 rows calibrate and the rest stay unassigned.
three <- data.frame(x = sin(1:90) + rep(c(0, .5, 1), c(40, 30, 20)),
truth = factor(rep(c("a", "b", "c"), c(40, 30, 20))))
pairwise <- workflows::extract_fit_engine(generics::fit(calibrated_workflow(base, "truth",
classification = "ovo", model_training = "pairwise", seed = 42,
training_size = .5, calibration_size = 10), three))
print(pairwise)
stopifnot(identical(pairwise$parameters$effective$unassigned_size,
c(pair_1 = 25L, pair_2 = 20L, pair_3 = 15L)))
# Searches whose candidates are calibrated workflows (calibration or joint
# model tuning) resolve the sizes again on resample rows and therefore
# accept proportions only; two-stage model searches also take row counts.
}model-adapter.R: Wrap GLM, multinomial and linear
regression fit/predict functions with model_adapter(),
calibrate them like native engines and keep their settings bound for
saved fits. The GLM callback also carries pairwise OvO, Sigmoid
postprocessing and a grid search over a recipe degree and the VA
loss.
# model_adapter(): your own fit(x, y) and predict(object, new_data) functions in
# a calibrated workflow, without registering a parsnip engine. The workflow keeps
# preprocessing, splits and calibration: every local fit trains a fresh model on
# its own prepared rows, and the calibrator never sees those training rows.
library(vennabers)
source(system.file("examples", "assertions.R", package = "vennabers"))
examples <- list()
if (all(vapply(c("parsnip", "workflows", "recipes", "rsample", "withr", "nnet"),
requireNamespace, logical(1), quietly = TRUE))) {
# Each factory binds its helpers and fixed settings locally, so a saved fit
# carries the actual functions into a fresh R process. Package functions use
# pkg::fun; nothing is looked up in the global environment later.
glm_adapter <- function() model_adapter("classification",
fit = function(x, y) list(model = stats::glm(y ~ ., data = cbind(x, y = y), family = stats::binomial()),
classes = levels(y)),
predict = function(object, new_data) {
# A binomial GLM models the second level. Return both named columns.
p <- stats::predict(object$model, new_data, type = "response")
matrix(c(1 - p, p), ncol = 2L, dimnames = list(NULL, object$classes))
})
multinom_adapter <- function(decay = 0) {
force(decay) # bind the value now, not a promise to the caller's variable
model_adapter("classification",
fit = function(x, y) nnet::multinom(y ~ ., data = cbind(x, y = y), decay = decay, trace = FALSE),
predict = function(object, new_data) {
# multinom drops a single row to a vector; keep one column per class.
p <- stats::predict(object, new_data, type = "probs")
matrix(p, nrow(new_data), length(object$lev), dimnames = list(NULL, object$lev))
})
}
lm_adapter <- function() model_adapter("regression",
fit = function(x, y) stats::lm(y ~ ., data = cbind(x, y = y)),
predict = function(object, new_data) unname(stats::predict(object, new_data)))
base <- function(spec, data) workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ ., data) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(spec)
# Binary: the same GLM as the native engine, so both calibrate identically.
binary <- data.frame(x = sin(1:200) + rep(c(1, 0, 0, 1), 50), z = cos(1:200),
truth = factor(rep(c("yes", "no", "no", "yes"), 50), levels = c("yes", "no")))
development <- binary[1:160, ]
assessment <- binary[161:200, c("x", "z")]
adapter <- calibrated_workflow(base(glm_adapter(), development), "truth", seed = 42)
native <- calibrated_workflow(base(parsnip::logistic_reg(engine = "glm"), development), "truth", seed = 42)
fit <- generics::fit(adapter, development)
p <- predict(fit, assessment, type = "prob")
print(head(p))
stopifnot(all.equal(p, predict(generics::fit(native, development), assessment, type = "prob")))
# Shared multiclass: the callback learns and predicts all local classes.
classes <- factor(rep(c("a", "b", "c"), 70))
multiclass <- data.frame(x = sin(1:210) + as.integer(classes), z = cos(1:210), truth = classes)
shared <- calibrated_workflow(base(multinom_adapter(decay = .1), multiclass[1:180, ]), "truth",
classification = "ovr", method = "cross", v = 3, seed = 42)
shared_fit <- generics::fit(shared, multiclass[1:180, ])
print(head(predict(shared_fit, multiclass[181:210, c("x", "z")], type = "prob")))
# Regression: one finite number per row; Full1 refits on all local rows.
regression <- data.frame(x = sin(1:150), z = cos(1:150))
regression$truth <- 10 + 3 * regression$x + regression$z^2
numeric <- calibrated_workflow(base(lm_adapter(), regression[1:120, ]), "truth",
prediction_model = "full", seed = 42)
numeric_fit <- generics::fit(numeric, regression[1:120, ])
print(head(venn_abers_details(numeric_fit, regression[121:150, c("x", "z")])$details))
# The stored state is the object your fit() returned, inside the workflow.
source_model <- workflows::extract_fit_engine(workflows::extract_fit_engine(fit)$models$Inductive1)
assert_conditions(inherits(source_model, "vennabers_adapter_fit"),
inherits(source_model$state$model, "glm"),
length(source_model$state$model$y) == length(workflows::extract_fit_engine(fit)$folds$Inductive1$analysis))
# Class pairs: the binary GLM callback carries pairwise OvO. Each call sees
# one pair's rows, with its two original levels. Overlapping classes keep
# every pair's GLM away from complete separation.
overlap <- transform(multiclass, x = x + .5 * sin(1:210))
pairwise <- calibrated_workflow(base(glm_adapter(), overlap[1:180, ]), "truth",
classification = "ovo", model_training = "pairwise", seed = 42)
pairwise_fit <- generics::fit(pairwise, overlap[1:180, ])
print(head(predict(pairwise_fit, overlap[181:210, c("x", "z")], type = "prob")))
# Postprocessing: B fits the callback, disjoint P learns Sigmoid on its
# probabilities, C learns Venn-Abers. The glm_link input needs the native GLM.
sigmoid <- list(method = "sigmoid", sigmoid_input = "probability", strategy = "holdout", prop = .3)
post_fit <- generics::fit(calibrated_workflow(base(glm_adapter(), development), "truth", seed = 42,
postprocessing = sigmoid), development)
stopifnot(all.equal(predict(post_fit, assessment, type = "prob"),
predict(generics::fit(calibrated_workflow(base(parsnip::logistic_reg(engine = "glm"), development), "truth",
seed = 42, postprocessing = sigmoid), development), assessment, type = "prob")))
examples <- list(
binary = list(data = binary, model = adapter, fit = fit, new = assessment),
multiclass = list(data = multiclass, model = shared, fit = shared_fit, new = multiclass[181:210, c("x", "z")]),
regression = list(data = regression, model = numeric, fit = numeric_fit, new = regression[121:150, c("x", "z")]))
# Searches tune calibration and recipe parameters. Callback settings are fixed
# in the functions, so the adapter itself declares no tune() parameters.
if (all(vapply(c("tune", "yardstick"), requireNamespace, logical(1), quietly = TRUE))) {
poly <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ x + z, development) |>
recipes::step_poly(x, degree = tune::tune("degree"))) |>
workflows::add_model(glm_adapter())
folds <- function(data) rsample::vfold_cv(data, v = 2)
searched <- calibrated_workflow(poly, "truth", loss = tune::tune("va_loss"), seed = 42,
tuning = list(strategy = "two_stage", selection_prop = .5,
model = list(method = "grid", grid = data.frame(degree = 1:2), resamples = folds),
calibration = list(method = "grid", grid = data.frame(va_loss = c("log", "brier")), resamples = folds)))
searched_fit <- generics::fit(searched, development)
print(venn_abers_tuning(searched_fit)$calibration$selected)
examples$search <- list(data = binary, model = searched, fit = searched_fit, new = assessment)
}
}engine-options.R: Set fixed rpart options with
parsnip::set_engine(), check that the full-model refit
carries them, see extra fit arguments rejected, and read the not-run
XGBoost early-stopping call.
# Fixed engine options and model-internal validation. Options set with
# parsnip::set_engine() travel with the base workflow, so every local fit
# (source models, class pairs, Full1 and postprocessing B) uses them on its own
# rows only. calibrated_workflow() and fit() take no extra fit arguments.
library(vennabers)
source(system.file("examples", "assertions.R", package = "vennabers"))
if (all(vapply(c("parsnip", "workflows", "rsample", "withr", "rpart"),
requireNamespace, logical(1), quietly = TRUE))) {
data <- data.frame(x = sin(1:200) + rep(c(1, 0, 0, 1), 50), z = cos(1:200),
truth = factor(rep(c("yes", "no", "no", "yes"), 50)))
development <- data[1:160, ]
assessment <- data[161:200, ]
# xval = 0 skips rpart's internal cross-validation; maxdepth is a fixed
# main argument of the model specification.
tree <- parsnip::decision_tree(mode = "classification", tree_depth = 3L) |>
parsnip::set_engine("rpart", xval = 0L, maxsurrogate = 0L)
base <- workflows::workflow() |>
workflows::add_formula(truth ~ .) |>
workflows::add_model(tree)
fit <- generics::fit(calibrated_workflow(base, "truth", method = "cross", v = 3L,
prediction_model = "full", seed = 42), development)
state <- workflows::extract_fit_engine(fit)
print(state)
# Full mode keeps one fresh model on all 160 rows; it carries the options.
engine <- workflows::extract_fit_engine(state$models$Full1)
assert_conditions(engine$control$xval == 0L, engine$control$maxsurrogate == 0L,
engine$control$maxdepth == 3L, length(engine$where) == 160L)
print(head(predict(fit, assessment, type = "prob")))
# Fit options belong in set_engine(); extra arguments are rejected.
message <- tryCatch(calibrated_workflow(base, "truth", xval = 0L), error = conditionMessage)
stopifnot(grepl("unsupported argument: xval", message, fixed = TRUE))
# Native early stopping works the same way. Each local fit splits its
# validation share from its own prepared rows; calibration rows never reach
# it. Not run here because xgboost is not a vennabers dependency:
if (FALSE) {
spec <- parsnip::boost_tree(mode = "classification", trees = 100L, stop_iter = 10L) |>
parsnip::set_engine("xgboost", validation = 0.2)
boosted <- workflows::workflow() |>
workflows::add_formula(truth ~ .) |>
workflows::add_model(spec)
fitted <- generics::fit(calibrated_workflow(boosted, "truth", seed = 42), development)
}
}full-model-workflow.R: Compare matched and full
prediction models while retaining the same held-out calibration
state.
# Fixed binary settings; the same permitted splits compare two procedures.
source(system.file("examples", "assertions.R", package = "vennabers"))
packages <- c("parsnip", "workflows", "hardhat", "rsample", "recipes", "rlang",
"tibble", "withr", "generics", "tidyselect")
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) local({
library(vennabers)
set.seed(12)
data <- data.frame(x = rnorm(160))
data$truth <- factor(ifelse(runif(160) < plogis(data$x), "yes", "no"), levels = c("yes", "no"))
final_split <- rsample::make_splits(list(analysis = 1:120, assessment = 121:160), data)
development <- rsample::analysis(final_split)
assessment <- rsample::assessment(final_split)
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ x, development) |> recipes::step_normalize(x)) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
for (method in c("inductive", "cross")) {
# This function receives only the current local fit domain, also in last_fit.
plan <- function(data) {
if (method == "cross") rsample::vfold_cv(data, v = 3, strata = truth) else
rsample::make_splits(list(analysis = 1:90, assessment = 91:120), data)
}
shared_plan <- withr::with_seed(42, plan(development))
fits <- lapply(c("matched", "full"), function(mode) generics::fit(
calibrated_workflow(base, "truth", method = method, prediction_model = mode,
splits = shared_plan, seed = 43), development))
matched <- workflows::extract_fit_engine(fits[[1L]])
full <- workflows::extract_fit_engine(fits[[2L]])
stopifnot(identical(matched$calibrator, full$calibrator),
identical(matched$calibration, full$calibration),
identical(names(full$models), "Full1"))
p <- lapply(fits, predict, new_data = assessment, type = "prob")
print(data.frame(method, prediction_model = c("matched", "full"),
brier = vapply(p, function(x) brier_score(assessment$truth == "yes", x$.pred_yes), 0)))
print(full)
print(head(venn_abers_details(fits[[2L]], assessment)$details))
# All source calibration rows/values remain inspectable after source models
# are discarded. The full recipe is learned anew on all 120 local rows.
print(head(full$calibration[[1L]]))
print(workflows::extract_recipe(full$models$Full1))
if (all(vapply(c("tune", "yardstick"), requireNamespace, logical(1), quietly = TRUE))) {
model <- calibrated_workflow(base, "truth", method = method, prediction_model = "full",
splits = shared_plan, seed = 43)
final <- tune::last_fit(model, final_split,
metrics = yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss))
prediction <- tune::collect_predictions(final)
assert_conditions(nrow(tune::collect_notes(final)) == 0L,
identical(prediction$.row, 121:160), !anyDuplicated(prediction$.row),
all(prediction$.config == "pre0_mod0_post0"),
identical(as.matrix(prediction[names(p[[2L]])]), as.matrix(p[[2L]])))
}
}
# Full transfer costs 2 (Inductive) or K+1 (Cross) base fits. Prediction uses
# one full model per batch; every held-out calibrator still participates.
# This model change does not transfer calibration/coverage guarantees and need
# not improve quality. Comparing procedures is selection: use fresh untouched
# data if the comparison above determines the procedure eventually deployed.
})full-multiclass-workflow.R: Use an additional full
shared model with held-out OvO/OvR calibrators and inspect the retained
state.
# Shared multiclass full-model transfer is an R extension. OvO still means
source(system.file("examples", "assertions.R", package = "vennabers"))
# pairwise calibration of one shared class matrix, not pairwise model training.
packages <- c("vennabers", "parsnip", "workflows", "recipes", "rsample", "nnet")
examples <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
library(vennabers)
data <- data.frame(x = sin(1:120), z = cos(1:120),
truth = factor(rep(c("class", ".pred_class", "a b"), 40),
levels = c("class", ".pred_class", "a b")))
names(data) <- c("a b", "a.b", ".pred_class")
for (method in c("inductive", "cross")) for (classification in c("ovo", "ovr")) {
schema <- venn_abers_schema(data, ".pred_class", classification = classification)
encoded <- venn_abers_encode(data, schema)
outer_split <- rsample::make_splits(list(analysis = 1:90, assessment = 91:120), encoded)
development <- rsample::analysis(outer_split)
assessment <- rsample::assessment(outer_split)
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(reformulate(names(encoded)[1:2], schema$encoded_outcome), development) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::multinom_reg(penalty = .1) |> parsnip::set_engine("nnet", trace = FALSE))
plan <- local({
cross <- method == "cross"
function(data) {
n <- nrow(data)
held <- if (cross) split(seq_len(n), cut(seq_len(n), 3, labels = FALSE)) else
list(seq.int(n - ceiling(n * .25) + 1L, n))
parts <- lapply(held, function(h) rsample::make_splits(
list(analysis = setdiff(seq_len(n), h), assessment = h), data))
if (cross) rsample::manual_rset(parts, paste0("Part", seq_along(parts))) else parts[[1L]]
}
})
models <- lapply(c("matched", "full"), function(mode) calibrated_workflow(base,
schema$encoded_outcome, schema = schema, method = method, model_training = "shared",
prediction_model = mode, splits = plan, seed = 42, precision = 2))
fits <- lapply(models, generics::fit, data = development)
source <- workflows::extract_fit_engine(fits[[1L]])
state <- workflows::extract_fit_engine(fits[[2L]])
stopifnot(identical(source$calibrator, state$calibrator), identical(source$calibration, state$calibration))
native <- venn_abers_details(fits[[2L]], assessment)
decoded <- venn_abers_decode(native, schema)
print(state)
print(head(native$details))
print(head(decoded$details))
print(head(decoded$probability))
print(head(venn_abers_decode(predict(fits[[2L]], assessment, type = "class"), schema)$class))
case <- list(schema = schema, data = encoded, base = base, model = models[[2L]],
fit = fits[[2L]], matched = fits[[1L]], assessment = assessment)
if (all(vapply(c("tune", "yardstick"), requireNamespace, logical(1), quietly = TRUE))) {
audit <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), audit)
outer <- withr::with_seed(41, rsample::vfold_cv(development, v = 2, repeats = 2))
scoring <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
result <- tune::fit_resamples(models[[2L]], outer, metrics = scoring,
control = tune::control_resamples(save_pred = TRUE, extract = identity, allow_par = FALSE))
checked <- audit$check_encoded_evaluation(result, outer, schema)
print(checked$metrics)
final <- tune::last_fit(models[[2L]], outer_split, metrics = scoring)
final_p <- tune::collect_predictions(final)
final_m <- tune::collect_metrics(final)
assert_conditions(nrow(tune::collect_notes(final)) == 0L, identical(final_p$.row, 91:120),
!anyDuplicated(final_p$.row), all(final_p$.config == "pre0_mod0_post0"),
identical(as.matrix(final_p[names(native$prediction)]), as.matrix(native$prediction)),
nrow(final_m) == 2L, all(is.finite(final_m$.estimate)))
# yardstick uses half the manual multiclass matrix Brier score, including
# the two-class multiclass contract. Log clipping affects metrics only.
truth <- venn_abers_decode(final_p, schema)$truth
stopifnot(abs(final_m$.estimate[final_m$.metric == "brier_class"] -
brier_score(truth, decoded$probability) / 2) <= 1e-10)
case$evaluation <- result
case$outer <- outer
}
examples[[paste(method, classification)]] <- case
}
# Full transfer costs two Inductive or K+1 Cross fits and one prediction per
# nonempty batch. The same full matrix reaches all held-out calibrators.
# This R extension makes no new calibration, coverage or quality guarantee.
}full-regression-workflow.R: Compare matched and full
IVAR/CVAR workflows at fixed settings.
# Fixed-setting IVAR/CVAR full-model transfer. Python 1.5.4 exposes this option
source(system.file("examples", "assertions.R", package = "vennabers"))
# in the exported lower VennAbersCV class, not its regression facade.
packages <- c("vennabers", "parsnip", "workflows", "recipes", "rsample")
examples <- list()
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
library(vennabers)
data <- data.frame(x = sin(1:120), z = cos(1:120), truth = 10 + 3 * sin(1:120) + cos(1:120)^2)
names(data) <- c("a b", "a.b", ".pred")
schema <- venn_abers_schema(data, ".pred")
encoded <- venn_abers_encode(data, schema)
outer_split <- rsample::make_splits(list(analysis = 1:90, assessment = 91:120), encoded)
development <- rsample::analysis(outer_split)
assessment <- rsample::assessment(outer_split)
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(reformulate(names(encoded)[1:2], schema$encoded_outcome), development) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::linear_reg(engine = "lm"))
for (method in c("inductive", "cross")) {
# Ordered local partitions are replayed for both modes and rebuilt inside
# each outer analysis domain. This synthetic example assumes IID data.
plan <- local({
cross <- method == "cross"
function(data) {
n <- nrow(data)
held <- if (cross) split(seq_len(n), cut(seq_len(n), 3, labels = FALSE)) else list(seq.int(n - 9L, n))
parts <- lapply(held, function(h) rsample::make_splits(
list(analysis = setdiff(seq_len(n), h), assessment = h), data))
if (cross) rsample::manual_rset(parts, paste0("Part", seq_along(parts))) else parts[[1L]]
}
})
models <- lapply(c("matched", "full"), function(mode) calibrated_workflow(base,
schema$encoded_outcome, schema = schema, method = method, prediction_model = mode,
splits = plan, m = 2, seed = 42))
fits <- lapply(models, generics::fit, data = development)
native <- venn_abers_details(fits[[2L]], assessment)
decoded <- venn_abers_decode(native, schema)
print(data.frame(method = method, matched = predict(fits[[1L]], assessment)$.pred, full = decoded$prediction))
print(head(decoded$details))
# Reconstruct the final points and descriptive bounds independently from
# complete per-fold results. Never merge the averaged bounds into a point.
reconstructed <- stats::aggregate(cbind(prediction, lower, upper) ~ row, decoded$details, mean)
stopifnot(max(abs(reconstructed$prediction - decoded$prediction)) <= 1e-10)
if (method == "cross") {
stopifnot(max(abs(as.matrix(reconstructed[c("lower", "upper")]) -
as.matrix(decoded$aggregate[c("lower", "upper")]))) <= 1e-10)
print(head(decoded$aggregate))
}
case <- list(schema = schema, data = encoded, base = base, model = models[[2L]],
fit = fits[[2L]], matched = fits[[1L]], assessment = assessment)
if (all(vapply(c("tune", "yardstick"), requireNamespace, logical(1), quietly = TRUE))) {
audit <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), audit)
scoring <- yardstick::metric_set(yardstick::rmse, yardstick::mae)
truth <- assessment[[schema$encoded_outcome]]
print(data.frame(method = method, mode = c("matched", "full"),
rmse = vapply(fits, function(f) yardstick::rmse_vec(truth, predict(f, assessment)$.pred), 0),
mae = vapply(fits, function(f) yardstick::mae_vec(truth, predict(f, assessment)$.pred), 0)))
outer <- withr::with_seed(41, rsample::vfold_cv(development, v = 2, repeats = 2))
result <- tune::fit_resamples(models[[2L]], outer, metrics = scoring,
control = tune::control_resamples(save_pred = TRUE, extract = identity, allow_par = FALSE))
checked <- audit$check_encoded_evaluation(result, outer, schema)
print(checked$metrics)
final <- tune::last_fit(models[[2L]], outer_split, metrics = scoring)
p <- tune::collect_predictions(final); metrics <- tune::collect_metrics(final)
assert_conditions(nrow(tune::collect_notes(final)) == 0L, identical(p$.row, 91:120), !anyDuplicated(p$.row),
all(p$.config == "pre0_mod0_post0"), identical(p[[schema$encoded_outcome]], truth),
identical(p$.pred, native$prediction$.pred), nrow(metrics) == 2L,
setequal(metrics$.metric, c("rmse", "mae")), all(is.finite(metrics$.estimate)),
all(metrics$.config == "pre0_mod0_post0"))
stopifnot(abs(metrics$.estimate[metrics$.metric == "rmse"] - yardstick::rmse_vec(truth, decoded$prediction)) <= 1e-10,
abs(metrics$.estimate[metrics$.metric == "mae"] - yardstick::mae_vec(truth, decoded$prediction)) <= 1e-10)
case$evaluation <- result; case$outer <- outer
}
examples[[method]] <- case
}
# Full transfer fits 2 / K+1 models, keeps only the full workflow plus held-out
# calibration values/calibrators, and predicts once per nonempty batch.
# No automatic coverage, calibration or quality guarantee follows. Aggregate
# regression bounds are descriptive, not confidence or prediction intervals.
}pairwise-inductive.R: Train a separate binary workflow
for each class pair with matching Inductive calibration.
# Separate binary training with matching Inductive calibration, at fixed settings.
source(system.file("examples", "assertions.R", package = "vennabers"))
packages <- c("vennabers", "parsnip", "workflows", "recipes", "rsample")
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
library(vennabers)
data <- data.frame(x = sin(1:120), z = cos(1:120),
truth = factor(rep(c("class", "a b", "a.b"), 40), levels = c("class", "a b", "a.b")))
names(data) <- c("a b", "a.b", ".pred_class")
schema <- venn_abers_schema(data, ".pred_class", classification = "ovo")
encoded <- venn_abers_encode(data, schema)
outer_split <- rsample::make_splits(list(analysis = 1:90, assessment = 91:120), encoded)
development <- rsample::analysis(outer_split)
assessment <- rsample::assessment(outer_split)
formula <- reformulate(names(encoded)[1:2], schema$encoded_outcome)
base <- workflows::workflow() |> workflows::add_recipe(
recipes::recipe(formula, development) |> recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
# Receives only this pair's current local raw data, with exactly two levels.
# This is local row order, not a shared global time cutoff. Both classes must
# occur in training and calibration. Mixed holdouts are also supported.
pair_plan <- function(data) {
n <- nrow(data)
held <- seq.int(n - ceiling(n / 4) + 1L, n)
rsample::make_splits(list(analysis = setdiff(seq_len(n), held), assessment = held), data)
}
model <- calibrated_workflow(base, schema$encoded_outcome, schema = schema,
model_training = "pairwise", splits = pair_plan, seed = 42)
fit <- generics::fit(model, development)
state <- workflows::extract_fit_engine(fit)
print(state)
pair_table <- data.frame(pair_id = names(state$pair_models),
class_1 = vapply(state$pair_models, function(s) s$class_levels[1L], ""),
class_2 = vapply(state$pair_models, function(s) s$class_levels[2L], ""))
print(pair_table)
native <- venn_abers_details(fit, assessment)
decoded <- venn_abers_decode(native, schema)
print(head(decoded$probability))
print(head(decoded$details))
# Direct fits may instead supply exactly pair_1, pair_2, ... as a plan list.
# The table above maps these stable IDs to classes; class names are never joined.
plans <- lapply(state$pair_models, function(component) {
local <- development[component$rows, , drop = FALSE]
local[[schema$encoded_outcome]] <- factor(local[[schema$encoded_outcome]], levels = component$class_levels)
pair_plan(local)
})
explicit <- generics::fit(calibrated_workflow(base, schema$encoded_outcome, schema = schema,
model_training = "pairwise", splits = plans, seed = 42), development)
stopifnot(identical(native, venn_abers_details(explicit, assessment)))
# Independent complete binary workflows: preprocessing sees only each pair's
# training rows, and held-out model probabilities fit the existing binary core.
q <- matrix(0, nrow(assessment), nrow(pair_table))
for (j in seq_along(plans)) {
training <- rsample::analysis(plans[[j]])
held <- rsample::assessment(plans[[j]])
reference <- workflows::workflow() |> workflows::add_recipe(
recipes::recipe(formula, training) |> recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
binary <- generics::fit(reference, training)
event <- pair_table$class_2[j]
column <- paste0(".pred_", event)
cal <- venn_abers(held[[schema$encoded_outcome]] == event, predict(binary, held, type = "prob")[[column]])
expected <- predict(cal, predict(binary, assessment, type = "prob")[[column]])
parts <- native$details[native$details$pair_id == pair_table$pair_id[j], c("lower", "upper", "probability")]
stopifnot(all(abs(as.matrix(parts) - as.matrix(expected)) <= 1e-10))
q[, j] <- expected$probability
}
# Reciprocal OvO coupling, written independently as sums of binary odds.
p <- vapply(state$class_levels, function(cl) {
relevant <- which(pair_table$class_1 == cl | pair_table$class_2 == cl)
odds <- lapply(relevant, function(j) {
probability <- if (pair_table$class_2[j] == cl) q[, j] else 1 - q[, j]
(1 - probability) / probability
})
1 / (1 + Reduce(`+`, odds))
}, numeric(nrow(assessment)))
stopifnot(all(abs(p / rowSums(p) - as.matrix(native$prediction)) <= 1e-10))
if (all(vapply(c("tune", "yardstick"), requireNamespace, logical(1), quietly = TRUE))) {
scoring <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
outer <- withr::with_seed(41, rsample::vfold_cv(development, v = 2, repeats = 2))
result <- tune::fit_resamples(model, outer, metrics = scoring,
control = tune::control_resamples(save_pred = TRUE, extract = identity, allow_par = FALSE))
checker <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), checker)
checked <- checker$check_encoded_evaluation(result, outer, schema)
print(checked$metrics)
final <- tune::last_fit(model, outer_split, metrics = scoring)
predictions <- tune::collect_predictions(final)
metrics <- tune::collect_metrics(final)
assert_conditions(nrow(tune::collect_notes(final)) == 0L, identical(predictions$.row, 91:120),
!anyDuplicated(predictions$.row), all(predictions$.config == "pre0_mod0_post0"),
identical(predictions[[schema$encoded_outcome]], assessment[[schema$encoded_outcome]]),
nrow(metrics) == 2L, all(is.finite(metrics$.estimate)),
all(abs(as.matrix(predictions[names(native$prediction)]) - as.matrix(native$prediction)) <= 1e-10))
}
# Matched: P = K*(K-1)/2 pairs cost P base fits and P predictions per nonempty
# batch. No extra shared model or OvR ensemble is trained. All P recipes and
# calibrators remain available; predict never learns. A row may belong to
# several pairs.
# Outer assessment labels never reach these local fits or calibration plans.
# Prepared outer plans can use local_calibration_splits() over all local pairs;
# a development-wide plan cannot be reused on a smaller outer analysis domain.
# Matching-model assumptions still apply; no universal accuracy gain is promised.
# Full transfer keeps the held-out calibrators but fits one extra workflow
# on each complete local pair, including its calibration rows.
full_model <- calibrated_workflow(base, schema$encoded_outcome, schema = schema,
model_training = "pairwise", method = "inductive", prediction_model = "full",
splits = pair_plan, seed = 42)
full_fit <- generics::fit(full_model, development)
full_state <- workflows::extract_fit_engine(full_fit)
for (id in names(state$pair_models)) stopifnot(
identical(state$pair_models[[id]]$calibration, full_state$pair_models[[id]]$calibration),
identical(state$pair_models[[id]]$calibrator, full_state$pair_models[[id]]$calibrator),
identical(names(full_state$pair_models[[id]]$models), "Full1"))
full_native <- venn_abers_details(full_fit, assessment)
full_decoded <- venn_abers_decode(full_native, schema)
print(head(full_decoded$details))
for (mode in c("matched", "full")) {
probability <- if (mode == "full") full_decoded$probability else decoded$probability
truth <- venn_abers_decode(assessment[schema$encoded_outcome], schema)$truth
cat(mode, "Brier:", brier_score(truth, probability),
"log loss:", log_loss(truth, probability), "\n")
}
# Six base fits (three sources, three Full1); only the Full1 workflows remain,
# each predicting once per nonempty batch. The printed slot map sends every
# held-out calibrator to its pair's Full1.
print(full_state)
# Each pair source is named pair_N/Full1; pair_id + fold identifies its
# calibrator. Source workflows are discarded after all full fits succeed.
# No in-sample recalibration or pooling occurs. Outer assessment stays excluded.
# Matching-model guarantees do not automatically transfer to the new model;
# neither coverage nor improved quality is promised. Settings are fixed here;
# pairwise-grid.R and pairwise-bayes.R show automatic local selection.
}pairwise-cross.R: Retain the matching binary workflows
and calibrators for every class pair and calibration fold.
# Separate pair/fold workflows with matching Cross calibration at fixed settings.
source(system.file("examples", "assertions.R", package = "vennabers"))
packages <- c("vennabers", "parsnip", "workflows", "recipes", "rsample")
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) {
library(vennabers)
data <- data.frame(x = sin(1:120), z = cos(1:120),
truth = factor(rep(c("class", "a b", "a.b"), 40), levels = c("class", "a b", "a.b")))
names(data) <- c("a b", "a.b", ".pred_class")
schema <- venn_abers_schema(data, ".pred_class", classification = "ovo")
encoded <- venn_abers_encode(data, schema)
outer_split <- rsample::make_splits(list(analysis = 1:90, assessment = 91:120), encoded)
development <- rsample::analysis(outer_split)
assessment <- rsample::assessment(outer_split)
formula <- reformulate(names(encoded)[1:2], schema$encoded_outcome)
base <- workflows::workflow() |> workflows::add_recipe(
recipes::recipe(formula, development) |> recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm"))
pairs <- combn(levels(development[[schema$encoded_outcome]]), 2, simplify = FALSE)
# A local function also works inside fit_resamples()/last_fit(). Here the
# class pair selects 3, 4 or 5 folds. Fold1 in different pairs is unrelated.
pair_plan <- function(data) {
j <- which(vapply(pairs, identical, logical(1), y = levels(data[[schema$encoded_outcome]])))
v <- 2L + j
held <- split(seq_len(nrow(data)), cut(seq_len(nrow(data)), v, labels = FALSE))
rsample::manual_rset(lapply(held, function(h) rsample::make_splits(
list(analysis = setdiff(seq_len(nrow(data)), h), assessment = h), data)), paste0("Fold", seq_len(v)))
}
plans <- setNames(lapply(pairs, function(pair) {
local <- development[development[[schema$encoded_outcome]] %in% pair, , drop = FALSE]
local[[schema$encoded_outcome]] <- factor(local[[schema$encoded_outcome]], levels = pair)
pair_plan(local)
}), paste0("pair_", seq_along(pairs)))
explicit <- calibrated_workflow(base, schema$encoded_outcome, schema = schema,
model_training = "pairwise", method = "cross", splits = plans, seed = 42)
fit <- generics::fit(explicit, development)
state <- workflows::extract_fit_engine(fit)
print(state)
pair_table <- data.frame(pair_id = names(state$pair_models),
class_1 = vapply(state$pair_models, function(s) s$class_levels[1L], ""),
class_2 = vapply(state$pair_models, function(s) s$class_levels[2L], ""))
print(pair_table)
native <- venn_abers_details(fit, assessment)
decoded <- venn_abers_decode(native, schema)
print(head(native$details))
print(head(decoded$probability))
print(head(decoded$details))
model <- calibrated_workflow(base, schema$encoded_outcome, schema = schema,
model_training = "pairwise", method = "cross", splits = pair_plan, seed = 42)
stopifnot(identical(native, venn_abers_details(generics::fit(model, development), assessment)))
# Reconstruct each pair from its binary fold endpoints, then couple globally.
# There is no global fold matrix and no averaging of coupled fold predictions.
for (loss in c("log", "brier")) {
details <- venn_abers_details(fit, assessment, loss = loss)
q <- vapply(names(plans), function(id) {
d <- details$details[details$details$pair_id == id, ]
lower <- matrix(d$lower, nrow(assessment))
upper <- matrix(d$upper, nrow(assessment))
if (loss == "brier") rowMeans(matrix(d$probability, nrow(assessment))) else {
a <- apply(upper, 1, prod)^(1 / ncol(upper))
b <- apply(1 - lower, 1, prod)^(1 / ncol(lower))
a / (a + b)
}
}, numeric(nrow(assessment)))
p <- vapply(state$class_levels, function(cl) {
relevant <- which(pair_table$class_1 == cl | pair_table$class_2 == cl)
odds <- lapply(relevant, function(j) {
probability <- if (pair_table$class_2[j] == cl) q[, j] else 1 - q[, j]
(1 - probability) / probability
})
1 / (1 + Reduce(`+`, odds))
}, numeric(nrow(assessment)))
stopifnot(all(abs(p / rowSums(p) - as.matrix(details$prediction)) <= 1e-10))
}
cost <- sum(vapply(state$pair_models, function(p) length(p$models), 1L))
stopifnot(cost == 12L)
cat("Base fits per complete local fit:", cost, "(3 + 4 + 5)\n")
if (all(vapply(c("tune", "yardstick"), requireNamespace, logical(1), quietly = TRUE))) {
scoring <- yardstick::metric_set(yardstick::brier_class, yardstick::mn_log_loss)
outer <- withr::with_seed(41, rsample::vfold_cv(development, v = 2, repeats = 2))
result <- tune::fit_resamples(model, outer, metrics = scoring,
control = tune::control_resamples(save_pred = TRUE, extract = identity, allow_par = FALSE))
checker <- new.env()
sys.source(system.file("examples", "check-encoded-evaluation.R", package = "vennabers"), checker)
checked <- checker$check_encoded_evaluation(result, outer, schema)
print(checked$metrics)
final <- tune::last_fit(model, outer_split, metrics = scoring)
predictions <- tune::collect_predictions(final)
metrics <- tune::collect_metrics(final)
assert_conditions(nrow(tune::collect_notes(final)) == 0L, identical(predictions$.row, 91:120),
!anyDuplicated(predictions$.row), all(predictions$.config == "pre0_mod0_post0"),
identical(predictions[[schema$encoded_outcome]], assessment[[schema$encoded_outcome]]),
nrow(metrics) == 2L, all(is.finite(metrics$.estimate)),
all(abs(as.matrix(predictions[names(native$prediction)]) - as.matrix(native$prediction)) <= 1e-10))
cat("Outer resampling base fits:", nrow(outer) * cost, "; last_fit base fits:", cost, "\n")
}
# Matched: all 12 complete workflows/calibrators remain stored. Nonempty
# predict calls each model exactly once and never learns; empty inputs call
# no models.
# Outer assessment outcomes enter only evaluation, never the local pair plans.
# One-sided calibration folds are valid when their complements train and return
# valid two-class probabilities. Every row is assessed once within each pair.
# Full transfer keeps the held-out calibrators but fits one extra workflow
# on each complete local pair, including its calibration rows.
full_model <- calibrated_workflow(base, schema$encoded_outcome, schema = schema,
model_training = "pairwise", method = "cross", prediction_model = "full",
splits = pair_plan, seed = 42)
full_fit <- generics::fit(full_model, development)
full_state <- workflows::extract_fit_engine(full_fit)
for (id in names(state$pair_models)) stopifnot(
identical(state$pair_models[[id]]$calibration, full_state$pair_models[[id]]$calibration),
identical(state$pair_models[[id]]$calibrator, full_state$pair_models[[id]]$calibrator),
identical(names(full_state$pair_models[[id]]$models), "Full1"))
full_native <- venn_abers_details(full_fit, assessment)
full_decoded <- venn_abers_decode(full_native, schema)
print(head(full_decoded$details))
for (mode in c("matched", "full")) {
probability <- if (mode == "full") full_decoded$probability else decoded$probability
truth <- venn_abers_decode(assessment[schema$encoded_outcome], schema)$truth
cat(mode, "Brier:", brier_score(truth, probability),
"log loss:", log_loss(truth, probability), "\n")
}
# Fifteen base fits (3 + 4 + 5 sources, three Full1); only the Full1 workflows
# remain, each predicting once per nonempty batch. The printed slot map sends
# every held-out calibrator to its pair's Full1.
print(full_state)
# Each pair source is named pair_N/Full1; pair_id + fold identifies its
# calibrator. Source workflows are discarded after all full fits succeed.
# No in-sample recalibration or pooling occurs. Outer assessment stays excluded.
# Matching-model guarantees do not automatically transfer to the new model;
# neither coverage nor improved quality is promised. Settings are fixed here;
# pairwise-grid.R and pairwise-bayes.R show automatic local selection.
}frozen-binary.R: Adopt a previously fitted recipe, model
and postprocessor unchanged; compare losses on separate validation
rows.
# A previously learned recipe, model and Tailor remain frozen. The user must
# keep new VA calibration data outside ALL earlier training/model selection.
# This adopts the existing workflow unchanged; calibrated_workflow() instead
# trains new base workflows on its own split.
packages <- c("workflows", "parsnip", "recipes", "tailor", "probably", "rsample",
"hardhat", "rlang", "tibble", "withr", "generics", "tidyselect", "yardstick")
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) local({
set.seed(613)
data <- data.frame(x = rnorm(450), z = rnorm(450))
data$truth <- factor(ifelse(runif(450) < plogis(data$x - .5 * data$z), "yes", "no"),
levels = c("yes", "no"))
data$x[c(2, 155, 255, 355)] <- NA_real_
training <- data[1:150, ]
earlier_postprocessing <- data[151:250, ]
calibration <- data[251:350, ]
validation <- data[351:400, ]
assessment <- data[401:450, ]
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ ., training) |>
recipes::step_impute_median(x) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::logistic_reg(engine = "glm")) |>
workflows::add_tailor(tailor::tailor() |>
tailor::adjust_probability_calibration(method = "logistic", smooth = FALSE))
# These fits happened earlier, on their own data.
frozen <- generics::fit(base, training, data_calibration = earlier_postprocessing)
# Only the VA calibrator learns now. No bake() and no subsequent fit().
calibrated <- vennabers::calibrate_workflow(frozen, calibration, "truth")
print(calibrated) # Base fits: 0; the adopted workflow is the only model
# Narrow Log/Brier choice on separate validation rows with existing predict()
# and yardstick calls. Nothing is refitted; pass the chosen rule explicitly.
# Validation rows are selection data, so assess on still other rows.
losses <- vapply(c(log = "log", brier = "brier"), function(loss) {
p <- predict(calibrated, validation[c("x", "z")], type = "prob", loss = loss)
yardstick::mn_log_loss_vec(validation$truth, p$.pred_yes)
}, numeric(1))
chosen <- names(losses)[which.min(losses)]
print(losses)
new_data <- assessment[c("x", "z")]
probability <- predict(calibrated, new_data, type = "prob", loss = chosen)
classes <- predict(calibrated, new_data, type = "class", loss = chosen)
details <- vennabers::venn_abers_details(calibrated, new_data, loss = chosen)
print(c(log_loss = vennabers::log_loss(assessment$truth == "yes", probability$.pred_yes),
brier = vennabers::brier_score(assessment$truth == "yes", probability$.pred_yes)))
stopifnot(identical(levels(classes$.pred_class), levels(training$truth)),
identical(details$prediction, probability),
identical(calibrated$models[[1L]], frozen), calibrated$loss == "log")
path <- tempfile(fileext = ".rds")
saveRDS(calibrated, path)
stopifnot(identical(probability, predict(readRDS(path), new_data, loss = chosen)))
unlink(path)
# Retain the required packages. Engines using external resources may need
# their own persistence procedure. RDS is not a universal portability promise.
})frozen-multiclass-regression.R: Separate earlier
training and postprocessing from new VA calibration and independent
assessment.
# Separate earlier model learning, earlier postprocessing, new VA calibration,
# and independent assessment. All calls use the complete learned workflow.
packages <- c("workflows", "parsnip", "recipes", "tailor", "probably", "nnet", "mgcv",
"rsample", "hardhat", "rlang", "tibble", "withr", "generics", "tidyselect")
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) local({
set.seed(614)
data <- data.frame(x = rnorm(400), z = rnorm(400))
data$truth <- factor(rep(c("third", "first", "second"), length.out = 400),
levels = c("third", "first", "second"))
training <- data[1:150, ]
earlier_postprocessing <- data[151:250, ]
calibration <- data[251:350, ]
assessment <- data[351:400, ]
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ ., training) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::multinom_reg(penalty = .1) |>
parsnip::set_engine("nnet", trace = FALSE)) |>
workflows::add_tailor(tailor::tailor() |>
tailor::adjust_probability_calibration(method = "multinomial", smooth = TRUE))
frozen <- generics::fit(base, training, data_calibration = earlier_postprocessing)
for (method in c("ovo", "ovr")) {
calibrated <- vennabers::calibrate_workflow(frozen, calibration, "truth", classification = method, precision = 2)
new <- assessment[c("x", "z")]
probability <- predict(calibrated, new)
classes <- predict(calibrated, new, type = "class")
details <- vennabers::venn_abers_details(calibrated, new, loss = "brier")
stopifnot(identical(levels(classes$.pred_class), levels(training$truth)),
identical(details$prediction, predict(calibrated, new, loss = "brier")),
identical(calibrated$models[[1L]], frozen))
print(head(probability))
}
# Numeric truth (including 0/1) stays regression because the workflow says so.
data$truth <- 2 + data$x + cos(1:400)
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(truth ~ ., data[1:150, ]) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(parsnip::linear_reg(engine = "lm")) |>
workflows::add_tailor(tailor::tailor() |>
tailor::adjust_numeric_calibration(method = "linear", smooth = FALSE))
frozen <- generics::fit(base, data[1:150, ], data_calibration = data[151:250, ])
calibrated <- vennabers::calibrate_workflow(frozen, data[251:350, ], "truth", epsilon = .1)
points <- predict(calibrated, data[351:400, ], type = "numeric")
details <- vennabers::venn_abers_details(calibrated, data[351:400, ])
stopifnot(identical(points, details$prediction), identical(calibrated$models[[1L]], frozen),
calibrated$parameters$effective$m == 5)
print(c(rmse = sqrt(mean((points$.pred - data$truth[351:400])^2))))
# details$details contains row, fold, prediction, lower and upper. These IVAR
# bounds describe regularized conditional expectations, not prediction intervals.
})frozen-schema.R: Encode new calibration and assessment
data using the schema retained before the original workflow
training.
# Keep the schema from BEFORE training. Later data are explicitly encoded with it.
source(system.file("examples", "assertions.R", package = "vennabers"))
# Separate earlier model/recipe learning, earlier postprocessing, new VA
# calibration, and independent assessment. Never rebuild a schema from calibration.
packages <- c("workflows", "parsnip", "recipes", "tailor", "probably", "nnet", "mgcv",
"rsample", "hardhat", "rlang", "tibble", "withr", "generics", "tidyselect")
if (all(vapply(packages, requireNamespace, logical(1), quietly = TRUE))) local({
set.seed(615)
for (method in c("binary", "ovo", "ovr", "regression")) {
original <- data.frame(x = rnorm(400), z = rnorm(400))
original$y <- if (method == "regression") 2 + original$x + cos(1:400) else {
classes <- if (method == "binary") c("class", "vaL0001") else c("class", "a b", "vaL0001")
factor(rep(classes, length.out = 400), levels = classes)
}
names(original) <- c("vaV0002", "a-b", ".pred_class")
schema <- if (method == "regression") vennabers::venn_abers_schema(original[1:150, ], ".pred_class") else
if (method == "binary") vennabers::venn_abers_schema(original[1:150, ], ".pred_class", event_level = "second") else
vennabers::venn_abers_schema(original[1:150, ], ".pred_class", classification = method)
training <- vennabers::venn_abers_encode(original[1:150, ], schema)
earlier_postprocessing <- vennabers::venn_abers_encode(original[151:250, ], schema)
spec <- if (method == "regression") parsnip::linear_reg(engine = "lm") else
if (method == "binary") parsnip::logistic_reg(engine = "glm") else
parsnip::multinom_reg(penalty = .1) |> parsnip::set_engine("nnet", trace = FALSE)
base <- workflows::workflow() |>
workflows::add_recipe(recipes::recipe(vaV0003 ~ ., training) |>
recipes::step_normalize(recipes::all_numeric_predictors())) |>
workflows::add_model(spec) |>
workflows::add_tailor(if (method == "regression") tailor::tailor() |>
tailor::adjust_numeric_calibration(method = "linear", smooth = FALSE) else tailor::tailor() |>
tailor::adjust_probability_calibration(method = if (method == "binary") "logistic" else "multinomial",
smooth = (method != "binary")))
earlier <- generics::fit(base, training, data_calibration = earlier_postprocessing)
# Store earlier and schema together if calibration will happen in a later session.
calibration <- vennabers::venn_abers_encode(original[251:350, ], schema)
calibrated <- vennabers::calibrate_workflow(earlier, calibration, schema$encoded_outcome, schema = schema)
new <- vennabers::venn_abers_encode(original[351:400, 1:2], schema)
native <- predict(calibrated, new)
decoded <- vennabers::venn_abers_decode(vennabers::venn_abers_details(calibrated, new), schema)
assert_conditions(identical(calibrated$models[[1L]], earlier), identical(calibrated$schema, schema),
decoded$outcome == ".pred_class", is.null(decoded$identity), is.null(decoded$aggregate))
if (method != "regression") {
decisions <- vennabers::venn_abers_decode(predict(calibrated, new, type = "class"), schema)
stopifnot(identical(colnames(decoded$probability), schema$class_levels),
identical(levels(decisions$class), schema$class_levels))
}
print(head(native))
}
# A workflow trained on original names continues to use those names, with
# schema = NULL. Retrofitting a schema cannot rename learned state or repair
# an old full-predict failure. Errors preserve names, stage and cause; there
# is no automatic raw-response/engine fallback that bypasses postprocessing.
# Retained bindings and learned metadata are checked, but detached matching
# codes cannot prove provenance: callers must supply the actual training schema.
})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.