非線形混合モデル（nlme）の予測の信頼区間

非線形混合nlmeモデルの予測で95％の信頼区間を取得したいと思います。内nlmeでこれを行うための標準は何も提供されていないので、Ben Bolkerの本の章で説明されている「人口予測間隔」の方法を使用するのが正しいかどうか疑問に思いました。適合モデルの分散共分散行列に基づいて固定効果パラメーターをリサンプリングし、これに基づいて予測をシミュレートし、これらの予測の95％パーセンタイルを取得して95％の信頼区間を取得しますか？

これを行うためのコードは次のようになります：（ここでは、nlmeヘルプファイルの「Loblolly」データを使用します）

library(effects)
library(nlme)
library(MASS)

fm1 <- nlme(height ~ SSasymp(age, Asym, R0, lrc),
    data = Loblolly,
    fixed = Asym + R0 + lrc ~ 1,
    random = Asym ~ 1,
    start = c(Asym = 103, R0 = -8.5, lrc = -3.3))

xvals=seq(min(Loblolly$age),max(Loblolly$age),length.out=100)
nresamp=1000
pars.picked = mvrnorm(nresamp, mu = fixef(fm1), Sigma = vcov(fm1)) # pick new parameter values by sampling from multivariate normal distribution based on fit
yvals = matrix(0, nrow = nresamp, ncol = length(xvals))

for (i in 1:nresamp) 
{
    yvals[i,] = sapply(xvals,function (x) SSasymp(x,pars.picked[i,1], pars.picked[i,2], pars.picked[i,3]))
} 

quant = function(col) quantile(col, c(0.025,0.975)) # 95% percentiles
conflims = apply(yvals,2,quant) # 95% confidence intervals

信頼限界があるので、グラフを作成します。

meany = sapply(xvals,function (x) SSasymp(x,fixef(fm1)[[1]], fixef(fm1)[[2]], fixef(fm1)[[3]]))

par(cex.axis = 2.0, cex.lab=2.0)
plot(0, type='n', xlim=c(3,25), ylim=c(0,65), axes=F, xlab="age", ylab="height");
axis(1, at=c(3,1:5 * 5), labels=c(3,1:5 * 5)) 
axis(2, at=0:6 * 10, labels=0:6 * 10)   

for(i in 1:14)
{
    data = subset(Loblolly, Loblolly$Seed == unique(Loblolly$Seed)[i])   
    lines(data$age, data$height, col = "red", lty=3)
}

lines(xvals,meany, lwd=3)
lines(xvals,conflims[1,])
lines(xvals,conflims[2,])

この方法で得られた95％信頼区間のプロットは次のとおりです。

このアプローチは有効ですか、または非線形混合モデルの予測で95％の信頼区間を計算する他の、またはより良いアプローチがありますか？モデルのランダム効果の構造をどのように扱うか完全にはわかりません...おそらくランダム効果レベルを超えて平均する必要がありますか？または、平均的な被験者に信頼区間を設定しても大丈夫でしょうか？

ここで行ったことは合理的です。簡単な答えは、ほとんどの場合、混合モデルと非線形モデルから信頼区間を予測する問題は多かれ少なかれ直交するということです。つまり、両方の問題を心配する必要がありますが、私は知っていますof）奇妙な方法で相互作用します。

• 混合モデルの問題：集団またはグループレベルで予測しようとしていますか？変量効果パラメーターの変動をどのように考慮しますか？グループレベルの観測を条件にしていますか？
• 非線形モデルの問題：パラメーターのサンプリング分布は正規ですか？エラーを伝播するときに非線形性を考慮するにはどうすればよいですか？

全体を通して、母集団レベルで予測し、母集団レベルとして信頼区間を構築していると仮定します-つまり、典型的なグループの予測値をプロットしようとしていますが、グループ間の変動は信頼に含めません間隔。これにより、混合モデルの問題が簡素化されます。次のプロットは、3つのアプローチを比較しています（コードダンプについては以下を参照）。

• 人口予測間隔：これは上で試したアプローチです。モデルが正しく、固定効果パラメーターのサンプリング分布が多変量正規であると想定しています。また、変量効果パラメーターの不確実性も無視します
• ブートストラップ：階層的なブートストラップを実装しました。グループレベルとグループ内の両方でリサンプリングします。グループ内サンプリングは、残差をし、予測に追加します。このアプローチでは、仮定が最も少なくなります。
• デルタ法：これは、サンプリング分布の多変量正規性と、2次近似を可能にするほど非線形性が弱いことを前提としています。

