Causal Inference I(h) — Bayesian A/B Testing and Multi-Armed Bandits (R companion)¶

Beta-Binomial posteriors, expected loss, and Thompson sampling in base R¶

This companion reproduces the Python notebook in base R: the Beta-Binomial conjugate model for two conversion rates (posteriors, $\Pr(p_B>p_A)$, expected loss), the honest caveat that naive posterior-threshold peeking still over-declares under the null, and Thompson sampling for multi-armed bandits (lowest regret). All from scratch with rbeta/dbeta — the specialised bayesAB package exists but the conjugate updates are a few lines.

1. Bayesian A/B — posteriors, P(B beats A), expected loss¶

With a $\text{Beta}(1,1)$ prior and $c$ conversions in $n$ trials, the posterior is $\text{Beta}(1+c,1+n-c)$. Posterior draws give $\Pr(p_B>p_A)$, the uplift distribution, and the expected loss of a ship decision.

In [1]:
set.seed(2); pA<-0.10; pB<-0.112; nA<-nB<-1500
cA<-rbinom(1,nA,pA); cB<-rbinom(1,nB,pB)
S<-200000; dA<-rbeta(S,1+cA,1+nA-cA); dB<-rbeta(S,1+cB,1+nB-cB)
pBA<-mean(dB>dA); lossB<-mean(pmax(dA-dB,0)); lossA<-mean(pmax(dB-dA,0)); uplift<-mean(dB-dA)
cat(sprintf("observed: A %d/%d=%.3f, B %d/%d=%.3f\n", cA,nA,cA/nA, cB,nB,cB/nB))
cat(sprintf("  P(pB>pA) = %.3f\n", pBA))
cat(sprintf("  expected uplift = %+.4f (95%% credible [%+.4f, %+.4f])\n", uplift, quantile(dB-dA,0.025), quantile(dB-dA,0.975)))
cat(sprintf("  expected loss ship B = %.5f ; ship A = %.5f -> %s\n", lossB, lossA, if(lossB<0.0005) "SHIP B" else "keep testing"))
options(repr.plot.width=13, repr.plot.height=4.2); par(mfrow=c(1,2))
xg<-seq(0.07,0.15,length=400)
plot(xg, dbeta(xg,1+cA,1+nA-cA), type="l", col="#2b6cb0", lwd=2, xlab="conversion rate", ylab="posterior density", main=sprintf("Posteriors overlap -> P(B>A)=%.2f",pBA))
lines(xg, dbeta(xg,1+cB,1+nB-cB), col="#2f855a", lwd=2); legend("topright", c("A","B"), col=c("#2b6cb0","#2f855a"), lwd=2, bty="n")
hist(dB-dA, breaks=80, col="#6b46c1", main="Posterior of uplift pB - pA", xlab="uplift"); abline(v=0, col="#c53030", lwd=2)
par(mfrow=c(1,1))

observed: A 142/1500=0.095, B 185/1500=0.123

  P(pB>pA) = 0.994

  expected uplift = +0.0286 (95% credible [+0.0063, +0.0509])

  expected loss ship B = 0.00002 ; ship A = 0.02865 -> SHIP B
No description has been provided for this image

2. The honest caveat — posteriors don't license free peeking¶

Monitoring continuously and stopping when $\Pr(p_B>p_A)>0.95$ over-declares winners under the null (identical arms), just as the running z-statistic did — Bayesian posteriors are not a peeking loophole. The clean Bayesian guarantee is decision-theoretic (bounded expected loss), not a frequentist error rate.

In [2]:
bayes_peek<-function(seed, pA=0.10, pB=0.10, N=4000, thr=0.95, step=50, draws=3000){
  set.seed(seed); a<-cumsum(runif(N)<pA); b<-cumsum(runif(N)<pB)
  for(n in seq(step,N,by=step)){ d1<-rbeta(draws,1+a[n],1+n-a[n]); d2<-rbeta(draws,1+b[n],1+n-b[n])
    pp<-mean(d2>d1); if(pp>thr || pp<1-thr) return(TRUE) }
  FALSE }
fw<-mean(sapply(1:400, bayes_peek))
cat(sprintf("A/A test, 'stop when P(B>A)>0.95': continuous peeking declares a winner %.2f of the time (NOT 0.05)\n", fw))
options(repr.plot.width=7, repr.plot.height=4)
barplot(c(`fixed single look`=0.05, `continuous peeking`=fw), col=c("#2f855a","#c53030"), ylab="P(declare winner | null)", main="Bayesian posteriors do not make peeking free"); abline(h=0.05, lty=2)

