Estimaciones de efectos aleatorios en modelo binomial (lme4)

Estoy simulando ensayos de Bernoulli con un entre grupos y luego el modelo correspondiente con el paquete:$\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)

Luego comparo las proporciones de éxitos por grupo con sus estimaciones y siempre obtengo ese resultado:

Por " siempre ", quiero decir que las estimaciones de glmer son siempre más altas que las proporciones empíricas para pequeñas proporciones, y siempre más bajas para altas proporciones. La estimación de glmer está cerca de la proporción empírica para valores alrededor de la proporción general ( en mi ejemplo). Después de aumentar la diferencia entre las estimaciones y las proporciones se vuelve insignificante, pero siempre se obtiene esta imagen. ¿Es un hecho conocido y por qué es válido? Esperaba obtener estimaciones centradas en las proporciones empíricas.$0.7$$J$

Lo que está viendo es un fenómeno llamado contracción , que es una propiedad fundamental de los modelos mixtos; las estimaciones grupales individuales se "reducen" hacia la media general en función de la varianza relativa de cada estimación. (Si bien la contracción se discute en varias respuestas en CrossValidated, la mayoría se refiere a técnicas como el lazo o la regresión de cresta; las respuestas a esta pregunta proporcionan conexiones entre modelos mixtos y otras vistas de contracción).

La contracción es posiblemente deseable; a veces se le llama fuerza de endeudamiento . Especialmente cuando tenemos pocas muestras por grupo, las estimaciones separadas para cada grupo serán menos precisas que las estimaciones que aprovechan algunas agrupaciones de cada población. En un marco bayesiano bayesiano o empírico, podemos pensar que la distribución a nivel de población actúa como un previo para las estimaciones a nivel de grupo. Las estimaciones de contracción son especialmente útiles / poderosas cuando (como no es el caso en este ejemplo) la cantidad de información por grupo (tamaño de muestra / precisión) varía ampliamente, por ejemplo, en un modelo epidemiológico espacial donde hay regiones con poblaciones muy pequeñas y muy grandes .

La propiedad de contracción debería aplicarse tanto a los enfoques de ajuste bayesiano como a los frecuentistas: las diferencias reales entre los enfoques se encuentran en el nivel superior (la "suma de cuadrados residuales ponderados penalizados del frecuentista" es la desviación log-posterior bayesiana a nivel de grupo ... ) La principal diferencia en la imagen a continuación, que muestra lme4y MCMCglmmresultados, es que debido a que MCMCglmm usa un algoritmo estocástico, las estimaciones para diferentes grupos con las mismas proporciones observadas difieren ligeramente.

Con un poco más de trabajo, creo que podríamos determinar el grado preciso de contracción esperado al comparar las variaciones binomiales para los grupos y el conjunto de datos en general, pero mientras tanto aquí hay una demostración (el hecho de que el caso J = 10 parece menos reducido que J = 20 es solo una variación de muestreo, creo). (Accidentalmente cambié los parámetros de simulación a media = 0.5, desviación estándar RE = 0.7 (en la escala 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)