In BayesFactor: Computation of Bayes Factors for Common Designs

library(BayesFactor)

options(BFprogress = FALSE)
bfversion = BFInfo()
session = sessionInfo()[[1]]
rversion = paste(session$version.string," on ",session$platform,sep="")


options(markdown.HTML.stylesheet = 'extra/manual.css')
library(knitr)
opts_chunk$set(dpi = 200, out.width = "67%") 
options(digits=3)
require(graphics)
set.seed(2)

Comparison of BayesFactor against other packages

This R markdown file runs a series of tests to ensure that the BayesFactor package is giving correct answers, and can gracefully handle probable input.

library(arm)
library(lme4)

ANOVA

First we generate some data.

# Number of participants
N <- 20
sig2 <- 1
sig2ID <- 1

# 3x3x3 design, with participant as random factor
effects <- expand.grid(A = c("A1","A2","A3"),
                       B = c("B1","B2","B3"),
                       C = c("C1","C2","C3"),
                       ID = paste("Sub",1:N,sep="")
)
Xdata <- model.matrix(~ A*B*C + ID, data=effects)
beta <- matrix(c(50,
          -.2,.2,
          0,0,
          .1,-.1,
          rnorm(N-1,0,sqrt(sig2ID)),
          0,0,0,0,
          -.1,.1,.1,-.1,
          0,0,0,0,
          0,0,0,0,0,0,0,0),
               ncol=1)
effects$y = rnorm(Xdata%*%beta,Xdata%*%beta,sqrt(sig2))

# Typical repeated measures ANOVA
summary(fullaov <- aov(y ~ A*B*C + Error(ID/(A*B*C)),data=effects))

We can plot the data with standard errors:

mns <- tapply(effects$y,list(effects$A,effects$B,effects$C),mean)
stderr = sqrt((sum(resid(fullaov[[3]])^2)/fullaov[[3]]$df.resid)/N)

par(mfrow=c(1,3),cex=1.1)
for(i in 1:3){
  matplot(mns[,,i],xaxt='n',typ='b',xlab="A",main=paste("C",i), 
          ylim=range(mns)+c(-1,1)*stderr,ylab="y")
  axis(1,at=1:3,lab=1:3)
  segments(1:3 + mns[,,i]*0,mns[,,i] + stderr,1:3 + mns[,,i]*0,mns[,,i] - stderr,col=rgb(0,0,0,.3))
}

Bayes factor

Compute the Bayes factors, while testing the Laplace approximation

t.is = system.time(bfs.is <- anovaBF(y ~ A*B*C + ID, data = effects, 
                                     whichRandom="ID")
)
t.la = system.time(bfs.la <- anovaBF(y ~ A*B*C + ID, data = effects, 
                                     whichRandom="ID",
                                     method = "laplace")
)

t.is
t.la

plot(log(extractBF(sort(bfs.is))$bf),log(extractBF(sort(bfs.la))$bf),
     xlab="Default Sampler",ylab="Laplace approximation",
     pch=21,bg=rgb(0,0,1,.2),col="black",asp=TRUE,cex=1.2)
abline(0,1)

bfs.is

Comparison to lmer and arm

We can use samples from the posterior distribution to compare BayesFactor with lmer and arm.

chains <- lmBF(y ~ A + B + C + ID, data=effects, whichRandom = "ID", posterior=TRUE, iterations=10000)

lmerObj <- lmer(y ~ A + B + C + (1|ID), data=effects)
# Use arm function sim() to sample from posterior
chainsLmer = sim(lmerObj,n.sims=10000)

Compare estimates of variance

BF.sig2 <- chains[,colnames(chains)=="sig2"]
AG.sig2 <- (chainsLmer@sigma)^2
qqplot(log(BF.sig2),log(AG.sig2),pch=21,bg=rgb(0,0,1,.2),
       col=NULL,asp=TRUE,cex=1,xlab="BayesFactor samples",
       ylab="arm samples",main="Posterior samples of\nerror variance")
abline(0,1)

Compare estimates of participant effects:

AG.raneff <- chainsLmer@ranef$ID[,,1]
BF.raneff <-  chains[,grep('ID-',colnames(chains),fixed='TRUE')]
plot(colMeans(BF.raneff),colMeans(AG.raneff),pch=21,bg=rgb(0,0,1,.2),col="black",asp=TRUE,cex=1.2,xlab="BayesFactor estimate",ylab="arm estimate",main="Random effect posterior means")
abline(0,1)

Compare estimates of fixed effects:

AG.fixeff <- chainsLmer@fixef
BF.fixeff <-  chains[,1:10]

# Adjust AG results from reference cell to sum to 0
Z = c(1,  1/3,  1/3,  1/3,  1/3,  1/3,  1/3,
      0, -1/3, -1/3,    0,    0,    0,    0,
      0,  2/3, -1/3,    0,    0,    0,    0,
      0, -1/3,  2/3,    0,    0,    0,    0,
      0,     0,   0, -1/3, -1/3,    0,    0,
      0,     0,   0,  2/3, -1/3,    0,    0,
      0,     0,   0, -1/3,  2/3,    0,    0,
      0,     0,   0,    0,    0, -1/3, -1/3,
      0,     0,   0,    0,    0,  2/3, -1/3,
      0,     0,   0,    0,    0, -1/3,  2/3)
dim(Z) = c(7,10)
Z = t(Z)

AG.fixeff2 = t(Z%*%t(AG.fixeff))

## Our grand mean has heavier tails
qqplot(BF.fixeff[,1],AG.fixeff2[,1],pch=21,bg=rgb(0,0,1,.2),col=NULL,asp=TRUE,cex=1,xlab="BayesFactor estimate",ylab="arm estimate",main="Grand mean posterior samples")
abline(0,1)

