Co ngót đáng ngờ cao trong hồi quy logistic hiệu ứng ngẫu nhiên

Hãy xem xét ví dụ đơn giản sau:

library( rms )
library( lme4 )
params <- structure(list(Ns = c(181L, 191L, 147L, 190L, 243L, 164L, 83L, 
                            383L, 134L, 238L, 528L, 288L, 214L, 502L, 307L, 302L, 199L, 156L, 
                            183L), means = c(0.09, 0.05, 0.03, 0.06, 0.07, 0.07, 0.1, 0.1, 
                                             0.06, 0.11, 0.1, 0.11, 0.07, 0.11, 0.1, 0.09, 0.1, 0.09, 0.08
                            )), .Names = c("Ns", "means"), row.names = c(NA, -19L), class = "data.frame")
SimData <- data.frame( ID = as.factor( rep( 1:nrow( params ), params$Ns ) ),
                   Res = do.call( c, apply( params, 1, function( x ) c( rep( 0, x[ 1 ]-round( x[ 1 ]*x[ 2 ] ) ),
                                                                        rep( 1, round( x[ 1 ]*x[ 2 ] ) ) ) ) ) )
tapply( SimData$Res, SimData$ID, mean )
dd <- datadist( SimData )
options( datadist = "dd" )
fitFE <- lrm( Res ~  ID, data = SimData )
fitRE <- glmer( Res ~ ( 1|ID ), data = SimData, family = binomial( link = logit ), nAGQ = 50 )

Tức là chúng tôi đang đưa ra một hiệu ứng cố định và một mô hình hiệu ứng ngẫu nhiên cho cùng một vấn đề rất đơn giản (hồi quy logistic, chỉ chặn).

Đây là cách mô hình hiệu ứng cố định trông như thế nào:

plot( summary( fitFE ) )

Và đây là cách hiệu ứng ngẫu nhiên:

dotplot( ranef( fitRE, condVar = TRUE ) )

Sự co lại không phải là đáng ngạc nhiên, nhưng mức độ của nó là. Đây là một so sánh trực tiếp hơn:

xyplot( plogis(fe)~plogis(re),
    data = data.frame( re = coef( fitRE )$ID[ , 1 ],
                       fe = c( 0, coef( fitFE )[ -1  ] )+coef( fitFE )[ 1 ] ),
    abline = c( 0, 1 ) )

Các ước tính hiệu ứng cố định nằm trong khoảng từ ít hơn 3% đến hơn 11, tuy nhiên, các hiệu ứng ngẫu nhiên nằm trong khoảng từ 7,5 đến 9,5%. (Bao gồm các đồng biến làm cho điều này thậm chí còn cực đoan hơn.)

Tôi không phải là chuyên gia về hiệu ứng ngẫu nhiên trong hồi quy logistic, nhưng từ hồi quy tuyến tính, tôi có ấn tượng rằng sự co rút đáng kể chỉ có thể xảy ra từ các kích thước nhóm rất nhỏ. Tuy nhiên, ở đây, ngay cả nhóm nhỏ nhất cũng có gần một trăm quan sát và kích thước mẫu vượt quá 500.

Lý do cho điều này là gì? Hay tôi đang nhìn thứ gì đó ...?

EDIT (ngày 28 tháng 7 năm 2017). Theo đề xuất của @Ben Bolker, tôi đã thử điều gì xảy ra nếu phản hồi liên tục (để chúng tôi loại bỏ các vấn đề về kích thước mẫu hiệu quả , cụ thể cho dữ liệu nhị thức).

Cái mới SimDatalà do đó

SimData <- data.frame( ID = as.factor( rep( 1:nrow( params ), params$Ns ) ),
                   Res = do.call( c, apply( params, 1, function( x ) c( rep( 0, x[ 1 ]-round( x[ 1 ]*x[ 2 ] ) ),
                                                                        rep( 1, round( x[ 1 ]*x[ 2 ] ) ) ) ) ),
                   Res2 = do.call( c, apply( params, 1, function( x ) rnorm( x[1], x[2], 0.1 ) ) ) )
data.frame( params, Res = tapply( SimData$Res, SimData$ID, mean ), Res2 = tapply( SimData$Res2, SimData$ID, mean ) )

và các mô hình mới là

fitFE2 <- ols( Res2 ~ ID, data = SimData )
fitRE2 <- lmer( Res2 ~ ( 1|ID ), data = SimData )

Kết quả với

xyplot( fe~re, data = data.frame( re = coef( fitRE2 )$ID[ , 1 ],
                       fe = c( 0, coef( fitFE2 )[ -1  ] )+coef( fitFE2 )[ 1 ] ),
    abline = c( 0, 1 ) )

Là

Càng xa càng tốt!

Tuy nhiên, tôi quyết định thực hiện một kiểm tra khác để xác minh ý tưởng của Ben, nhưng kết quả hóa ra khá kỳ quái. Tôi quyết định kiểm tra lý thuyết theo một cách khác: tôi trở lại kết quả nhị phân, nhưng tăng phương tiện để kích thước mẫu hiệu quả trở nên lớn hơn. Tôi chỉ đơn giản là chạy params$means <- params$means + 0.5và sau đó thử lại ví dụ ban đầu, đây là kết quả:

Mặc dù kích thước mẫu tối thiểu (hiệu quả) thực sự tăng mạnh ...

> summary(with(SimData,tapply(Res,list(ID),
+                             function(x) min(sum(x==0),sum(x==1)))))
Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
33.0    72.5    86.0   100.3   117.5   211.0 

... sự co lại thực sự tăng lên ! (Trở thành tổng số, với phương sai bằng không ước tính.)

$n=4$$n=10^4$

Cỡ mẫu hiệu quả cho mỗi nhóm:

summary(with(SimData,tapply(Res,list(ID),
                      function(x) min(sum(x==0),sum(x==1)))))
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   4.00   11.00   16.00   21.63   29.00   55.00 

Cỡ mẫu cho mỗi nhóm:

summary(c(table(SimData$ID)))
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   83.0   172.5   199.0   243.8   295.0   528.0 

Một cách để kiểm tra lời giải thích này là làm một ví dụ tương tự với các phản ứng thay đổi liên tục (Gamma hoặc Gaussian).