Doğrusal olmayan karma bir model için tahminlerde güven aralıkları (nlme)

Doğrusal olmayan karışık bir nlmemodelin tahminlerinde% 95 güven aralığı elde etmek istiyorum . Bunu yapmak için standart bir şey sağlanmadığı için , Ben Bolker'ın kitap bölümünde maksimum olasılıkla uygun modeller bağlamında belirtildiğinlme gibi "nüfus tahmin aralıkları" yöntemini kullanmanın doğru olup olmadığını merak ediyordum . takılan modelin varyans-kovaryans matrisine dayalı sabit etki parametrelerini yeniden örneklemek, buna dayalı tahminleri simüle etmek ve daha sonra% 95 güven aralıkları elde etmek için bu tahminlerin% 95 persantilini almak?

Bunu yapmak için kod aşağıdaki gibi görünüyor: (Ben burada nlmeyardım dosyasından 'Loblolly' verileri kullanın )

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

Artık güven sınırlarım olduğuna göre bir grafik oluşturuyorum:

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

İşte bu şekilde elde edilen% 95 güven aralıklı grafik:

Bu yaklaşım geçerli mi veya doğrusal olmayan karma bir modelin tahminlerinde% 95 güven aralığını hesaplamak için başka veya daha iyi yaklaşımlar var mı? Modelin rastgele etki yapısıyla nasıl başa çıkacağından tam olarak emin değilim ... Biri belki de rastgele etki seviyelerinin üzerinde olmalı mı? Ya da şu an sahip olduğum şeye daha yakın gibi görünen ortalama bir konu için güven aralıklarına sahip olmak uygun olur mu?

Burada yaptıklarınız makul görünüyor. Kısa cevap, çoğunlukla karışık modellerden ve doğrusal olmayan modellerden güven aralıklarını tahmin etme konularının az çok dikey olduğu , yani her iki sorun kümesi için endişelenmeniz gerektiğidir, ancak bilmiyorlar (biliyorum herhangi bir garip yolla etkileşim.

• Karışık model sorunları : Nüfus veya grup düzeyinde tahmin etmeye çalışıyorsunuz? Rastgele etkiler parametrelerindeki değişkenliği nasıl değerlendiriyorsunuz? Grup düzeyinde gözlemleri şartlandırıyor musunuz?
• Doğrusal olmayan model sorunları : Parametrelerin örnekleme dağılımı Normal mi? Hata yayılırken doğrusal olmama durumunu nasıl hesaplarım?

Boyunca, nüfus düzeyinde tahmin yaptığınızı ve nüfus aralığı olarak güven aralıkları oluşturduğunuzu varsayacağım - diğer bir deyişle , güveniniz arasında gruplar arası varyasyonu içermeyen tipik bir grubun tahmin edilen değerlerini çizmeye çalışıyorsunuz. aralıkları. Bu, karma model sorunlarını basitleştirir. Aşağıdaki grafikler üç yaklaşımı karşılaştırır (kod dökümü için aşağıya bakın):

• nüfus tahmin aralıkları : yukarıda denediğiniz yaklaşım budur. Modelin doğru olduğunu ve sabit etki parametrelerinin örnekleme dağılımlarının çok değişkenli Normal olduğunu varsayar; rastgele etkiler parametrelerindeki belirsizliği de göz ardı eder
• bootstrapping : Hiyerarşik bootstrapping uyguladım; hem gruplar düzeyinde hem de gruplar içinde yeniden örnekleme yapıyoruz. Grup içi örnekleme, kalıntıları örnekler ve tahminlere geri ekler. Bu yaklaşım en az varsayımı yapar.
• delta yöntemi : Bu, hem çok değişkenli örnekleme dağılımlarının normalliğini hem de doğrusal olmama durumunun ikinci dereceden bir yaklaşıma izin verecek kadar zayıf olduğunu varsayar.

Ayrıca parametrik önyükleme yapabiliriz ...

İşte verilerle birlikte çizilen CI'lar ...

... ama farkları pek göremiyoruz.

Tahmin edilen değerleri çıkararak yakınlaştırma (kırmızı = önyükleme, mavi = PPI, cam göbeği = delta yöntemi)

Bu durumda, önyükleme aralıkları aslında en kısadır (örneğin, parametrelerin örnekleme dağılımları aslında Normalden biraz daha ince kuyrukludur ), PPI ve delta yöntemi aralıkları birbirine çok benzerdir.

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)