変量効果ロジスティック回帰の不審に高い収縮

次の簡単な例を考えます。

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 )

つまり、同じ非常に単純な問題（ロジスティック回帰、切片のみ）に対して固定効果と変量効果モデルを与えています。

固定効果モデルは次のようになります。

plot( summary( fitFE ) )

そしてこれはどのようにランダムな効果です：

dotplot( ranef( fitRE, condVar = TRUE ) )

収縮自体は驚くべきことではありませんが、その程度は驚くべきものです。以下は、より直接的な比較です。

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 ) )

固定効果の推定値は3％未満から11を超える範囲ですが、変量効果は7.5〜9.5％です。（共変量を含めると、これはさらに極端になります。）

私はロジスティック回帰における変量効果の専門家ではありませんが、線形回帰から、非常に小さなグループサイズからのみかなりの縮小が発生する可能性があるという印象を受けました。ただし、ここでは、最小グループでもほぼ100の観測値があり、サンプルサイズは500を超えます。

これの理由は何ですか？または私は何かを見落としているか...？

編集（2017年7月28日）。@Ben Bolkerの提案に従って、応答が連続的である場合に何が起こるかを試しました（これにより、二項データに固有の有効なサンプルサイズに関する問題が削除されます）。

SimDataしたがって、新しい

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 ) )

そして新しいモデルは

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

結果は

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

です

ここまでは順調ですね！

しかし、私は別のチェックを実行してベンのアイデアを検証することにしましたが、結果はかなり奇妙であることがわかりました。理論を別の方法で確認することにしました。バイナリの結果に戻りますが、有効なサンプルサイズが大きくなるように平均を増やします。私は単に実行してparams$means <- params$means + 0.5から元の例を再試行しました、これが結果です：

最小（有効）サンプルサイズにもかかわらず、実際に大幅に増加しています...

> 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 

...実際に収縮が増加しました！（合計となり、ゼロ分散が推定されます。）

ここでの答えは「効果的なサンプルサイズ」の定義に関係しているのではないかと思います。経験則（ハレルの回帰モデリング戦略の本から）は、ベルヌーイ変数の効果的なサンプルサイズは成功と失敗の最小数であるということです。例えば、わずか4成功とサイズ10,000サンプルがよりようなものであり、以外。ここでの有効なサンプルサイズは小さくありませんが、観測数よりもはるかに小さくなっています。n = 10 $n=4$$n=10^4$

グループあたりの効果的なサンプルサイズ：

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 

グループあたりのサンプルサイズ：

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 

この説明をテストする1つの方法は、連続的に変化する（ガン​​マまたはガウス）応答で類似の例を実行することです。