Example scripts: training and frozen workflows

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.

Choose an example

• Training binary and shared multiclass workflows
• Encoding binary names
• Encoding multiclass and regression names
• Reference-style data roles
• Independent Inductive training and calibration sizes
• Own fit and predict functions
• Fixed engine options and internal validation
• Binary full-model transfer
• Shared multiclass full-model transfer
• Regression full-model transfer
• Pairwise Inductive OvO training
• Pairwise Cross OvO training
• Calibrating a frozen binary workflow
• Calibrating frozen multiclass and regression workflows
• Keeping the original schema for frozen adoption

Running an example

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.

Training binary and shared multiclass workflows

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)))
  }
})

Encoding binary names

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))))
}

Encoding multiclass and regression names

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-style data roles

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.
}

Independent Inductive training and calibration sizes

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.
}

Own fit and predict functions

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)
  }
}

Fixed engine options and internal validation

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)
  }
}

Binary full-model transfer

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.
})

Shared multiclass full-model transfer

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.
}

Regression full-model transfer

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 OvO training

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 OvO training

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.
}

Calibrating a frozen binary workflow

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.
})

Calibrating frozen multiclass and regression workflows

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.
})

Keeping the original schema for frozen adoption

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.
})