Intervalli di confidenza sulle previsioni per un modello misto non lineare (nlme)

Vorrei ottenere intervalli di confidenza al 95% sulle previsioni di un nlmemodello misto non lineare . Dato che non viene fornito nulla di standard per farlo all'interno di questo nlme, mi chiedevo se fosse corretto utilizzare il metodo degli "intervalli di previsione della popolazione", come indicato nel capitolo del libro di Ben Bolker nel contesto di modelli adatti alla massima probabilità , basati sull'idea di ricampionamento dei parametri degli effetti fissi in base alla matrice varianza-covarianza del modello adattato, simulando previsioni basate su questo, e quindi prendendo i percentili al 95% di queste previsioni per ottenere gli intervalli di confidenza al 95%?

Il codice per fare ciò appare come segue: (Qui uso i dati "Loblolly" dal nlmefile della guida)

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

Ora che ho i miei limiti di confidenza, creo un grafico:

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

Ecco la trama con gli intervalli di confidenza al 95% ottenuti in questo modo:

Questo approccio è valido o esistono altri approcci o migliori per calcolare gli intervalli di confidenza al 95% sulle previsioni di un modello misto non lineare? Non sono del tutto sicuro di come gestire la struttura degli effetti casuali del modello ... Forse una media dovrebbe superare i livelli di effetti casuali? O sarebbe OK avere intervalli di confidenza per un soggetto medio, che sembrerebbe essere più vicino a quello che ho adesso?

Quello che hai fatto qui sembra ragionevole. La risposta breve è che per la maggior parte i problemi relativi alla previsione di intervalli di confidenza da modelli misti e da modelli non lineari sono più o meno ortogonali , ovvero è necessario preoccuparsi di entrambi i gruppi di problemi, ma non (che io sappia di) interagire in qualsiasi modo strano.

• Problemi con modelli misti : stai cercando di prevedere a livello di popolazione o di gruppo? Come si spiega la variabilità nei parametri degli effetti casuali? Stai condizionando le osservazioni a livello di gruppo o no?
• Problemi del modello non lineare : la distribuzione campionaria dei parametri è normale? Come conto della non linearità durante la propagazione dell'errore?

In tutto, supporrò che stai predendo a livello di popolazione e costruendo intervalli di confidenza come livello di popolazione - in altre parole stai cercando di tracciare i valori previsti di un gruppo tipico e non includere la variazione tra i gruppi nella tua sicurezza intervalli. Questo semplifica i problemi del modello misto. I seguenti grafici mettono a confronto tre approcci (vedi sotto per il dump del codice):

• intervalli di previsione della popolazione : questo è l'approccio che hai provato sopra. Presuppone che il modello sia corretto e che le distribuzioni campionarie dei parametri ad effetto fisso siano normali multivariate; ignora anche l'incertezza nei parametri degli effetti casuali
• bootstrap : ho implementato il bootstrap gerarchico; ricampioniamo sia a livello di gruppi che all'interno dei gruppi. Il campionamento all'interno del gruppo campiona i residui e li aggiunge alle previsioni. Questo approccio fa il minor numero di ipotesi.
• metodo delta : questo presuppone sia la Normalità multivariata delle distribuzioni campionarie sia che la non linearità sia abbastanza debole da consentire un'approssimazione del secondo ordine.

Potremmo anche eseguire il bootstrap parametrico ...

Ecco gli elementi della configurazione tracciati insieme ai dati ...

... ma non riusciamo a vedere le differenze.

Ingrandimento sottraendo i valori previsti (rosso = bootstrap, blu = PPI, ciano = metodo delta)

In questo caso gli intervalli di bootstrap sono in realtà più stretti (ad esempio presumibilmente le distribuzioni di campionamento dei parametri sono in realtà leggermente più sottili di quelle normali), mentre gli intervalli PPI e delta-method sono molto simili tra loro.

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)