Interval kepercayaan pada prediksi untuk model campuran non-linear (nlme)

Saya ingin mendapatkan interval kepercayaan 95% pada prediksi nlmemodel campuran non-linear . Karena tidak ada standar yang disediakan untuk melakukan hal ini di dalam nlme, saya bertanya-tanya apakah benar menggunakan metode "interval prediksi populasi", sebagaimana diuraikan dalam bab buku Ben Bolker dalam konteks model yang sesuai dengan kemungkinan maksimum , berdasarkan pada gagasan resampling parameter efek tetap berdasarkan matriks varians-kovarian model pas, mensimulasikan prediksi berdasarkan ini, dan kemudian mengambil 95% persentil dari prediksi ini untuk mendapatkan interval kepercayaan 95%?

Kode untuk melakukan ini terlihat sebagai berikut: (Saya di sini menggunakan data 'Loblolly' dari nlmefile bantuan)

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

Sekarang saya memiliki batas kepercayaan diri saya membuat grafik:

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

Inilah plot dengan interval kepercayaan 95% yang diperoleh dengan cara ini:

Apakah pendekatan ini valid, atau adakah pendekatan lain atau yang lebih baik untuk menghitung interval kepercayaan 95% pada prediksi model campuran nonlinier? Saya tidak sepenuhnya yakin bagaimana cara menangani struktur efek acak model ... Haruskah satu rata-rata mungkin melebihi tingkat efek acak? Atau apakah boleh untuk memiliki interval kepercayaan untuk subjek rata-rata, yang tampaknya lebih dekat dengan apa yang saya miliki sekarang?

Apa yang Anda lakukan di sini terlihat masuk akal. Jawaban singkatnya adalah bahwa sebagian besar masalah prediksi interval kepercayaan dari model campuran dan dari model nonlinier lebih atau kurang ortogonal , yaitu, Anda perlu khawatir tentang kedua set masalah, tetapi mereka tidak (yang saya tahu dari) berinteraksi dengan cara yang aneh.

• Masalah model campuran : apakah Anda mencoba memprediksi pada tingkat populasi atau kelompok? Bagaimana Anda menjelaskan variabilitas dalam parameter efek-acak? Apakah Anda mengkondisikan pengamatan tingkat kelompok atau tidak?
• Masalah model nonlinear : apakah distribusi sampling dari parameter Normal? Bagaimana cara menjelaskan nonlinier saat menyebarkan galat?

Sepanjang, saya akan menganggap Anda memprediksi pada tingkat populasi dan membangun interval kepercayaan sebagai tingkat populasi - dengan kata lain Anda mencoba untuk merencanakan nilai prediksi dari khas kelompok, dan tidak termasuk variasi di antara kelompok dalam kepercayaan diri Anda interval. Ini menyederhanakan masalah model campuran. Plot berikut membandingkan tiga pendekatan (lihat di bawah untuk dump kode):

• interval prediksi populasi : ini adalah pendekatan yang Anda coba di atas. Ini mengasumsikan model itu benar dan bahwa distribusi sampling dari parameter efek tetap adalah multivariat Normal; itu juga mengabaikan ketidakpastian dalam parameter efek-acak
• bootstrap : Saya menerapkan bootstrap hierarkis; kami melakukan resample baik di tingkat grup maupun di dalam grup. Pengambilan sampel dalam kelompok sampel residu dan menambahkannya kembali ke prediksi. Pendekatan ini membuat asumsi paling sedikit.
• metode delta : ini mengasumsikan Normalitas multivariat dari distribusi sampel dan bahwa nonlinier cukup lemah untuk memungkinkan pendekatan orde kedua.

Kita juga bisa melakukan bootstrap parametrik ...

Berikut adalah CI yang diplot bersama dengan data ...

... tapi kita hampir tidak bisa melihat perbedaannya.

Memperbesar dengan mengurangi nilai yang diprediksi (merah = bootstrap, biru = PPI, cyan = metode delta)

Dalam hal ini interval bootstrap sebenarnya paling sempit (mis. Agaknya distribusi sampling dari parameter sebenarnya sedikit lebih tipis daripada Normal), sedangkan interval PPI dan metode delta sangat mirip satu sama lain.

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)