Ước tính các hiệu ứng ngẫu nhiên trong mô hình nhị thức (lme4)

Tôi đang mô phỏng các thử nghiệm Bernoulli với một giữa các nhóm và sau đó tôi khớp với mô hình tương ứng với các gói:$\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)

Sau đó, tôi so sánh tỷ lệ thành công theo nhóm với ước tính của họ và tôi luôn nhận được kết quả như vậy:

Theo " luôn luôn ", ý tôi là các ước tính glmer luôn cao hơn tỷ lệ thực nghiệm cho tỷ lệ nhỏ và luôn thấp hơn cho tỷ lệ cao. Ước tính glmer gần với tỷ lệ thực nghiệm cho các giá trị xung quanh tỷ lệ tổng thể ( trong ví dụ của tôi). Sau khi tăng sự khác biệt giữa ước tính và tỷ lệ trở nên không đáng kể nhưng người ta luôn có được bức ảnh này. Nó có phải là một thực tế được biết đến và tại sao nó giữ? Tôi dự kiến ​​sẽ có được ước tính tập trung xung quanh tỷ lệ thực nghiệm.$0.7$$J$

Những gì bạn đang thấy là một hiện tượng gọi là co rút , là một thuộc tính cơ bản của các mô hình hỗn hợp; ước tính nhóm riêng lẻ được "thu hẹp" đối với giá trị trung bình tổng thể như là một hàm của phương sai tương đối của mỗi ước tính. (Mặc dù co rút được thảo luận trong các câu trả lời khác nhau trên CrossValidated, hầu hết đều đề cập đến các kỹ thuật như hồi quy lasso hoặc sườn núi; câu trả lời cho câu hỏi này cung cấp các kết nối giữa các mô hình hỗn hợp và các quan điểm khác về co ngót.)

Co ngót là mong muốn; đôi khi nó được gọi là sức mạnh vay . Đặc biệt là khi chúng tôi có ít mẫu cho mỗi nhóm, các ước tính riêng biệt cho mỗi nhóm sẽ kém chính xác hơn so với ước tính tận dụng một số nhóm từ mỗi nhóm. Trong khuôn khổ Bayes hoặc theo kinh nghiệm Bayes, chúng ta có thể nghĩ rằng sự phân bố cấp độ dân số đóng vai trò như một ưu tiên cho các ước tính cấp độ nhóm. Ước tính co ngót đặc biệt hữu ích / mạnh mẽ khi ( không phải trong trường hợp này trong ví dụ này) lượng thông tin trên mỗi nhóm (cỡ mẫu / độ chính xác) rất khác nhau, ví dụ như trong một mô hình dịch tễ không gian nơi có các khu vực có dân số rất nhỏ và rất lớn .

Thuộc tính co ngót nên áp dụng cho cả hai cách tiếp cận phù hợp với Bayes và thường xuyên - sự khác biệt thực sự giữa các cách tiếp cận nằm ở cấp cao nhất ("tổng bình phương có trọng số bị phạt" của người thường xuyên là sự sai lệch log-postior của Bayes ở cấp độ nhóm ... ) Sự khác biệt chính trong hình dưới đây, cho thấy lme4và MCMCglmmkết quả, là bởi vì MCMCglmm sử dụng thuật toán ngẫu nhiên, các ước tính cho các nhóm khác nhau có cùng tỷ lệ quan sát được khác nhau một chút.

Với một chút công việc, tôi nghĩ rằng chúng ta có thể tìm ra mức độ co rút chính xác dự kiến ​​bằng cách so sánh phương sai nhị thức cho các nhóm và tập dữ liệu tổng thể, nhưng trong khi đó đây là một minh chứng (thực tế là trường hợp J = 10 trông ít hơn thu nhỏ hơn J = 20 chỉ là biến thể lấy mẫu, tôi nghĩ vậy). (Tôi vô tình thay đổi các tham số mô phỏng thành mean = 0,5, độ lệch chuẩn RE = 0,7 (theo thang đo 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)