tests/comparisons/wheelReinvention.R

In merTools: Tools for Analyzing Mixed Effect Regression Models

#What exactly are the values spit out by fitted(sim(merMod), merMod)???
#Does it produce what we are trying to produce with predictInterval?

#The answer is no because it doesn't re-sample the RFX (I am fairly certain)
#The following does show the arm::sim() side-by-side with our method.  It looks
#like the effect of the differences is that our within-group regression lines are
#closer to the population average regression line.

library(arm); library(abind); library(mvtnorm);
set.seed(95371)

data(sleepstudy)

model <- lmer(Reaction ~ Days + (Days|Subject), data=sleepstudy)

#Take 5 simulations
test.sim <- sim(model, 1000)

#Display simulated coefs
#coef(test.sim)
ranef.array <- coef(test.sim)$ranef[[1]]
fixef.matrix <- coef(test.sim)$fixef

#Expand and permute fixefs to conform to ranefs for elementwise addition
dim(ranef.array)
dim(fixef.matrix)

#For now do it by hand
fixef.array <- array(data = rep(fixef.matrix, dim(ranef.array)[2]),
                     dim  = c(dim(fixef.matrix), dim(ranef.array)[2]))
fixef.array <- aperm(fixef.array, c(1,3,2))
dim(fixef.array)

combo.array <- fixef.array+ranef.array

#Extract model.matrix for our own multiplication
model.matrix <- lFormula(model@call, data=model@frame)$X
dim(model.matrix)
expanded.combo.array <- combo.array[,model@flist[[1]],]
expanded.combo.array <- aperm(expanded.combo.array, c(3,2,1))

#Matrix multiplication with arrays ???

##The following yeilds a 180x180 matrix for each prediction because I have
##multiplied ALL obs by ALL possible group coefficients
myCalc.large <- abind(
                  lapply(1:dim(expanded.combo.array)[3],
                         function(i) model.matrix %*% expanded.combo.array[,,i]),
                  along=3)

##I only need the diagonal of each 180x180 matrix so we get the value of
##the values for obs i and the coefficients for obs i
myCalc <- abind(lapply(1:dim(myCalc.large)[3],
                       function(x) diag(myCalc.large[,,x])), along=2)

isTRUE(all.equal(myCalc,fitted(test.sim, model), check.attributes=FALSE))

##Compare with predictInterval()
checkPI <- predictInterval(model, sleepstudy, nsim = 1000, predict="link")$yhat

myCalc.lwr <- apply(myCalc,1,function(x) as.numeric(quantile(x, .025)))
myCalc.fit <- apply(myCalc,1,function(x) as.numeric(quantile(x, .500)))
myCalc.upr <- apply(myCalc,1,function(x) as.numeric(quantile(x, .975)))

checkPI.lwr <- apply(checkPI,1,function(x) as.numeric(quantile(x, .025)))
checkPI.fit <- apply(checkPI,1,function(x) as.numeric(quantile(x, .500)))
checkPI.upr <- apply(checkPI,1,function(x) as.numeric(quantile(x, .975)))

plot.data <- rbind(
               data.frame(model="Arm.sim",
                          x=(1:180)-.15,
                          lwr=myCalc.lwr,
                          fit=myCalc.fit,
                          upr=myCalc.upr),
               data.frame(model="predictInterval",
                          x=(1:180)+.15,
                          lwr=checkPI.lwr,
                          fit=checkPI.fit,
                          upr=checkPI.upr))

ggplot(aes(x=x, y=fit, ymin=lwr, ymax=upr, color=model, position="dodge"), data=plot.data) +
geom_point() +
geom_linerange()

library(dplyr)
calc.sigma <- sqrt(1/rgamma(1000, 0.5*lme4:::df.residual.merMod(model), 0.5*getME(model, "devcomp")$cmp[["pwrss"]]))
sim.sigma <- test.sim@sigma
data.frame(
  model=c(rep("ARM",1000),rep("Carl",1000)),
  sigma=c(sim.sigma, calc.sigma)
  ) %>%
  qplot(sigma, color=model, data=., geom="density")