Executive Summary
Where to set the cutoff on Glucose, and what each candidate assumes about your costs
The short answer
At a cutoff of 124.0000 on Glucose, you catch 70.1% of positives (188 of 268) while flagging 58.4% of your alerts as true cases — but this cutoff was chosen and scored on the same 768 rows, so its reported F1 of 0.637 is optimistic. A bootstrap correction estimates the honest F1 on fresh data at 0.626.
The detail
Maximum F1 and Youden's J both land at 124.0000, where precision is 58.4%, recall is 70.1%, and F1 is 0.637 in-sample. This cutoff flags 322 of 768 rows (188 true positives, 134 false alarms) and is equivalent to believing a missed positive costs 1.79 to 2.32 times a false alarm. Over 200 bootstrap resamples, the optimism in F1 is estimated at 0.0114, yielding a corrected expectation of 0.626 on unseen rows. The chosen cutoff itself ranged from 108.0000 to 129.0000 across resamples — a span of 21.0000, or 0.51 times the disagreement between criteria — indicating the cutoff is not tightly pinned by 768 rows.
What this can't tell you
Because no costs were supplied, this report does not declare a cutoff to be the answer. The maximum-F1 cutoff is the one the analysis leads with, but it is right only if your belief about cost ratios matches its implicit assumption (1.79 to 2.32). If your costs differ, a different row in the criteria table is your answer.
Analysis Overview
Where to set the cutoff on Glucose when deciding '1' versus '0', across 768 rows.
The short answer
A cutoff is a business choice, not a statistical one. Every value on Glucose trades catching diabetes cases against raising false alarms; the 136 distinct cutoffs present in your data span from 114.0000 to 155.0000, and four named criteria (maximum F1, Youden's J, and others) disagree on where the line should go. This analysis shows what each cutoff buys and what it costs, so you can decide based on what your errors are actually worth.
The detail
The analysis evaluates all 136 distinct cutoffs present in Glucose across 768 rows. The maximum-F1 criterion lands at 124.0000, as does Youden's J. Because the criteria span 114.0000 to 155.0000, no single "best" answer exists without knowing your cost ratio — the relative weight of a missed positive against a false alarm. The maximum-F1 cutoff at 124.0000 implicitly assumes one missed case costs between 1.79 and 2.32 times one false alarm.
What this can't tell you
Without supplying the cost of a false positive and a false negative, the report cannot choose a cutoff for you. If your cost ratio differs from what maximum F1 assumes, a different cutoff minimizes your expected loss. A companion ROC analysis would answer whether Glucose ranks cases well at all; this report takes that ranking as given and focuses only on where to draw the line.
Data Quality
Positive-class definition, dropped rows, class balance, and the score's scale.
The short answer
All 768 rows loaded with complete outcome and glucose values; no rows were dropped. The data holds 268 positive cases (34.9%) and 500 negatives, making it reasonably balanced. Glucose ranges from 0.0000 to 199.0000 and is treated as an arbitrary continuous score, not a probability — so the conventional 0.50 cutoff is meaningless and is not reported.
The detail
768 rows, 768 usable. Outcome was coded as '1' (positive) and '0' (negative), with all rows carrying both values. Positive rate is 0.349 (268 / 768). Glucose spans 0.0000 to 199.0000 and was read as a continuous variable where higher values indicate higher likelihood of '1'. Because the score falls outside the 0-to-1 range, it is not a calibrated probability, and a default 0.50 threshold would be arbitrary. The class balance (34.9% positives) is reasonable enough that accuracy retains some interpretive value, but the majority-class baseline of 65.1% — what you score by always predicting '0' — is the bar any accuracy claim must clear.
What this can't tell you
The analysis takes the Glucose score as given and does not assess whether it is well-calibrated to actual diabetes risk. A companion ROC analysis (if run) would answer whether Glucose ranks positive cases above negative ones; this report assumes that ranking is sound and focuses only on where to draw the line.
Metric Curves by Cutoff
Precision, recall, F1 and specificity at every candidate cutoff on Glucose.
The short answer
As the cutoff tightens from left to right, recall and specificity move in opposite directions by construction: raising the cutoff catches fewer positives but clears more negatives. Precision generally rises as the flag list shrinks. F1 peaks at 124.0000 (F1 = 0.637), the point where the trade-off between precision and recall is tightest.
The detail
The four curves (precision, recall, F1, specificity) are traced across all 136 candidate cutoffs on Glucose. F1 reaches its maximum of 0.637 at a cutoff of 124.0000. Youden's J also peaks at 124.0000. Precision and recall are equal at a cutoff of 129.0000, where both sit near 61.8%. The vertical reference line at 124.0000 marks the maximum-F1 cutoff for orientation only. The steepness of the curves around any point tells you how much each metric would move if you shifted the cutoff slightly — a steep curve means small changes in the cutoff incur large changes in the metric.
What this can't tell you
The curves show the trade-off but do not reveal which trade-off is right for you. A cutoff that maximizes F1 ignores what your errors actually cost; it is useful as a reference point when no cost information is available, but it is not inherently superior to a cutoff chosen to minimize your expected cost.
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 |
|---|---|---|---|---|---|---|---|---|
| Maximum F1 | 124.0000 | 58.4% | 70.1% | 0.637 | 73.2% | n/a | 1.79 to 2.32 | Balances precision against recall with no reference to what either error costs you. |
| Youden's J | 124.0000 | 58.4% | 70.1% | 0.637 | 73.2% | n/a | 1.79 to 2.32 | Maximises sensitivity plus specificity, which weights a missed positive and a false alarm equally. |
| Meets precision >= 80.0% | 155.0000 | 80.3% | 36.6% | 0.503 | 95.2% | n/a | 0.43 to 0.93 | Catches as many positives as possible while keeping precision at or above 80.0% (default). |
| Meets recall >= 80.0% | 114.0000 | 51.7% | 80.2% | 0.629 | 59.8% | 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
Four named criteria are shown side by side, and they disagree: they span 41.0000 on the Glucose scale from 114.0000 to 155.0000. Maximum F1 and Youden's J both land at 124.0000 and catch 70.1% of positives with 58.4% precision. A 80% precision floor pushes the cutoff to 155.0000, catching only 36.6% of positives but nearly eliminating false alarms. A 80% recall floor pulls it back to 114.0000, catching 80.2% of positives at the cost of precision dropping to 51.7%.
The detail
Maximum F1 (124.0000): precision 58.4%, recall 70.1%, F1 0.637, specificity 73.2%, implied cost ratio 1.79 to 2.32. Youden's J (124.0000): identical metrics, same implied cost ratio. Meets precision ≥ 80% (155.0000): precision 80.3%, recall 36.6%, F1 0.503, specificity 95.2%, implied cost ratio 0.43 to 0.93. Meets recall ≥ 80% (114.0000): precision 51.7%, recall 80.2%, F1 0.629, specificity 59.8%, no cost ratio makes this cutoff cheapest. The last column translates each cutoff into a belief: a range of '1.79 to 2.32' means the cutoff is optimal only if one missed positive hurts 1.79 to 2.32 times as much as one false alarm. No costs were supplied, so no row is marked as the answer.
What this can't tell you
The table shows what each criterion buys but does not tell you which is right. That decision rests on your actual costs. If you believe a missed positive is roughly twice as costly as a false alarm, the maximum-F1 cutoff at 124.0000 is your answer; if you believe false alarms are much costlier, the 155.0000 cutoff is better; if you must catch 80% of positives, the 114.0000 cutoff is the only option.
Confusion Matrix at the Chosen Cutoff
Every count and rate at the maximum f1 cutoff of 124.0000.
| Metric | Value | Interpretation |
|---|---|---|
| Cutoff on Glucose | 124.0000 | Flag a row when Glucose is at or above this value. |
| True positives (flagged and really '1') | 188 | Caught positives — the wins this cutoff buys. |
| False positives (flagged but really '0') | 134 | False alarms — the cost this cutoff incurs. |
| True negatives (cleared and really '0') | 366 | Correctly cleared '0' rows. |
| False negatives (cleared but really '1') | 80 | Missed positives — what slips through at this cutoff. |
| Precision (PPV) | 58.4% | Of the rows flagged, the share that really are '1'. |
| Recall (sensitivity) | 70.1% | Of the real '1' rows, the share caught. |
| Specificity | 73.2% | Of the real '0' rows, the share correctly cleared. |
| F1 score | 0.637 | Harmonic mean of precision and recall. |
| Accuracy | 72.1% | Share of all rows classified correctly at this cutoff. |
| Majority-class baseline accuracy | 65.1% | What you would score by always predicting '0' and never looking at the score — the bar accuracy has to clear before it means anything. |
| Rows flagged positive | 322 of 768 | How much work this cutoff creates. |
The short answer
At a cutoff of 124.0000, you flag 322 rows: 188 are true positives and 134 are false alarms. You catch 70.1% of the 268 real positives (188) and miss 80. Precision is 58.4% — meaning 58.4% of your alerts are real cases — and specificity is 73.2%, meaning you correctly clear 73.2% of the negative rows.
The detail
Cutoff: 124.0000. Flagged rows: 322 of 768. True positives (caught positives): 188. False positives (false alarms): 134. True negatives (correctly cleared): 366. False negatives (missed positives): 80. Precision (PPV): 58.4% — of the 322 flagged, 188 are real '1' rows. Recall (sensitivity): 70.1% — of the 268 real '1' rows, 188 are caught. Specificity: 73.2% — of the 500 real '0' rows, 366 are correctly cleared. F1: 0.637. Accuracy: 72.1%, which clears the majority-class baseline of 65.1% by 7.0 percentage points. Glucose is not on a 0-to-1 scale, so no default 0.50 cutoff exists for comparison.
What this can't tell you
These counts reflect what the cutoff does on the same 768 rows used to select it, so they are optimistic by about 0.0114 in F1. On fresh data, expect recall and precision to move slightly; the bootstrap-corrected F1 of 0.626 is the honest forecast. The cutoff itself is also uncertain: across resamples it ranged from 108.0000 to 129.0000, so treating 124.0000 as a fixed rule would overstate precision.
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.637 | The figure you get by choosing and scoring the cutoff on the same rows. It is optimistic. |
| Optimism (bootstrap estimate) | 0.0114 | How much of that F1 is an artefact of choosing the cutoff on this very data. |
| F1 corrected for optimism | 0.626 | The honest expectation for the same cutoff rule applied to fresh rows. |
| Cutoff 95% bootstrap interval | 108.0000 to 129.0000 | 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 | 34.9% | 268 '1' rows against 500 '0' rows. |
| Majority-class baseline accuracy | 65.1% | Accuracy is only informative to the extent it beats this number. |
The short answer
The cutoff was chosen and scored on the same 768 rows, so it is optimistic by construction. A bootstrap correction over 200 resamples estimates the flattery at 0.0114 in F1, meaning the honest expectation on fresh data is 0.626 instead of the reported 0.637. The chosen cutoff itself is not tightly pinned: it ranged from 108.0000 to 129.0000 across resamples, a span of 21.0000.
The detail
In-sample F1 at the maximum-F1 cutoff: 0.637. Bootstrap optimism (200 resamples, Efron method): 0.0114. Corrected F1 expectation on fresh rows: 0.626. Cutoff 95% bootstrap interval: 108.0000 to 129.0000, a span of 21.0000 — equal to 0.51 times the full disagreement between criteria (41.0000). This wide interval means the cutoff is not well determined by 768 rows; small changes in the sample can move it by several points. Positive-class share: 34.9% (268 of 768). Majority-class baseline accuracy: 65.1%. The only way to eliminate optimism entirely is to choose the cutoff on one set of rows and measure it on rows the search never saw.
What this can't tell you
The corrected F1 of 0.626 is an estimate, not a guarantee. The true performance on fresh data depends on whether the new data comes from the same distribution; if the Glucose score or the outcome changes, the cutoff and its metrics will shift. A held-out test set would give a direct answer.
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)
)
}