Perkiraan efek acak dalam model binomial (lme4)

Saya mensimulasikan uji coba Bernoulli dengan acak $\text{logit}\, \theta \sim {\cal N}(\text{logit}\, \theta_0, 1^2)$antara kelompok dan kemudian saya cocokkan dengan model yang sesuai dengan lme4paket:

library(lme4)
library(data.table)
I <- 30 # number of groups
J <- 10 # number of Bernoulli trials within each group
logit <- function(p) log(p)-log(1-p)
expit <- function(x) exp(x)/(1+exp(x))
theta0 <- 0.7
ddd <- data.table(subject=factor(1:I),logittheta=rnorm(I, logit(theta0)))[, list(result=rbinom(J, 1, expit(logittheta))), by=subject]
fit <- glmer(result~(1|subject), data=ddd, family="binomial")
props <- ddd[, list(p=mean(result)), by=subject]$p
estims <- expit(coef(fit)$subject[,1])
par(pty="s")
plot(props, estims, asp=1, xlim=c(0,1), ylim=c(0,1),
     xlab="proportion", ylab="glmer estimate")
abline(0,1)

Lalu saya membandingkan proporsi keberhasilan berdasarkan kelompok dengan perkiraan mereka dan saya selalu mendapatkan hasil seperti itu:

Dengan " selalu ", maksud saya bahwa estimasi glmer selalu lebih tinggi daripada proporsi empiris untuk proporsi kecil, dan selalu lebih rendah untuk proporsi tinggi. Estimasi glmer dekat dengan proporsi empiris untuk nilai-nilai di sekitar proporsi keseluruhan ($0.7$dalam contoh saya). Setelah meningkat$J$perbedaan antara perkiraan dan proporsi menjadi diabaikan tetapi kita selalu mendapatkan gambaran ini. Apakah itu fakta yang diketahui dan mengapa itu berlaku? Saya berharap mendapatkan perkiraan yang berpusat di sekitar proporsi empiris.

Apa yang Anda lihat adalah fenomena yang disebut penyusutan , yang merupakan sifat dasar dari model campuran; perkiraan kelompok individu "menyusut" ke arah rata-rata keseluruhan sebagai fungsi dari varians relatif dari masing-masing perkiraan. (Sementara susut dibahas dalam berbagai jawaban tentang CrossValidated, sebagian besar merujuk pada teknik seperti laso atau regresi ridge; jawaban untuk pertanyaan ini menyediakan koneksi antara model campuran dan pandangan lain tentang susut.)

Penyusutan bisa dibilang diinginkan; kadang-kadang disebut kekuatan meminjam . Terutama ketika kami memiliki beberapa sampel per kelompok, perkiraan terpisah untuk masing-masing kelompok akan menjadi kurang tepat dari perkiraan yang memanfaatkan beberapa pengumpulan dari setiap populasi. Dalam kerangka Bayesian atau empiris Bayesian, kita dapat menganggap distribusi tingkat populasi bertindak sebagai pendahuluan untuk estimasi tingkat kelompok. Perkiraan susut sangat berguna / kuat ketika (seperti tidak terjadi di contoh ini) jumlah informasi per kelompok (ukuran sampel / presisi) bervariasi, misalnya dalam model epidemiologi spasial di mana ada daerah dengan populasi yang sangat kecil dan sangat besar .

Properti susut harus berlaku untuk pendekatan pemasangan Bayesian dan sering - perbedaan nyata antara pendekatan terletak di tingkat atas ("kuadrat jumlah residu tertimbang kuadrat" yang sering terjadi adalah penyimpangan log-posterior Bayesian di tingkat kelompok ... ) Perbedaan utama pada gambar di bawah ini, yang menunjukkan lme4dan MCMCglmmhasil, adalah bahwa karena MCMCglmm menggunakan algoritma stokastik estimasi untuk kelompok yang berbeda dengan proporsi yang diamati sama sedikit berbeda.

Dengan sedikit lebih banyak pekerjaan, saya pikir kita bisa mengetahui tingkat penyusutan yang diharapkan dengan membandingkan varian binomial untuk kelompok dan kumpulan data keseluruhan, tetapi sementara itu di sini adalah demonstrasi (fakta bahwa kasus J = 10 terlihat kurang menyusut dari J = 20 hanyalah variasi sampel, saya pikir). (Saya tidak sengaja mengubah parameter simulasi menjadi = 0,5, standar deviasi RE = 0,7 (pada skala logit) ...)

library("lme4")
library("MCMCglmm")
##' @param I number of groups
##' @param J number of Bernoulli trials within each group
##' @param theta random effects standard deviation (logit scale)
##' @param beta intercept (logit scale)
simfun <- function(I=30,J=10,theta=0.7,beta=0,seed=NULL) {
    if (!is.null(seed)) set.seed(seed)
    ddd <- expand.grid(subject=factor(1:I),rep=1:J)
    ddd <- transform(ddd,
                     result=suppressMessages(simulate(~1+(1|subject),
                     family=binomial,
                     newdata=ddd,
                     newparams=list(theta=theta,beta=beta))[[1]]))
}
sumfun <- function(ddd) {
    fit <- glmer(result~(1|subject), data=ddd, family="binomial")
    fit2 <- MCMCglmm(result~1,random=~subject, data=ddd,
                    family="categorical",verbose=FALSE,
                    pr=TRUE)
    res <- data.frame(
        props=with(ddd,tapply(result,list(subject),mean)),
        lme4=plogis(coef(fit)$subject[,1]),
        MCMCglmm=plogis(colMeans(fit2$Sol[,-1])))
    return(res)
}
set.seed(101)
res <- do.call(rbind,
        lapply(c(10,20,50,100,500),
               function(J) {
                   data.frame(J=J,sumfun(simfun(J=J)))
               }))
library("reshape2")
m <- melt(res,id.vars=c("J","props"))
library("ggplot2"); theme_set(theme_bw())
ggplot(m,aes(props,value))+
    geom_point(aes(colour=factor(J),shape=variable))+
    geom_abline(intercept=0,slope=1,colour="gray")+
      labs(x="observed proportion",y="estimate")
ggsave("shrinkage.png",width=5,height=5)