私たちもできる パラメトリックブートストラップをます...

以下は、データとともにプロットされたCIです...

...しかし、我々はほとんど違いを見ることができません。

予測値を差し引くことでズームイン（赤=ブートストラップ、青= PPI、シアン=デルタ法）

この場合、ブートストラップ間隔は実際に最も狭くなります（たとえば、パラメーターのサンプリング分布は実際には通常よりもわずかに薄いテールになります）が、PPIとデルタ法の間隔は互いに非常に似ています。

library(nlme)
library(MASS)

fm1 <- nlme(height ~ SSasymp(age, Asym, R0, lrc),
            data = Loblolly,
            fixed = Asym + R0 + lrc ~ 1,
            random = Asym ~ 1,
            start = c(Asym = 103, R0 = -8.5, lrc = -3.3))

xvals <-  with(Loblolly,seq(min(age),max(age),length.out=100))
nresamp <- 1000
## pick new parameter values by sampling from multivariate normal distribution based on fit
pars.picked <- mvrnorm(nresamp, mu = fixef(fm1), Sigma = vcov(fm1))

## predicted values: useful below
pframe <- with(Loblolly,data.frame(age=xvals))
pframe$height <- predict(fm1,newdata=pframe,level=0)

## utility function
get_CI <- function(y,pref="") {
    r1 <- t(apply(y,1,quantile,c(0.025,0.975)))
    setNames(as.data.frame(r1),paste0(pref,c("lwr","upr")))
}

set.seed(101)
yvals <- apply(pars.picked,1,
               function(x) { SSasymp(xvals,x[1], x[2], x[3]) }
)
c1 <- get_CI(yvals)

## bootstrapping
sampfun <- function(fitted,data,idvar="Seed") {
    pp <- predict(fitted,levels=1)
    rr <- residuals(fitted)
    dd <- data.frame(data,pred=pp,res=rr)
    ## sample groups with replacement
    iv <- levels(data[[idvar]])
    bsamp1 <- sample(iv,size=length(iv),replace=TRUE)
    bsamp2 <- lapply(bsamp1,
        function(x) {
        ## within groups, sample *residuals* with replacement
        ddb <- dd[dd[[idvar]]==x,]
        ## bootstrapped response = pred + bootstrapped residual
        ddb$height <- ddb$pred +
            sample(ddb$res,size=nrow(ddb),replace=TRUE)
        return(ddb)
    })
    res <- do.call(rbind,bsamp2)  ## collect results
    if (is(data,"groupedData"))
        res <- groupedData(res,formula=formula(data))
    return(res)
}

pfun <- function(fm) {
    predict(fm,newdata=pframe,level=0)
}

set.seed(101)
yvals2 <- replicate(nresamp,
                    pfun(update(fm1,data=sampfun(fm1,Loblolly,"Seed"))))
c2 <- get_CI(yvals2,"boot_")

## delta method
ss0 <- with(as.list(fixef(fm1)),SSasymp(xvals,Asym,R0,lrc))
gg <- attr(ss0,"gradient")
V <- vcov(fm1)
delta_sd <- sqrt(diag(gg %*% V %*% t(gg)))
c3 <- with(pframe,data.frame(delta_lwr=height-1.96*delta_sd,
                             delta_upr=height+1.96*delta_sd))

pframe <- data.frame(pframe,c1,c2,c3)

library(ggplot2); theme_set(theme_bw())
ggplot(Loblolly,aes(age,height))+
    geom_line(alpha=0.2,aes(group=Seed))+
    geom_line(data=pframe,col="red")+
    geom_ribbon(data=pframe,aes(ymin=lwr,ymax=upr),colour=NA,alpha=0.3,
                fill="blue")+
    geom_ribbon(data=pframe,aes(ymin=boot_lwr,ymax=boot_upr),
                colour=NA,alpha=0.3,
                fill="red")+
    geom_ribbon(data=pframe,aes(ymin=delta_lwr,ymax=delta_upr),
                colour=NA,alpha=0.3,
                fill="cyan")


ggplot(Loblolly,aes(age))+
    geom_hline(yintercept=0,lty=2)+
    geom_ribbon(data=pframe,aes(ymin=lwr-height,ymax=upr-height),
                colour="blue",
                fill=NA)+
    geom_ribbon(data=pframe,aes(ymin=boot_lwr-height,ymax=boot_upr-height),
                colour="red",
                fill=NA)+
    geom_ribbon(data=pframe,aes(ymin=delta_lwr-height,ymax=delta_upr-height),
                colour="cyan",
                fill=NA)