Executive Summary
Where to set the cutoff on Churn Probability, and what each candidate assumes about your costs
The short answer
Set the cutoff at 0.4009 if a missed churner costs 1.50 to 2.00 times a false alarm. At that point you catch 70.2% of actual churners (915 of 1,304) while flagging 1,430 rows total, with 64.0% precision—meaning 515 false alarms. If your cost ratio differs, the metric curves show where every other cutoff lands.
The detail
Across 4,000 rows with 32.6% churners, maximum F1 peaks at 0.4009 on Churn Probability, yielding precision of 0.64, recall of 0.702, and F1 of 0.669 in-sample. The optimism-corrected F1 over 200 bootstrap resamples is 0.664, accounting for the flattery of choosing the cutoff on the same data it scores. The competing criteria are Youden's J at 0.3583 and the default 0.50; all three disagree. At 0.4009, you miss 389 churners and raise 515 false alarms. The maximum-F1 choice implicitly assumes a cost ratio between 1.50 and 2.00. Across bootstrap resamples the chosen cutoff ranged from 0.2695 to 0.4163, showing sensitivity to sample variation.
What this can't tell you
No cutoff is chosen without your costs. If your false-negative cost differs materially from 1.50–2.00 times your false-positive cost, the optimal cutoff is elsewhere on the metric curves.
Analysis Overview
Where to set the cutoff on Churn Probability when deciding 'Yes' versus 'No', across 4,000 rows.
The short answer
Cutoff selection is fundamentally a business decision, not a statistical one. Every cutoff trades misses against false alarms; these 3,990 candidate thresholds on Churn Probability span 0.3026 to 0.6875, and the criteria disagree sharply on where to land. Without your cost figures, no single cutoff is the right answer—you must pick the one whose implied cost ratio matches what you actually believe.
The detail
The analysis sweeps all 3,990 distinct cutoffs present in the 4,000-row dataset, recording confusion counts and resulting precision, recall, F1, and specificity at each. Because the criteria disagree on cost assumptions—maximum F1 lands at 0.4009, Youden's J at 0.3583, and precision ≥80% at 0.6875—the report states the cost ratio each cutoff implicitly assumes. The companion ROC analysis answers the threshold-free question of how well Churn Probability ranks 'Yes' rows above 'No' rows; this report takes that ranking as given and asks only where to draw the line.
What this can't tell you
The report cannot tell you which cutoff is correct without knowing your costs. The decision requires knowledge of what a missed churn ('Yes') costs relative to a false alarm ('No'), which only you can supply.
Data Quality
Positive-class definition, dropped rows, class balance, and the score's scale.
The short answer
All 4,000 rows are usable with no missing outcome or score. The data is reasonably balanced at 32.6% 'Yes' and 67.4% 'No', so accuracy is meaningful but must clear the majority-class baseline of 67.4%. Churn Probability ranges from 0.0015 to 0.9961 on a true 0–1 probability scale, making the default 0.50 cutoff interpretable.
The detail
4,000 rows loaded; 0 rows removed. 'Yes' was treated as the positive class with 1,304 positive rows (32.6%) and 2,696 negative rows. Churn Probability is continuous, ranging from 0.0015 to 0.9961, and every value lies between 0 and 1, so it can be read as a probability and compared directly against the default 0.50 cutoff. The classes are reasonably balanced; even so, the majority-class baseline of 67.4% is the bar any accuracy figure must clear.
What this can't tell you
The analysis does not assess whether Churn Probability itself is well-calibrated—whether a row with a score of 0.50 truly has a 50% chance of churning. Calibration is a separate diagnostic.
Metric Curves by Cutoff
Precision, recall, F1 and specificity at every candidate cutoff on Churn Probability.
The short answer
Precision rises as the cutoff tightens (moving right), while recall falls—a strict tradeoff by design. F1 peaks at 0.4009 with a value of 0.669, and Youden's J peaks at 0.3583. Precision and recall cross at 0.4371, both near 65.2%. The curves are steep around the maximum-F1 cutoff, so small changes in the threshold move each metric noticeably.
The detail
Each curve traces one metric across all 3,990 candidate cutoffs on Churn Probability. Reading left to right, the cutoff gets stricter: recall and specificity move in opposite directions by construction, and precision generally rises as the flag list shrinks. F1 peaks at 0.4009 (F1 = 0.669), while Youden's J peaks at 0.3583. Precision and recall cross at a cutoff of 0.4371, where both sit near 65.2%. The vertical marker at 0.4009 shows the maximum-F1 cutoff for reference; the second marker at 0.50 is the default. The steepness of the curves around any chosen cutoff tells you how much a small change in the threshold would move each metric.
What this can't tell you
The curves show no causal relationship between cutoff and metric—they are definitional tradeoffs. The curves do not reveal whether the underlying score is well-calibrated or whether the ranking itself is strong; the companion ROC analysis answers that prior question.
Criteria Side by Side
Where each named criterion puts the cutoff, and the cost ratio each one implicitly assumes.
| Criterion | Threshold | Precision | Recall | F1 | Specificity | Expected Cost | Implied Cost Ratio | Note |
|---|---|---|---|---|---|---|---|---|
| Default cutoff (0.50) | 0.5001 | 69.6% | 58.0% | 0.633 | 87.8% | n/a | no cost ratio makes this cutoff cheapest | The out-of-the-box cutoff, shown only because the score already lies between 0 and 1. |
| Maximum F1 | 0.4009 | 64.0% | 70.2% | 0.669 | 80.9% | n/a | 1.50 to 2.00 | Balances precision against recall with no reference to what either error costs you. |
| Youden's J | 0.3583 | 60.7% | 74.4% | 0.669 | 76.7% | n/a | 2.05 to 2.21 | Maximises sensitivity plus specificity, which weights a missed positive and a false alarm equally. |
| Meets precision >= 80.0% | 0.6875 | 80.4% | 35.2% | 0.490 | 95.8% | n/a | no cost ratio makes this cutoff cheapest | Catches as many positives as possible while keeping precision at or above 80.0% (default). |
| Meets recall >= 80.0% | 0.3026 | 56.7% | 80.1% | 0.664 | 70.4% | n/a | no cost ratio makes this cutoff cheapest | Keeps the flag list as clean as possible while catching at least 80.0% of positives (default). |
The short answer
The five named criteria span 0.3849 on the Churn Probability scale (from 0.3026 to 0.6875) and disagree sharply on cost assumptions. Maximum F1 at 0.4009 assumes a missed churn costs 1.50 to 2.00 times a false alarm; Youden's J at 0.3583 assumes 2.05 to 2.21 times. Without supplied costs, pick the row whose implied cost ratio matches what you actually believe.
The detail
The criteria do not agree. Default cutoff (0.5001) delivers 69.6% precision and 58.0% recall with F1 of 0.633, but no cost ratio makes it cheapest. Maximum F1 at 0.4009 delivers 64.0% precision, 70.2% recall, and F1 of 0.669, assuming a cost ratio of 1.50 to 2.00. Youden's J at 0.3583 delivers 60.7% precision, 74.4% recall, and F1 of 0.669, assuming 2.05 to 2.21. Meets precision ≥80.0% at 0.6875 delivers 80.4% precision but only 35.2% recall and F1 of 0.490. Meets recall ≥80.0% at 0.3026 delivers 56.7% precision, 80.1% recall, and F1 of 0.664, but no cost ratio makes it cheapest. The honest recommendation is to pick the row whose implied cost ratio matches what you believe, or supply the two costs and let the arithmetic pick it.
What this can't tell you
The table does not tell you which cost ratio is correct—only you know what a missed churn actually costs your business relative to a false alarm.
Confusion Matrix at the Chosen Cutoff
Every count and rate at the maximum f1 cutoff of 0.4009.
| Metric | Value | Interpretation |
|---|---|---|
| Cutoff on Churn Probability | 0.4009 | Flag a row when Churn Probability is at or above this value. |
| True positives (flagged and really 'Yes') | 915 | Caught positives — the wins this cutoff buys. |
| False positives (flagged but really 'No') | 515 | False alarms — the cost this cutoff incurs. |
| True negatives (cleared and really 'No') | 2,181 | Correctly cleared 'No' rows. |
| False negatives (cleared but really 'Yes') | 389 | Missed positives — what slips through at this cutoff. |
| Precision (PPV) | 64.0% | Of the rows flagged, the share that really are 'Yes'. |
| Recall (sensitivity) | 70.2% | Of the real 'Yes' rows, the share caught. |
| Specificity | 80.9% | Of the real 'No' rows, the share correctly cleared. |
| F1 score | 0.669 | Harmonic mean of precision and recall. |
| Accuracy | 77.4% | Share of all rows classified correctly at this cutoff. |
| Majority-class baseline accuracy | 67.4% | What you would score by always predicting 'No' and never looking at the score — the bar accuracy has to clear before it means anything. |
| Rows flagged positive | 1,430 of 4,000 | How much work this cutoff creates. |
The short answer
At the maximum-F1 cutoff of 0.4009, you flag 1,430 of 4,000 rows. Of those, 915 are real churners (64.0% precision) and 515 are false alarms; you miss 389 churners (70.2% recall). Compared to the default 0.50 cutoff, this catches 159 more positives but raises 185 more false alarms.
The detail
At 0.4009 on Churn Probability: 915 true positives, 515 false positives, 2,181 true negatives, 389 false negatives. Precision is 64.0% (of 1,430 flagged rows, 915 are really 'Yes'). Recall is 70.2% (of 1,304 real 'Yes' rows, 915 are caught). Specificity is 80.9% (of 2,696 real 'No' rows, 2,181 are correctly cleared). F1 is 0.669. Accuracy is 77.4% against a majority-class baseline of 67.4%, a gain of 10.0 percentage points. Against the default 0.50 cutoff, this cutoff catches 159 more positives and raises 185 more false alarms, creating 1,430 rows of work instead of 1,271.
What this can't tell you
Accuracy alone does not tell you whether this cutoff is right for your business—that depends on what your false alarms and missed churners actually cost. The majority-class baseline of 67.4% is the floor accuracy must clear before it means anything.
In-Sample Optimism, Stability & Balance
What the reported performance at the chosen cutoff does and does not entitle you to claim.
| Check | Value | Interpretation |
|---|---|---|
| Bootstrap resamples used | 200 | Efron optimism bootstrap, implemented directly in base R: each resample picks its own max-F1 cutoff, which is then scored on the original data. |
| F1 at the max-F1 cutoff (in-sample) | 0.669 | The figure you get by choosing and scoring the cutoff on the same rows. It is optimistic. |
| Optimism (bootstrap estimate) | 0.0056 | How much of that F1 is an artefact of choosing the cutoff on this very data. |
| F1 corrected for optimism | 0.664 | The honest expectation for the same cutoff rule applied to fresh rows. |
| Cutoff 95% bootstrap interval | 0.2695 to 0.4163 | Where the max-F1 cutoff landed across resamples. A wide interval means the cutoff itself is not well determined by this much data. |
| Positive-class share | 32.6% | 1,304 'Yes' rows against 2,696 'No' rows. |
| Majority-class baseline accuracy | 67.4% | Accuracy is only informative to the extent it beats this number. |
The short answer
The reported F1 of 0.669 is optimistic because the cutoff was chosen and scored on the same 4,000 rows. A bootstrap optimism correction estimates the flattery at 0.0056, putting the honest expectation on fresh data at 0.664. Across resamples the cutoff ranged from 0.2695 to 0.4163, a narrow span that suggests the cutoff is reasonably well determined.
The detail
Over 200 bootstrap resamples, each picking its own maximum-F1 cutoff and then scored on the original rows, the average optimism is 0.0056 in F1. The in-sample F1 of 0.669 therefore corresponds to an honest expectation of about 0.664 on fresh rows. Across resamples the chosen cutoff ranged from 0.2695 to 0.4163, a span of 0.1468 on the Churn Probability scale—0.38 times the distance between the criteria themselves. That is narrow, so the cutoff is reasonably well determined by 4,000 rows. The positive-class share is 32.6% (1,304 'Yes' against 2,696 'No'), and the majority-class baseline accuracy is 67.4%.
What this can't tell you
This analysis cannot remove in-sample optimism entirely. The one clean way to eliminate it is to choose the cutoff on one set of rows and measure it on rows the search never saw.
Methodology
Statistical methodology and diagnostics for Classification Threshold Optimizer
Statistical Method
Standard-library analysis: where should the cutoff go on your model score, given what YOUR errors actually cost? Map the true yes/no outcome and a predicted probability or score, and every candidate cutoff is swept — precision, recall, F1, specificity, accuracy and expected cost at each. The report gives the optimum under several named criteria (maximum F1, Youden's J, minimum expected cost from your own cost of a false positive and a false negative, and the cutoff that meets a target precision or recall), the metric-versus-threshold curves as the headline chart, and — for every cutoff — the cost ratio it implicitly assumes. If no costs are supplied, the criteria are shown side by side rather than one being picked for you.
- Higher score means more likely to be in the positive class
- The true outcome is genuinely binary (two classes)
- The rows scored here are representative of the rows the cutoff will be applied to
- Supplied costs are per-error and on a common scale (the analysis uses only their ratio for the implied-ratio column)
- A cutoff chosen on a dataset and evaluated on that same dataset is optimistic; the report measures that optimism with a bootstrap correction but cannot eliminate it — only a genuine holdout can
- With a rare positive class, accuracy at any cutoff is misleading; the report reports it only against the majority-class baseline and never as the headline
- The bootstrap correction assumes the rows are independent; repeated measurements of the same subject violate that
- Without supplied costs the analysis deliberately does not recommend a single cutoff — it reports what each criterion implicitly assumes instead
Analysis Code
Complete R source code for this analysis
Classification Threshold Optimizer — Where Should the Cutoff Go?
Takes a predicted probability or score plus the true binary outcome and finds the cutoff that maximises the objective you actually care about — not the default 0.5, and not blindly Youden's J. Every candidate cutoff is swept, and the report gives the confusion matrix, precision, recall, F1, specificity and expected cost at each; the optimum under several named criteria (maximum F1, Youden's J, minimum expected cost given your own cost of a false positive and a false negative, and the cutoff that meets a target precision or recall); and the metric-versus-threshold curves as the headline chart.
Why This Method?
A cutoff is a business decision wearing a statistical costume. The score ranks rows; the cutoff turns that ranking into an action, and the right place to draw the line depends entirely on what a false alarm costs you relative to a miss. This module makes that trade-off explicit: it reports every criterion side by side and, for each one, the cost ratio it implicitly assumes — so the choice is yours and it is visible.
What This Analysis Covers
- Precision, recall, F1, specificity and accuracy at every candidate cutoff
- The optimum under max-F1, Youden's J, minimum expected cost, target
precision and target recall
- The cost ratio each cutoff implicitly assumes
- A bootstrap optimism correction, because a cutoff chosen on the same
data it is scored on flatters itself
- Explicit class-imbalance handling: accuracy is never the headline
Companion Tool
standard_roc_analysis (ROC Curve & Classifier Cutoff) answers the threshold-free question — how well the score ranks positives above negatives at all, summarised by AUC. This module answers the next question: given that ranking, where do you draw the line?
Standard Library
Platform standard-library module (LAT-1441): runs on ANY dataset via the semantic mapping {actual, score}. All narrative is derived from the user's own column names and computed values.
suppressPackageStartupMessages(library(DT))
suppressPackageStartupMessages(library(htmlwidgets))
suppressPackageStartupMessages(library(arrow))
suppressPackageStartupMessages(library(knitr))
suppressPackageStartupMessages(library(rmarkdown))
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(tidyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(stringr))
suppressPackageStartupMessages(library(lubridate))
suppressPackageStartupMessages(library(broom))
suppressPackageStartupMessages(library(Matrix))
suppressPackageStartupMessages(library(cluster))
suppressPackageStartupMessages(library(data.table))Step 1: Row accounting + semantic column discovery
initial_rows <- nrow(df)
if (!"actual" %in% names(df)) {
stop("column_mapping must map an 'actual' column (the true yes/no outcome).")
}
if (!"score" %in% names(df)) {
stop("column_mapping must map a 'score' column (the predicted probability or score).")
}
actual_name <- humanize_semantic("actual", col_map)
score_name <- humanize_semantic("score", col_map)Step 2: Choose the positive class + binarize the outcome
Deliberately identical to standard_roc_analysis so the two tools name the positive class the same way on the same data.
v_raw <- df$actual
if (is.logical(v_raw)) {
keep_a <- !is.na(v_raw)
df <- df[keep_a, , drop = FALSE]
y <- as.integer(df$actual)
positive_label <- "TRUE"
negative_label <- "FALSE"
positive_rule <- "the boolean TRUE value"
} else {
vc <- trimws(as.character(v_raw))
keep_a <- !is.na(v_raw) & !is.na(vc) & vc != ""
df <- df[keep_a, , drop = FALSE]
vc <- vc[keep_a]
lv <- sort(unique(vc))
if (length(lv) < 2) {
stop(sprintf(
"The outcome column('%s') has only one value ('%s') — choosing a cutoff needs both the positive and the negative class present.",
actual_name, if (length(lv) == 1) lv[1] else "empty"))
}
pat <- "^(1|yes|true|positive|pos|disease|churn|churned|fraud|default|defaulted|converted)$"
hits <- lv[grepl(pat, tolower(lv))]
if (length(hits) >= 1) {
positive_label <- hits[length(hits)]
positive_rule <- "it matched a conventional positive label"
} else {
positive_label <- lv[length(lv)]
positive_rule <- "no conventional positive label was found, so the alphabetically-last class was used"
}
neg_levels <- setdiff(lv, positive_label)
negative_label <- if (length(neg_levels) == 1) neg_levels[1]
else paste0("not ", positive_label)
if (length(lv) > 2) {
positive_rule <- paste0(positive_rule,
"; the outcome had more than two values, so this is a one-versus-rest evaluation")
}
y <- as.integer(vc == positive_label)
}Step 3: Coerce the score with the 95% numeric rule
sc_raw <- df$score
if (is.numeric(sc_raw)) {
sc <- sc_raw
} else {
chr <- trimws(as.character(sc_raw))
chr[is.na(chr)] <- ""
nonblank <- chr[chr != ""]
parsed <- suppressWarnings(as.numeric(nonblank))
keep_rate <- if (length(nonblank) > 0) mean(!is.na(parsed)) else 0
if (keep_rate < 0.95) {
stop(sprintf(
"The score column('%s') could not be read as numbers — only %s of its non-blank values parsed as a number, below the 95%% needed. Map a numeric score or probability column where a higher value means more likely '%s'.",
score_name, fpct(keep_rate), positive_label))
}
sc <- suppressWarnings(as.numeric(ifelse(chr == "", NA_character_, chr)))
}
keep_s <- !is.na(sc) & is.finite(sc) & !is.na(y)
sc <- sc[keep_s]
y <- y[keep_s]
final_rows <- length(y)
rows_removed <- initial_rows - final_rows
if (final_rows < 20) {
stop(sprintf(
"Only %d rows have both a usable outcome('%s') and a numeric score ('%s') — at least 20 are required to choose a cutoff.",
final_rows, actual_name, score_name))
}Step 4: Class guards — both classes, at least 10 of each
n1 <- sum(y == 1L)
n0 <- sum(y == 0L)
if (n1 < 10 || n0 < 10) {
stop(sprintf(
"Choosing a cutoff needs at least 10 of each class, but '%s' has %d '%s' and %d '%s' rows.",
actual_name, n1, positive_label, n0, negative_label))
}
sc_var <- suppressWarnings(var(sc))
if (is.na(sc_var) || sc_var == 0) {
stop(sprintf(
"The score column('%s') is constant — every row would fall on the same side of any cutoff, so there is no cutoff to choose.",
score_name))
}
prevalence <- n1 / final_rows
baseline_accuracy <- max(prevalence, 1 - prevalence)
imbalanced <- prevalence < 0.10 || prevalence > 0.90
score_min <- min(sc)
score_max <- max(sc)
score_is_prob <- score_min >= 0 && score_max <= 1Step 5: Read the cost and target parameters
cost_fp <- num_param(params, c("cost_fp", "cost_false_positive", "fp_cost"))
cost_fn <- num_param(params, c("cost_fn", "cost_false_negative", "fn_cost"))
benefit_tp <- num_param(params, c("benefit_tp", "value_true_positive", "tp_benefit"))
if (is.null(benefit_tp) || benefit_tp < 0) benefit_tp <- 0
have_costs <- !is.null(cost_fp) && !is.null(cost_fn) &&
cost_fp >= 0 && cost_fn >= 0 && (cost_fp + cost_fn + benefit_tp) > 0
if (!have_costs) { cost_fp <- NA_real_; cost_fn <- NA_real_ }
cost_fn_eff <- if (have_costs) cost_fn + benefit_tp else NA_real_
tp_in <- num_param(params, c("target_precision", "min_precision"))
tr_in <- num_param(params, c("target_recall", "min_recall", "target_sensitivity"))
target_precision <- if (!is.null(tp_in) && tp_in > 0 && tp_in <= 1) tp_in else 0.80
target_recall <- if (!is.null(tr_in) && tr_in > 0 && tr_in <= 1) tr_in else 0.80
tp_source <- if (!is.null(tp_in) && tp_in > 0 && tp_in <= 1) "your input" else "default"
tr_source <- if (!is.null(tr_in) && tr_in > 0 && tr_in <= 1) "your input" else "default"Step 6: Sweep every candidate cutoff (base R sort + cumulative sums)
Rule at a cutoff t: flag positive when the score is at or above t. The last index of each run of equal scores carries the counts for >= t.
o <- order(sc, decreasing = TRUE)
s_o <- sc[o]
y_o <- y[o]
ctp <- cumsum(y_o == 1L)
cfp <- cumsum(y_o == 0L)
run_end <- which(c(diff(s_o) != 0, TRUE))
thr <- s_o[run_end]
tp_v <- ctp[run_end]
fp_v <- cfp[run_end]
fn_v <- n1 - tp_v
tn_v <- n0 - fp_v
K <- length(thr)
precision_v <- tp_v / (tp_v + fp_v) # denominator is >= 1 by construction
recall_v <- tp_v / n1
spec_v <- tn_v / n0
f1_v <- ifelse((precision_v + recall_v) > 0,
2 * precision_v * recall_v / (precision_v + recall_v), 0)
acc_v <- (tp_v + tn_v) / final_rows
j_v <- recall_v + spec_v - 1
cost_v <- if (have_costs)
(fp_v * cost_fp + fn_v * cost_fn_eff) / final_rows
else rep(NA_real_, K)
cost_none <- if (have_costs) (n1 * cost_fn_eff) / final_rows else NA_real_Step 7: The cost ratio each cutoff implicitly assumes
Cutoff k minimises cost_fp FP + cost_fn FN for every ratio R = cost_fn / cost_fp inside [R_lo, R_hi]; outside it another cutoff is cheaper. When R_lo exceeds R_hi the cutoff is optimal for no ratio at all.
FNj <- c(fn_v, n1) # every sweep point plus the "flag nobody" endpoint
FPj <- c(fp_v, 0)
implied_ratio <- function(k) {
if (is.na(k)) return(c(NA_real_, NA_real_))
FNk <- fn_v[k]; FPk <- fp_v[k]
up <- FNj < FNk
dn <- FNj > FNk
r_hi <- if (any(up)) min((FPj[up] - FPk) / (FNk - FNj[up])) else Inf
r_lo <- if (any(dn)) max((FPk - FPj[dn]) / (FNj[dn] - FNk)) else 0
c(r_lo, r_hi)
}Step 8: Locate each named criterion
NA-filter before every which.max/which.min (LAT-1445 crash class).
safe_max <- function(v) { v[is.na(v)] <- -Inf; if (all(!is.finite(v))) NA_integer_ else which.max(v) }
safe_min <- function(v) { v[is.na(v)] <- Inf; if (all(!is.finite(v))) NA_integer_ else which.min(v) }
k_f1 <- safe_max(f1_v)
k_youden <- safe_max(j_v)
k_cost <- if (have_costs) safe_min(cost_v) else NA_integer_
k_half <- if (score_is_prob && any(thr >= 0.5)) max(which(thr >= 0.5)) else NA_integer_Target precision: among cutoffs that clear it, take the one catching the most positives. Target recall: among cutoffs that clear it, take the one with the cleanest flag list.
ok_p <- which(!is.na(precision_v) & precision_v >= target_precision)
k_tp <- if (length(ok_p) > 0) ok_p[safe_max(recall_v[ok_p])] else NA_integer_
ok_r <- which(!is.na(recall_v) & recall_v >= target_recall)
k_tr <- if (length(ok_r) > 0) ok_r[safe_max(precision_v[ok_r])] else NA_integer_Step 9: Bootstrap optimism correction (implemented directly)
A cutoff chosen on a sample and scored on that same sample is flattered. Efron's optimism bootstrap measures the flattery: on each resample pick the cutoff by the SAME rule, score it on the resample (apparent) and on the original data (test); the mean gap is the optimism, and the corrected figure is the apparent figure minus that gap.
B <- 200
set.seed(42)
boot_thr <- rep(NA_real_, B)
boot_of1 <- rep(NA_real_, B)
boot_ocst <- rep(NA_real_, B)
for (b in seq_len(B)) {
ix <- sample.int(final_rows, final_rows, replace = TRUE)
y_b <- y[ix]; s_b <- sc[ix]
n1b <- sum(y_b == 1L)
if (n1b < 1L || n1b >= final_rows) next
ob <- order(s_b, decreasing = TRUE)
sbo <- s_b[ob]; ybo <- y_b[ob]
c1 <- cumsum(ybo == 1L); c0 <- cumsum(ybo == 0L)
reb <- which(c(diff(sbo) != 0, TRUE))
tb <- sbo[reb]; tpb <- c1[reb]; fpb <- c0[reb]
fnb <- n1b - tpb
prb <- tpb / (tpb + fpb)
rcb <- tpb / n1b
f1b <- ifelse((prb + rcb) > 0, 2 * prb * rcb / (prb + rcb), 0)
kb <- safe_max(f1b)
if (is.na(kb)) nextEvery bootstrap cutoff is an observed score, so it is always present in the full sweep — match() gives the full-sample counts at that cutoff.
kk <- match(tb[kb], thr)
if (is.na(kk)) next
boot_thr[b] <- tb[kb]
boot_of1[b] <- f1b[kb] - f1_v[kk]
if (have_costs) {
cstb <- (fpb * cost_fp + fnb * cost_fn_eff) / final_rows
kc <- safe_min(cstb)
if (!is.na(kc)) {
kkc <- match(tb[kc], thr)
if (!is.na(kkc)) boot_ocst[b] <- cstb[kc] - cost_v[kkc]
}
}
}
boot_b <- sum(!is.na(boot_of1))
optimism_f1 <- if (boot_b > 0) mean(boot_of1, na.rm = TRUE) else NA_real_
f1_apparent <- if (!is.na(k_f1)) f1_v[k_f1] else NA_real_
f1_corrected <- if (!is.na(optimism_f1) && !is.na(f1_apparent))
max(0, min(1, f1_apparent - optimism_f1)) else NA_real_
thr_q <- if (boot_b > 1)
as.numeric(quantile(boot_thr, c(0.025, 0.975), na.rm = TRUE, names = FALSE))
else c(NA_real_, NA_real_)
thr_ci_low <- thr_q[1]; thr_ci_high <- thr_q[2]
optimism_cost <- if (have_costs && sum(!is.na(boot_ocst)) > 0)
mean(boot_ocst, na.rm = TRUE) else NA_real_
cost_apparent <- if (have_costs && !is.na(k_cost)) cost_v[k_cost] else NA_real_
cost_corrected <- if (!is.na(optimism_cost) && !is.na(cost_apparent))
cost_apparent - optimism_cost else NA_real_Step 10: Assemble the criterion rows
crit_row <- function(key, label, k, note) {
r <- implied_ratio(k)
list(key = key, label = label, k = k, note = note,
threshold = if (is.na(k)) NA_real_ else thr[k],
precision = if (is.na(k)) NA_real_ else precision_v[k],
recall = if (is.na(k)) NA_real_ else recall_v[k],
f1 = if (is.na(k)) NA_real_ else f1_v[k],
specificity = if (is.na(k)) NA_real_ else spec_v[k],
accuracy = if (is.na(k)) NA_real_ else acc_v[k],
cost = if (is.na(k) || !have_costs) NA_real_ else cost_v[k],
tp = if (is.na(k)) NA_integer_ else tp_v[k],
fp = if (is.na(k)) NA_integer_ else fp_v[k],
tn = if (is.na(k)) NA_integer_ else tn_v[k],
fn = if (is.na(k)) NA_integer_ else fn_v[k],
ratio_lo = r[1], ratio_hi = r[2])
}
crit <- list()
if (!is.na(k_half)) {
crit$default_half <- crit_row(
"default_half", "Default cutoff(0.50)", k_half,
"The out-of-the-box cutoff, shown only because the score already lies between 0 and 1.")
}
crit$max_f1 <- crit_row(
"max_f1", "Maximum F1", k_f1,
"Balances precision against recall with no reference to what either error costs you.")
crit$youden <- crit_row(
"youden", "Youden's J", k_youden,
"Maximises sensitivity plus specificity, which weights a missed positive and a false alarm equally.")
if (have_costs) {
crit$min_cost <- crit_row(
"min_cost", "Minimum expected cost", k_cost,
sprintf("Uses the costs you supplied: %s per false positive, %s per false negative%s.",
fnum(cost_fp, 2), fnum(cost_fn, 2),
if (benefit_tp > 0) paste0(", plus ", fnum(benefit_tp, 2),
" of value per positive caught") else ""))
}
crit$target_precision <- crit_row(
"target_precision",
sprintf("Meets precision >= %s", fpct(target_precision)), k_tp,
sprintf("Catches as many positives as possible while keeping precision at or above %s(%s).",
fpct(target_precision), tp_source))
crit$target_recall <- crit_row(
"target_recall",
sprintf("Meets recall >= %s", fpct(target_recall)), k_tr,
sprintf("Keeps the flag list as clean as possible while catching at least %s of positives(%s).",
fpct(target_recall), tr_source))Step 11: Which cutoff does the report lead with?
Only the costs the user supplied earn the right to pick one. Absent them the report refuses to choose and shows the criteria side by side.
picked_for_user <- have_costs && !is.na(k_cost)
headline_key <- if (picked_for_user) "min_cost" else "max_f1"
hl <- crit[[headline_key]]
if (is.na(hl$k)) hl <- crit$max_f1
headline_label <- hl$label
headline_thr <- hl$threshold
headline_k <- hl$kCalibration check: for a perfectly calibrated probability the cost-optimal cutoff is exactly cost_fp / (cost_fp + cost_fn). Comparing it against the empirical minimum is a free calibration diagnostic.
calib_cutoff <- if (have_costs && (cost_fp + cost_fn_eff) > 0)
cost_fp / (cost_fp + cost_fn_eff) else NA_real_
calib_gap <- if (!is.na(calib_cutoff) && !is.na(k_cost) && score_is_prob)
abs(thr[k_cost] - calib_cutoff) else NA_real_Step 12: The metric-versus-threshold curves (the headline chart)
key_idx <- unique(stats::na.omit(vapply(crit, function(x) as.integer(x$k), integer(1))))
sel <- if (K <= 300) seq_len(K) else
sort(unique(c(1L, K, key_idx,
as.integer(round(seq(1, K, length.out = 300L))))))
mk <- function(lab, v) data.frame(
threshold = round(thr[sel], 5),
metric = lab,
metric_value = round(v[sel], 4),
stringsAsFactors = FALSE)
metric_curves_df <- rbind(
mk("Precision(PPV)", precision_v),
mk("Recall(sensitivity)", recall_v),
mk("F1 score", f1_v),
mk("Specificity", spec_v))
metric_curves_df <- metric_curves_df[order(metric_curves_df$metric,
metric_curves_df$threshold), ]
rownames(metric_curves_df) <- NULLStep 13: Criteria comparison table (fixed-notation strings only)
ratio_text <- function(x) {
if (is.na(x$ratio_lo) || is.na(x$ratio_hi)) return("n/a")
if (x$ratio_lo > x$ratio_hi + 1e-12) return("no cost ratio makes this cutoff cheapest")
paste0(fratio(x$ratio_lo), " to ", fratio(x$ratio_hi))
}
criteria_df <- do.call(rbind, lapply(crit, function(x) data.frame(
criterion = x$label,
threshold = if (is.na(x$threshold)) "not reachable" else fnum(x$threshold, 4),
precision = fpct(x$precision),
recall = fpct(x$recall),
f1 = fnum(x$f1, 3),
specificity = fpct(x$specificity),
expected_cost = if (have_costs) fnum(x$cost, 4) else "n/a",
implied_cost_ratio = ratio_text(x),
note = x$note,
stringsAsFactors = FALSE)))
rownames(criteria_df) <- NULLStep 14: Confusion + operating metrics at the leading cutoff
cmp_half <- if (!is.null(crit$default_half) && !is.na(crit$default_half$k))
crit$default_half else NULL
confusion_df <- data.frame(
metric = c(paste0("Cutoff on ", score_name),
paste0("True positives(flagged and really '", positive_label, "')"),
paste0("False positives(flagged but really '", negative_label, "')"),
paste0("True negatives(cleared and really '", negative_label, "')"),
paste0("False negatives(cleared but really '", positive_label, "')"),
"Precision(PPV)", "Recall(sensitivity)", "Specificity", "F1 score",
"Accuracy", "Majority-class baseline accuracy",
"Rows flagged positive"),
value = c(fnum(hl$threshold, 4),
fcount(hl$tp), fcount(hl$fp), fcount(hl$tn), fcount(hl$fn),
fpct(hl$precision), fpct(hl$recall), fpct(hl$specificity),
fnum(hl$f1, 3), fpct(hl$accuracy), fpct(baseline_accuracy),
paste0(fcount(hl$tp + hl$fp), " of ", fcount(final_rows))),
interpretation = c(
paste0("Flag a row when ", score_name, " is at or above this value."),
paste0("Caught positives — the wins this cutoff buys."),
paste0("False alarms — the cost this cutoff incurs."),
paste0("Correctly cleared '", negative_label, "' rows."),
paste0("Missed positives — what slips through at this cutoff."),
paste0("Of the rows flagged, the share that really are '", positive_label, "'."),
paste0("Of the real '", positive_label, "' rows, the share caught."),
paste0("Of the real '", negative_label, "' rows, the share correctly cleared."),
"Harmonic mean of precision and recall.",
"Share of all rows classified correctly at this cutoff.",
paste0("What you would score by always predicting '",
if (prevalence >= 0.5) positive_label else negative_label,
"' and never looking at the score — the bar accuracy has to clear before it means anything."),
"How much work this cutoff creates."),
stringsAsFactors = FALSE)Step 15: Honesty table — optimism, stability, imbalance, calibration
honesty_rows <- list(
c("Bootstrap resamples used", fcount(boot_b),
"Efron optimism bootstrap, implemented directly in base R: each resample picks its own max-F1 cutoff, which is then scored on the original data."),
c("F1 at the max-F1 cutoff(in-sample)", fnum(f1_apparent, 3),
"The figure you get by choosing and scoring the cutoff on the same rows. It is optimistic."),
c("Optimism(bootstrap estimate)", fnum(optimism_f1, 4),
"How much of that F1 is an artefact of choosing the cutoff on this very data."),
c("F1 corrected for optimism", fnum(f1_corrected, 3),
"The honest expectation for the same cutoff rule applied to fresh rows."),
c("Cutoff 95% bootstrap interval",
if (is.na(thr_ci_low)) "n/a" else paste0(fnum(thr_ci_low, 4), " to ", fnum(thr_ci_high, 4)),
"Where the max-F1 cutoff landed across resamples. A wide interval means the cutoff itself is not well determined by this much data."),
c("Positive-class share", fpct(prevalence),
paste0(fcount(n1), " '", positive_label, "' rows against ", fcount(n0), " '",
negative_label, "' rows.")),
c("Majority-class baseline accuracy", fpct(baseline_accuracy),
if (imbalanced)
"One class dominates, so accuracy is a misleading headline here and this report does not lead with it — precision, recall and expected cost carry the meaning."
else
"Accuracy is only informative to the extent it beats this number.")
)
if (have_costs) {
honesty_rows <- c(honesty_rows, list(
c("Expected cost per row(in-sample)", fnum(cost_apparent, 4),
"Cost at the minimum-cost cutoff, chosen and scored on the same rows."),
c("Expected cost corrected for optimism", fnum(cost_corrected, 4),
"The honest expectation on fresh rows — always at or above the in-sample figure."),
c("Cost of flagging nobody", fnum(cost_none, 4),
"The do-nothing baseline: every positive is missed and no false alarm is raised.")))
if (!is.na(calib_cutoff)) {
honesty_rows <- c(honesty_rows, list(
c("Calibration-implied cutoff", fnum(calib_cutoff, 4),
if (score_is_prob)
paste0("If ", score_name,
" were a perfectly calibrated probability, the cost-minimising cutoff would sit exactly here; the empirical minimum sits at ",
fnum(thr[k_cost], 4),
if (!is.na(calib_gap) && calib_gap > 0.05)
" — the gap is a sign the score is not well calibrated."
else " — the two agree closely.")
else
paste0("This is the break-even probability implied by your costs. ", score_name,
" is not on a 0-to-1 scale, so it cannot be compared against it directly."))))
}
}
honesty_df <- data.frame(
check = vapply(honesty_rows, function(r) r[1], character(1)),
value = vapply(honesty_rows, function(r) r[2], character(1)),
interpretation = vapply(honesty_rows, function(r) r[3], character(1)),
stringsAsFactors = FALSE)Step 16: KPI metrics + machine channels
metrics <- list(
`Observations` = final_rows,
`Positive Rate` = round(prevalence, 4),
`Chosen Criterion` = headline_label,
`Chosen Cutoff` = round(headline_thr, 4),
`Precision at Cutoff` = round(hl$precision, 3),
`Recall at Cutoff` = round(hl$recall, 3),
`F1(optimism-corrected)` = round(f1_corrected, 3)
)Accuracy is a KPI only when the classes are balanced enough for it to mean something; with a rare positive class it is replaced by the balance itself so nothing headlines a number the base rate already guarantees.
if (imbalanced) {
metrics$`Class Balance` <- paste0("rare positives(", fpct(prevalence), ")")
} else {
metrics$`Accuracy at Cutoff` <- round(hl$accuracy, 3)
}
threshold_summary <- list(
n = final_rows, n1 = n1, n0 = n0, prevalence = prevalence,
imbalanced = imbalanced, baseline_accuracy = baseline_accuracy,
score_is_prob = score_is_prob,
positive_label = positive_label, negative_label = negative_label,
have_costs = have_costs, cost_fp = cost_fp, cost_fn = cost_fn,
benefit_tp = benefit_tp, cost_fn_eff = cost_fn_eff, cost_none = cost_none,
calib_cutoff = calib_cutoff,
target_precision = target_precision, target_recall = target_recall,
picked_for_user = picked_for_user,
headline_key = if (picked_for_user) "min_cost" else "max_f1",
headline_threshold = headline_thr,
headline_precision = hl$precision, headline_recall = hl$recall,
headline_f1 = hl$f1, headline_accuracy = hl$accuracy,
tp = hl$tp, fp = hl$fp, tn = hl$tn, fn = hl$fn,
thr_max_f1 = if (is.na(k_f1)) NA_real_ else thr[k_f1],
f1_max = f1_apparent,
thr_youden = if (is.na(k_youden)) NA_real_ else thr[k_youden],
youden_j = if (is.na(k_youden)) NA_real_ else j_v[k_youden],
thr_min_cost = if (is.na(k_cost)) NA_real_ else thr[k_cost],
cost_min = cost_apparent,
thr_default_half = if (is.na(k_half)) NA_real_ else thr[k_half],
cost_at_half = if (!is.na(k_half) && have_costs) cost_v[k_half] else NA_real_,
thr_target_precision = if (is.na(k_tp)) NA_real_ else thr[k_tp],
thr_target_recall = if (is.na(k_tr)) NA_real_ else thr[k_tr],
precision_at_target_precision = if (is.na(k_tp)) NA_real_ else precision_v[k_tp],
recall_at_target_recall = if (is.na(k_tr)) NA_real_ else recall_v[k_tr],
ratio_lo = crit[[if (have_costs) "min_cost" else "max_f1"]]$ratio_lo,
ratio_hi = crit[[if (have_costs) "min_cost" else "max_f1"]]$ratio_hi,
f1_ratio_lo = crit$max_f1$ratio_lo, f1_ratio_hi = crit$max_f1$ratio_hi,
optimism_f1 = optimism_f1, f1_corrected = f1_corrected,
optimism_cost = optimism_cost, cost_corrected = cost_corrected,
thr_ci_low = thr_ci_low, thr_ci_high = thr_ci_high, boot_b = boot_b,
n_thresholds = K
)Step 17: The one-paragraph computed answer
choice_clause <- if (picked_for_user) {
paste0(
"Using the costs supplied(", fnum(cost_fp, 2), " per false positive, ",
fnum(cost_fn, 2), " per false negative), expected cost is lowest at a cutoff of ",
fnum(headline_thr, 4), " on ", score_name, ", at ", fnum(cost_apparent, 4),
" per row",
if (!is.null(cmp_half))
paste0(" against ", fnum(cmp_half$cost, 4), " at the default 0.50 cutoff") else "",
".")
} else {
paste0(
"No cost of a false positive or a false negative was supplied, so this report does ",
"not pick a cutoff for you: it shows each criterion side by side and, for each, the ",
"cost ratio that criterion implicitly assumes. The maximum-F1 cutoff of ",
fnum(crit$max_f1$threshold, 4), " on ", score_name,
" is shown for reference; it is only the right cutoff if you believe a missed '",
positive_label, "' costs between ", fratio(crit$max_f1$ratio_lo), " and ",
fratio(crit$max_f1$ratio_hi), " times a false alarm.")
}
json_output <- list(
answer = paste0(
"Cutoff analysis of ", score_name, " against ", actual_name, " across ",
fcount(final_rows), " rows(", fpct(prevalence), " '", positive_label, "'). ",
choice_clause,
" At that cutoff precision is ", fpct(hl$precision), " and recall is ",
fpct(hl$recall), " (", fcount(hl$tp), " caught, ", fcount(hl$fn), " missed, ",
fcount(hl$fp), " false alarms). ",
if (imbalanced)
paste0("Positives are rare(", fpct(prevalence),
"), so accuracy is not used as the headline here — always predicting '",
if (prevalence >= 0.5) positive_label else negative_label,
"' would already score ", fpct(baseline_accuracy), ". ")
else "",
"Because the cutoff was chosen on the same rows it is scored on, the in-sample F1 of ",
fnum(f1_apparent, 3), " is optimistic; a bootstrap optimism correction over ",
fcount(boot_b), " resamples puts the honest figure at ", fnum(f1_corrected, 3), "."
),
cards = lapply(
c("tldr", "overview", "preprocessing", "metric_curves",
"criteria_table", "confusion_table", "honesty"),
function(cid) list(id = cid, metrics = metrics)
)
)
list(
initial_rows = initial_rows, final_rows = final_rows, rows_removed = rows_removed,
actual_name = actual_name, score_name = score_name,
positive_label = positive_label, negative_label = negative_label,
positive_rule = positive_rule,
n1 = n1, n0 = n0, prevalence = prevalence, imbalanced = imbalanced,
baseline_accuracy = baseline_accuracy, score_is_prob = score_is_prob,
score_min = score_min, score_max = score_max,
have_costs = have_costs, cost_fp = cost_fp, cost_fn = cost_fn,
benefit_tp = benefit_tp, cost_fn_eff = cost_fn_eff, cost_none = cost_none,
calib_cutoff = calib_cutoff, calib_gap = calib_gap,
target_precision = target_precision, target_recall = target_recall,
tp_source = tp_source, tr_source = tr_source,
crit = crit, cmp_half = cmp_half,
picked_for_user = picked_for_user,
headline_label = headline_label, headline_thr = headline_thr,
headline_k = headline_k, hl = hl,
f1_apparent = f1_apparent, optimism_f1 = optimism_f1, f1_corrected = f1_corrected,
cost_apparent = cost_apparent, optimism_cost = optimism_cost,
cost_corrected = cost_corrected,
thr_ci_low = thr_ci_low, thr_ci_high = thr_ci_high, boot_b = boot_b,
n_thresholds = K,
metric_curves_df = metric_curves_df, criteria_df = criteria_df,
confusion_df = confusion_df, honesty_df = honesty_df,
threshold_summary = threshold_summary, metrics = metrics,
json_output = json_output
)
}Where precision and recall cross is a genuinely computed landmark, not a canned phrase — it is reported only when the two curves actually meet.
d <- shared$metric_curves_df
p <- d[d$metric == "Precision(PPV)", ]
r <- d[d$metric == "Recall(sensitivity)", ]
m <- merge(p[, c("threshold", "metric_value")], r[, c("threshold", "metric_value")],
by = "threshold", suffixes = c("_p", "_r"))
gap <- m$metric_value_p - m$metric_value_r
ok <- which(!is.na(gap))
if (length(ok) > 1 && any(gap[ok] > 0) && any(gap[ok] < 0)) {
i <- ok[which.min(abs(gap[ok]))]
paste0("Precision and recall cross at a cutoff of ", fnum(m$threshold[i], 4),
", where both sit near ", fpct(m$metric_value_p[i]), ". ")
} else if (length(ok) > 1 && all(gap[ok] >= 0)) {
paste0("Precision stays above recall at every cutoff in range, so ", shared$score_name,
" is consistently better at keeping the flag list clean than at catching everything. ")
} else ""
}
ref <- list(list(axis = "x", value = round(shared$headline_thr, 5)))
if (!is.null(shared$cmp_half)) {
ref <- c(ref, list(list(axis = "x", value = 0.5)))
}
list(
title = "Metric Curves by Cutoff",
description = paste0("Precision, recall, F1 and specificity at every candidate cutoff on ",
shared$score_name, "."),
text = paste0(
"Each curve is one metric traced across every cutoff on ", shared$score_name,
". Reading left to right, the cutoff gets stricter: recall and specificity move in ",
"opposite directions by construction, and precision generally rises as the flag list ",
"shrinks. F1 peaks at ", fnum(shared$crit$max_f1$threshold, 4), " (F1 = ",
fnum(shared$f1_apparent, 3), "), while Youden's J peaks at ",
fnum(shared$crit$youden$threshold, 4), ". ", crossing,
if (shared$have_costs)
paste0("The vertical marker sits at the minimum-expected-cost cutoff of ",
fnum(shared$headline_thr, 4),
", which is where your own costs put the line",
if (!is.null(shared$cmp_half))
paste0(" — the second marker is the default 0.50, and the distance between ",
"the two is the whole argument for computing a cutoff instead of ",
"accepting one") else "", ". ")
else
paste0("The vertical marker sits at the maximum-F1 cutoff of ",
fnum(shared$headline_thr, 4),
", shown for reference rather than as a recommendation",
if (!is.null(shared$cmp_half))
" — the second marker is the default 0.50" else "", ". "),
"The curves are the point: any cutoff you choose is a point on these lines, and the ",
"steepness around it tells you how much a small change in the cutoff would move ",
"each metric."
),
chart_labels = list(
threshold = paste0("Cutoff on ", shared$score_name),
metric_value = "Metric value(0 to 1)",
metric = "Metric"
),
overrides = list(reference_lines = ref),
data = list(metric_curves = shared$metric_curves_df)
)
}
# Card: criteria_table (table)
card_criteria_table <- function(shared, df, params) {
ths <- vapply(shared$crit, function(x) x$threshold, numeric(1))
spread <- max(ths, na.rm = TRUE) - min(ths, na.rm = TRUE)
reach <- vapply(shared$crit, function(x) is.na(x$k), logical(1))
unreachable <- names(shared$crit)[reach]
unreachable_note <- if (length(unreachable) > 0) {
paste0("One criterion could not be met at any cutoff: ",
paste(vapply(shared$crit[unreachable], function(x) x$label, character(1)),
collapse = "; "),
". That is a fact about the score, not a failure of the search — no cutoff on ",
shared$score_name, " reaches that target. ")
} else ""
list(
title = "Criteria Side by Side",
description = "Where each named criterion puts the cutoff, and the cost ratio each one implicitly assumes.",
text = paste0(
"The criteria do not agree, and that disagreement is the finding: they span ",
fnum(spread, 4), " on the ", shared$score_name,
" scale. Each row shows what that cutoff buys — precision, recall, F1, specificity",
if (shared$have_costs) " and expected cost per row" else "",
" — alongside the range of cost ratios for which that cutoff is the cheapest one. ",
"Read that last column as a belief: a range of '3 to 5' means the cutoff is right ",
"only if one missed '", shared$positive_label,
"' hurts between three and five times as much as one false alarm. ",
unreachable_note,
if (shared$picked_for_user)
paste0("Because you supplied costs, the minimum-expected-cost row is the one this ",
"report leads with; the others are shown so the trade-off stays visible.")
else
paste0("No costs were supplied, so no row is marked as the answer. The honest ",
"recommendation is to pick the row whose implied cost ratio matches what you ",
"actually believe, or to supply the two costs and let the arithmetic pick it.")
),
data = list(threshold_criteria = shared$criteria_df)
)
}
# Card: confusion_table (table)
card_confusion_table <- function(shared, df, params) {
hl <- shared$hl
half_clause <- if (!is.null(shared$cmp_half)) {
d_tp <- hl$tp - shared$cmp_half$tp
d_fp <- hl$fp - shared$cmp_half$fp
paste0("Against the default 0.50 cutoff, this cutoff catches ",
fcount(abs(d_tp)), if (d_tp >= 0) " more" else " fewer",
" positives and raises ", fcount(abs(d_fp)),
if (d_fp >= 0) " more" else " fewer", " false alarms. ")
} else {
paste0(shared$score_name, " is not on a 0-to-1 scale, so there is no default 0.50 ",
"cutoff to compare against. ")
}
acc_clause <- if (shared$imbalanced) {
paste0("Accuracy at this cutoff is ", fpct(hl$accuracy), ", but it is reported only ",
"for completeness: with positives this rare, always predicting '",
if (shared$prevalence >= 0.5) shared$positive_label else shared$negative_label,
"' scores ", fpct(shared$baseline_accuracy),
" while being useless, so accuracy is not evidence of anything here.")
} else {
{
gap_pp <- 100 * (hl$accuracy - shared$baseline_accuracy)
paste0("Accuracy at this cutoff is ", fpct(hl$accuracy), " against a majority-class ",
"baseline of ", fpct(shared$baseline_accuracy), ", ",
if (gap_pp >= 0)
paste0("a gain of ", fnum(gap_pp, 1), " percentage points.")
else
paste0("which is ", fnum(abs(gap_pp), 1),
" percentage points BELOW the baseline — this cutoff trades raw accuracy for the recall it buys."))
}
}
list(
title = "Confusion Matrix at the Chosen Cutoff",
description = paste0("Every count and rate at the ", tolower(shared$headline_label),
" cutoff of ", fnum(shared$headline_thr, 4), "."),
text = paste0(
"At a cutoff of ", fnum(shared$headline_thr, 4), " on ", shared$score_name,
", ", fcount(hl$tp + hl$fp), " of ", fcount(shared$final_rows),
" rows get flagged. Of those, ", fcount(hl$tp), " really are '",
shared$positive_label, "' and ", fcount(hl$fp), " are not, giving precision of ",
fpct(hl$precision), ". Of the ", fcount(shared$n1), " real '",
shared$positive_label, "' rows, ", fcount(hl$tp), " are caught and ",
fcount(hl$fn), " are missed, giving recall of ", fpct(hl$recall),
"; specificity is ", fpct(hl$specificity), ". ", half_clause, acc_clause
),
data = list(confusion_detail = shared$confusion_df)
)
}
# Card: honesty (table)
card_honesty <- function(shared, df, params) {
width <- if (is.na(shared$thr_ci_low)) NA_real_ else shared$thr_ci_high - shared$thr_ci_low
stability <- if (is.na(width)) {
"The bootstrap could not characterise the cutoff's stability on this data. "
} else {
span <- max(vapply(shared$crit, function(x) x$threshold, numeric(1)), na.rm = TRUE) -
min(vapply(shared$crit, function(x) x$threshold, numeric(1)), na.rm = TRUE)
paste0("Across resamples the chosen cutoff ranged from ", fnum(shared$thr_ci_low, 4),
" to ", fnum(shared$thr_ci_high, 4), ", a span of ", fnum(width, 4), " on the ",
shared$score_name, " scale",
if (is.finite(span) && span > 0)
paste0(" — ", fnum(width / max(span, 1e-9), 2),
" times the distance between the criteria themselves") else "",
". ",
if (width > 0.15)
paste0("That is wide: the cutoff is not well determined by ",
fcount(shared$final_rows),
" rows, and treating it as a precise number would overstate what the data supports. ")
else
paste0("That is narrow, so the cutoff is reasonably well determined by ",
fcount(shared$final_rows), " rows. "))
}
calib <- if (shared$have_costs && !is.na(shared$calib_cutoff) && shared$score_is_prob) {
paste0("A separate check falls out of the costs: if ", shared$score_name,
" were a perfectly calibrated probability, the cost-minimising cutoff would sit ",
"exactly at ", fnum(shared$calib_cutoff, 4),
". The empirical minimum sits at ", fnum(shared$crit$min_cost$threshold, 4),
", a gap of ", fnum(shared$calib_gap, 4), " — ",
if (!is.na(shared$calib_gap) && shared$calib_gap > 0.05)
"large enough to suggest the score is not well calibrated, so read it as a ranking rather than as a probability."
else
"small, which is consistent with a reasonably calibrated score.", " ")
} else ""
list(
title = "In-Sample Optimism, Stability & Balance",
description = "What the reported performance at the chosen cutoff does and does not entitle you to claim.",
text = paste0(
"A cutoff chosen on a dataset and then scored on that same dataset is optimistic by ",
"construction — the search finds the point where this particular sample happened to ",
"look best, and some of that is noise that will not repeat. The size of the ",
"flattery grows as the data shrinks. Measuring it here: over ", fcount(shared$boot_b),
" bootstrap resamples, each picking its own maximum-F1 cutoff and then being scored ",
"on the original rows, the average optimism is ", fnum(shared$optimism_f1, 4),
" in F1. The in-sample F1 of ", fnum(shared$f1_apparent, 3),
" therefore corresponds to an honest expectation of about ",
fnum(shared$f1_corrected, 3), " on fresh rows",
if (shared$have_costs && !is.na(shared$cost_corrected))
paste0(", and the in-sample expected cost of ", fnum(shared$cost_apparent, 4),
" per row corresponds to about ", fnum(shared$cost_corrected, 4),
" on fresh rows") else "",
". ", stability, calib,
"The one clean way to remove this optimism entirely is to choose the cutoff on one ",
"set of rows and measure it on rows the search never saw."
),
data = list(honesty_checks = shared$honesty_df)
)
}