二項モデル（lme4）の変量効果の推定

ランダムロジットでベルヌーイ試験をシミュレートしていますグループとの間で、私と対応するモデルフィットパッケージ：$\text{logit}\, \theta \sim {\cal N}(\text{logit}\, \theta_0, 1^2)$lme4

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)

次に、グループごとの成功率と推定値を比較すると、常にそのような結果が得られます。

$0.7$$J$

表示されているのは、収縮と呼ばれる現象です。これは、混合モデルの基本的な特性です。個々のグループの推定値は、各推定値の相対分散の関数として、全体の平均に向かって「縮小」されます。（収縮についてはCrossValidatedのさまざまな回答で説明されていますが、ほとんどは投げ縄または尾根回帰などの手法を指します。この質問への回答は、混合モデルと他の収縮のビューとの関連を提供します。）

収縮は間違いなく望ましいです。借用力とも呼ばれます。特に、グループあたりのサンプル数が少ない場合、各グループの個別の推定値は、各母集団からのプールを利用する推定値よりも正確ではなくなります。ベイジアンまたは経験的ベイジアンフレームワークでは、人口レベルの分布をグループレベルの推定値の事前分布として考えることができます。（この例ではそうではないが）グループごとの情報の量（サンプルサイズ/精度）が大きく変動する場合（たとえば、人口が非常に少ない地域と非常に多い地域がある空間疫学モデル）には、収縮の推定は特に有用/強力です。。

収縮特性は、ベイジアンと頻度主義の両方のフィッティングアプローチに適用する必要があります-アプローチ間の実際の違いはトップレベルにあります（頻度主義者の「ペナルティ付き加重残差平方和」は、グループレベルでのベイジアンの対数事後偏差です... ）結果lme4とMCMCglmm結果を示す以下の図の主な違いは、MCMCglmmが確率的アルゴリズムを使用しているため、観察された同じ比率の異なるグループの推定値がわずかに異なることです。

もう少し作業を進めることで、グループの二項分散と全体のデータセットを比較することで、予測される正確な収縮の程度を把握できると思いますが、それまでの間、デモンストレーションを行います（J = 10の場合はあまり見えないという事実） J = 20よりも縮小されているのは、単なるサンプリングの変動だと思います）。（誤ってシミュレーションパラメーターを平均= 0.5、RE標準偏差= 0.7（ロジットスケールで）に変更しました...）

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)