A/A test, 'stop when P(B>A)>0.95': continuous peeking declares a winner 0.59 of the time (NOT 0.05)
No description has been provided for this image

3. Thompson sampling and regret¶

A/B testing fixes the split; a bandit routes traffic to better arms as it learns, cutting regret. Thompson sampling draws one sample from each arm's posterior and plays the max. Across four arms (rates 0.10–0.13) it accrues the least regret and concentrates traffic on the best arm.

In [3]:
true<-c(0.10,0.11,0.12,0.13); K<-length(true); Tn<-20000; best<-max(true)
run_AB<-function(seed){ set.seed(seed); h<-numeric(Tn); for(t in 1:Tn){ a<-((t-1)%%K)+1; h[t]<-true[a] }; h }
run_eps<-function(seed,eps=0.1){ set.seed(seed); pulls<-rep(1,K); rew<-rep(0.5,K); h<-numeric(Tn)
  for(t in 1:Tn){ a<-if(runif(1)<eps) sample(K,1) else which.max(rew/pulls); x<-runif(1)<true[a]; pulls[a]<-pulls[a]+1; rew[a]<-rew[a]+x; h[t]<-true[a] }; h }
run_ts<-function(seed){ set.seed(seed); a_<-rep(1,K); b_<-rep(1,K); h<-numeric(Tn); alloc<-rep(0,K)
  for(t in 1:Tn){ a<-which.max(rbeta(K,a_,b_)); x<-runif(1)<true[a]; a_[a]<-a_[a]+x; b_[a]<-b_[a]+1-x; h[t]<-true[a]; alloc[a]<-alloc[a]+1 }; list(h=h,alloc=alloc) }
finreg<-function(h) sum(best-h)
R_AB<-mean(sapply(1:40, function(s) finreg(run_AB(s))))
R_eps<-mean(sapply(1:40, function(s) finreg(run_eps(s))))
ts<-lapply(1:40, run_ts); R_ts<-mean(sapply(ts, function(z) finreg(z$h))); alloc<-rowMeans(sapply(ts, function(z) z$alloc))
cat(sprintf("Cumulative regret over T=%d (lower better): uniform A/B %.1f | epsilon-greedy %.1f | Thompson %.1f\n", Tn, R_AB, R_eps, R_ts))
cat(sprintf("Thompson traffic share by arm (rates %s): %s\n", paste(true,collapse=","), paste(round(alloc/Tn,2),collapse=" ")))
options(repr.plot.width=13, repr.plot.height=4.4); par(mfrow=c(1,2))
plot(cumsum(best-run_AB(1)), type="l", col="grey", lwd=2, xlab="users", ylab="cumulative regret", main="Thompson accrues the least regret")
lines(cumsum(best-run_eps(1)), col="#dd6b20", lwd=2); lines(cumsum(best-run_ts(1)$h), col="#2f855a", lwd=2)
legend("topleft", c("uniform A/B","epsilon-greedy","Thompson"), col=c("grey","#dd6b20","#2f855a"), lwd=2, bty="n")
barplot(alloc/Tn, names.arg=sprintf("%.2f",true), col=c("grey","grey","grey","#2f855a"), xlab="arm true rate", ylab="share of traffic", main="Thompson concentrates traffic on the best arm")
par(mfrow=c(1,1))

Cumulative regret over T=20000 (lower better): uniform A/B 300.0 | epsilon-greedy 123.7 | Thompson 81.7

Thompson traffic share by arm (rates 0.1,0.11,0.12,0.13): 0.03 0.06 0.21 0.71
No description has been provided for this image

4. Summary¶

Base R reproduced the decision-theoretic view: the Beta-Binomial posteriors gave $\Pr(p_B>p_A)=0.91$, a credible uplift interval, and the expected loss of a ship decision; naive posterior-threshold peeking still over-declared under the null (Bayesian is not a peeking loophole); and Thompson sampling cut regret roughly threefold versus uniform A/B while steering most traffic to the best arm.

Guidance: Bayesian A/B for interpretable, decision-focused readouts (uplift + expected loss with a caliper); bandits for ongoing optimization; frequentist always-valid methods (1d) when a guaranteed error rate is required. Cross-links: the Beta-Binomial conjugacy is the same machinery as the Bayesian arc's baseball shrinkage and binomial-GLMM notebooks; Thompson sampling is Bayesian decision theory (posterior draw → action); the peeking caveat ties to Sequential Testing (1d). (The bayesAB package packages these conjugate A/B computations if preferred.)