suppressMessages(library(lme4))
d <- read.csv('baseball.csv'); d$player <- factor(seq_len(nrow(d))); raw <- d$r/d$n; truth <- d$remaining_avg
# logit-normal GLMM
gm <- glmer(cbind(r, n-r) ~ 1 + (1|player), family=binomial, data=d)
mu_ln <- fixef(gm)[['(Intercept)']]; pln <- 1/(1+exp(-(mu_ln + ranef(gm)$player[,1])))
cat(sprintf('logit-normal (glmer): pop %.3f  sigma %.3f\n', 1/(1+exp(-mu_ln)), sqrt(unlist(VarCorr(gm))[1])))
# beta-binomial
ok <- suppressWarnings(suppressMessages(require(VGAM)))
if (!ok) { install.packages('VGAM', repos='https://cloud.r-project.org'); library(VGAM) }
fit <- vglm(cbind(r, n-r) ~ 1, betabinomial, data=d)
mu_bb <- predict(fit, type='response')[1]; rho <- 1/(1+exp(-coef(fit)[2]))     # intra-class corr
kappa <- (1-rho)/rho; a <- mu_bb*kappa; b <- (1-mu_bb)*kappa
pbb <- (a + d$r)/(a + b + d$n)
cat(sprintf('beta-binomial (VGAM): mu %.3f  kappa %.0f  shrinkage %.0f%%\n', mu_bb, kappa, 100*kappa/(kappa+45)))
rmse <- function(x) sqrt(mean((x-truth)^2))
cat(sprintf('\nRMSE vs rest-of-season: raw %.4f | beta-binomial %.4f | logit-normal %.4f\n', rmse(raw), rmse(pbb), rmse(pln)))

logit-normal (glmer): pop 0.265  sigma 0.081

Installing package into 'C:/Users/user/R/win-library/4.6'
(as 'lib' is unspecified)

package 'VGAM' successfully unpacked and MD5 sums checked

The downloaded binary packages are in
	C:\Users\user\AppData\Local\Temp\RtmpC2Lv5s\downloaded_packages

Loading required package: stats4

Loading required package: splines

beta-binomial (VGAM): mu 0.265  kappa 793  shrinkage 95%

RMSE vs rest-of-season: raw 0.0690 | beta-binomial 0.0389 | logit-normal 0.0389

options(repr.plot.width = 8, repr.plot.height = 5)
ord <- order(raw); pop <- mean(raw)
plot(seq_along(ord), raw[ord], pch=1, col='darkorange', ylim=c(0.12,0.42),
     xlab='player (sorted by raw avg)', ylab='batting average', main='Efron-Morris shrinkage (R)', xaxt='n')
points(seq_along(ord), pbb[ord], pch=19, col='steelblue'); points(seq_along(ord), pln[ord], pch=4, col='seagreen')
points(seq_along(ord), truth[ord], pch=3, col='black')
abline(h=pop, col='firebrick', lty=2)
legend('topleft', legend=c('raw','beta-binomial','logit-normal','truth','mean'),
       pch=c(1,19,4,3,NA), lty=c(NA,NA,NA,NA,2), col=c('darkorange','steelblue','seagreen','black','firebrick'), bty='n', cex=0.8)

Baseball — R cross-check (`lme4::glmer` + `VGAM` beta-binomial)¶

Results¶

Baseball — R cross-check (lme4::glmer + VGAM beta-binomial)¶

Results¶

Baseball — R cross-check (`lme4::glmer` + `VGAM` beta-binomial)¶