plot(colMeans(BF.fixeff[,-1]),colMeans(AG.fixeff2[,-1]),pch=21,bg=rgb(0,0,1,.2),col="black",asp=TRUE,cex=1.2,xlab="BayesFactor estimate",ylab="arm estimate",main="Fixed effect posterior means")
abline(0,1)

## Compare posterior standard deviations
BFsd = apply(BF.fixeff[,-1],2,sd)
AGsd = apply(AG.fixeff2[,-1],2,sd)
plot(sort(AGsd/BFsd),pch=21,bg=rgb(0,0,1,.2),col="black",cex=1.2,ylab="Ratio of posterior standard deviations (arm/BF)",xlab="Fixed effect index")
## AG estimates are slightly larger, consistent with sig2 estimates
## probably due to prior

Another comparison with lmer

We begin by loading required packages...

library(languageR)
library(xtable)

...and creating the data set to analyze.

data(primingHeidPrevRT)

primingHeidPrevRT$lRTmin1 <- log(primingHeidPrevRT$RTmin1)

###Frequentist 

lr4 <- lmer(RT ~ Condition + (1|Word)+ (1|Subject) + lRTmin1 + RTtoPrime + ResponseToPrime + ResponseToPrime*RTtoPrime +BaseFrequency ,primingHeidPrevRT)
# Get rid rid of some outlying response times
INDOL <- which(scale(resid(lr4)) < 2.5)
primHeidOL <- primingHeidPrevRT[INDOL,]

The first thing we have to do is center the continuous variables. This is done automatically by lmBF(), as required by Liang et al. (2008). This, of course, changes the definition of the intercept.

# Center continuous variables
primHeidOL$BaseFrequency <- primHeidOL$BaseFrequency - mean(primHeidOL$BaseFrequency)
primHeidOL$lRTmin1 <- primHeidOL$lRTmin1 - mean(primHeidOL$lRTmin1)
primHeidOL$RTtoPrime <- primHeidOL$RTtoPrime - mean(primHeidOL$RTtoPrime)

Now we perform both analyses on the same data, and place the fixed effect estimates for both packages into their own vectors.

# LMER
lr4b <- lmer(  RT ~ Condition + ResponseToPrime +  (1|Word)+ (1|Subject) + lRTmin1 + RTtoPrime + ResponseToPrime*RTtoPrime + BaseFrequency , primHeidOL)
# BayesFactor
B5out <- lmBF( RT ~ Condition + ResponseToPrime +     Word +    Subject  + lRTmin1 + RTtoPrime + ResponseToPrime*RTtoPrime + BaseFrequency  , primHeidOL , whichRandom = c("Word", "Subject"),  posterior = TRUE, iteration = 50000,columnFilter=c("Word","Subject"))

lmerEff <- fixef(lr4b)
bfEff <- colMeans(B5out[,1:10])

lmer uses a "reference cell" parameterization, rather than imposing sum-to-0 constraints. We can tell what the reference cell is by looking at the parameter names.

print(xtable(cbind("lmer fixed effects"=names(lmerEff))), type='html')

Notice what's missing: for the categorical parameters, we are missing Conditionbaseheid and ResponseToPrimecorrect. For the slope parameters, we are missing ResponseToPrimecorrect:RTtoPrime. The missing effects tell us what the reference cells are. Since the reference cell parameterization is just a linear transformation of the sum-to-0 parameterization, we can create a matrix that allows us to move from one to the other. We call this $10 \times 7$ matrix Z. It takes the 7 "reference-cell" parameters from lmer and maps them into the 10 linearly constrained parameters from lmBF.

The first row of Z transforms the intercept (reference cell) to the grand mean (sum-to-0). We have to add half of the two fixed effects back into the intercept. The second and third row divide the totl effect of Condition into two equal parts, one for baseheid and one for heid. Rows four and five do the same for ResponseToPrime.

The slopes that do not enter into interactions are fine as they are; however, ResponseToPrimecorrect:RTtoPrime serves as our reference cell for the ResponseToPrime:RTtoPrime interaction. We treat these slopes analogously to the grand mean; we take RTtoPrime and add half the ResponseToPrimeincorrect:RTtoPrime effect to it, to make it a grand mean slope. The last two rows divide up the ResponseToPrimeincorrect:RTtoPrime effect between ResponseToPrimeincorrect:RTtoPrime and ResponseToPrimecorrect:RTtoPrime.

# Adjust lmer results from reference cell to sum to 0
Z = c(1,   1/2, 1/2,    0,    0,    0,    0,
      0,  -1/2,   0,    0,    0,    0,    0,
      0,   1/2,   0,    0,    0,    0,    0,
      0,     0,-1/2,    0,    0,    0,    0,
      0,     0, 1/2,    0,    0,    0,    0,
      0,     0,   0,    1,    0,    0,    0,
      0,     0,   0,    0,    1,    0,  1/2,
      0,     0,   0,    0,    0,    1,    0,
      0,     0,   0,    0,    0,    0, -1/2,
      0,     0,   0,    0,    0,    0,  1/2)
dim(Z) = c(7,10)
Z = t(Z)

# Do reparameterization by pre-multimplying the parameter vector by Z
reparLmer <- Z %*% matrix(lmerEff,ncol=1)

# put results in data.frame for comparison
sideBySide <- data.frame(BayesFactor=bfEff,lmer=reparLmer)

We can look at them side by side for comparison:

print(xtable(sideBySide,digits=4), type='html')

...and plot them:

# Notice Bayesian shrinkage
par(cex=1.5)
plot(sideBySide[-1,],pch=21,bg=rgb(0,0,1,.2),col="black",asp=TRUE,cex=1.2, main="fixed effects\n (excluding grand mean)")
abline(0,1, lty=2)