Validation
Rank ordering out of time
gains_oot <- obwoe_gains(oot, target = "default", feature = "score",
use_column = "direct", n_groups = 10, sort_by = "bin")
gains_oot
#> Gains Table: score
#> ==================================================
#>
#> Observations: 8000 | Bins: 10
#> Total IV: 0.8580
#>
#> Performance Metrics:
#> KS Statistic: 36.19%
#> Gini Coefficient: 48.78%
#> AUC: 0.7439
#>
#> bin count pos_rate woe iv cum_pos_pct ks lift
#> G01 823 51.03% 1.5085 0.3291 28.0% 21.8% 2.72
#> G02 781 33.16% 0.7663 0.0709 45.3% 31.1% 1.77
#> G03 878 23.58% 0.2911 0.0102 59.1% 34.6% 1.26
#> G04 748 21.39% 0.1656 0.0027 69.8% 36.2% 1.14
#> G05 889 16.76% -0.1355 0.0020 79.7% 34.7% 0.89
#> G06 773 12.42% -0.4862 0.0195 86.1% 30.7% 0.66
#> G07 715 9.37% -0.8020 0.0441 90.6% 25.2% 0.50
#> G08 818 8.92% -0.8558 0.0564 95.5% 18.6% 0.48
#> G09 819 5.74% -1.3317 0.1164 98.6% 9.9% 0.31
#> G10 756 2.78% -2.0882 0.2068 100.0% 0.0% 0.15Three things to check, in order. The event rate must fall monotonically from the worst decile to the best — a break means the score does not rank. KS and Gini must be close to their development values. And the top decile’s lift is the number the business will quote.
gains_dev <- obwoe_gains(dev, target = "default", feature = "score",
use_column = "direct", n_groups = 10, sort_by = "bin")
data.frame(
sample = c("development", "out-of-time"),
ks = round(c(gains_dev$metrics$ks, gains_oot$metrics$ks), 2),
gini = round(c(gains_dev$metrics$gini, gains_oot$metrics$gini), 2),
auc = round(c(gains_dev$metrics$auc, gains_oot$metrics$auc), 4)
)
#> sample ks gini auc
#> 1 development 36.38 49.04 0.7452
#> 2 out-of-time 36.19 48.78 0.7439A drop of more than a few points from development to out-of-time is the usual signature of overfitting; holding steady, as here, is what a stable model looks like.
op <- par(mfrow = c(2, 2), mar = c(4, 4, 2, 1))
plot(gains_oot, type = "cumulative")
plot(gains_oot, type = "ks")
plot(gains_oot, type = "lift")
plot(gains_oot, type = "woe_iv")
Population stability
PSI compares the distribution of a variable between two periods:
\[ \mathrm{PSI} = \sum_i (p_i - q_i)\,\ln\frac{p_i}{q_i} \]
which is the same Jeffreys divergence that defines IV, applied to two vintages of one variable instead of to two classes. The conventional reading is \(<0.10\) stable, \(0.10\)–\(0.25\) worth watching, \(>0.25\) act.
psi <- function(p, q) {
p <- pmax(p, 1e-6)
q <- pmax(q, 1e-6)
sum((p - q) * log(p / q))
}
share <- function(x, levels) as.numeric(table(factor(x, levels))) / length(x)
bins_dev <- obwoe_apply(dev, binning, keep_original = FALSE)
bins_oot <- obwoe_apply(oot, binning, keep_original = FALSE)
psi_vars <- vapply(final_vars, function(v) {
levels <- binning$results[[v]]$bin
psi(share(bins_dev[[paste0(v, "_bin")]], levels),
share(bins_oot[[paste0(v, "_bin")]], levels))
}, numeric(1))
score_cuts <- c(-Inf, quantile(dev$score, seq(0.1, 0.9, 0.1)), Inf)
psi_score <- psi(share(cut(dev$score, score_cuts), levels(cut(dev$score, score_cuts))),
share(cut(oot$score, score_cuts), levels(cut(dev$score, score_cuts))))
psi_table <- data.frame(
variable = c("SCORE", final_vars),
psi = round(c(psi_score, psi_vars), 4),
row.names = NULL
)
psi_table <- psi_table[order(-psi_table$psi), ]
row.names(psi_table) <- NULL
psi_table
#> variable psi
#> 1 ltv 0.0022
#> 2 bureau_score 0.0017
#> 3 utilisation 0.0014
#> 4 SCORE 0.0012
#> 5 income_declared 0.0010
#> 6 age 0.0008
#> 7 housing 0.0007
#> 8 occupation 0.0006
#> 9 inquiries_6m 0.0004
#> 10 delinq_12m 0.0004
#> 11 tenure_months 0.0002
#> 12 channel 0.0002Comparing bin shares rather than raw quantiles is deliberate: the bins are what the model consumes, the comparison works for numerical and categorical variables alike, and a shift that does not cross a cut point is a shift the model never sees.
Both vintages come from the same generator here, so everything is stable by construction. In production this table is the monthly monitoring report, and the score’s own PSI is the headline.