Intervalles de confiance sur les prédictions pour un modèle mixte non linéaire (nlme)

Je souhaiterais obtenir des intervalles de confiance à 95% sur les prédictions d'un nlmemodèle mixte non linéaire . Étant donné que rien de standard n'est fourni pour le faire à l'intérieur nlme, je me demandais s'il était correct d'utiliser la méthode des "intervalles de prédiction de population", comme indiqué dans le chapitre du livre de Ben Bolker dans le contexte de modèles ajustés avec une probabilité maximale , basée sur l'idée de rééchantillonner les paramètres d'effets fixes sur la base de la matrice variance-covariance du modèle ajusté, simuler des prédictions basées sur cela, puis prendre les 95% des centiles de ces prédictions pour obtenir les intervalles de confiance à 95%?

Le code pour ce faire ressemble à ceci: (J'utilise ici les données 'Loblolly' du nlmefichier d'aide)

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

Maintenant que j'ai mes limites de confiance, je crée un graphique:

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

Voici l'intrigue avec les intervalles de confiance à 95% obtenus de cette façon:

Cette approche est-elle valide ou existe-t-il d'autres ou de meilleures approches pour calculer des intervalles de confiance à 95% sur les prédictions d'un modèle mixte non linéaire? Je ne suis pas tout à fait sûr de savoir comment gérer la structure à effet aléatoire du modèle ... Faut-il peut-être faire une moyenne sur les niveaux d'effet aléatoire? Ou serait-il OK d'avoir des intervalles de confiance pour un sujet moyen, ce qui semble être plus proche de ce que j'ai maintenant?

Ce que vous avez fait ici semble raisonnable. La réponse courte est que, pour la plupart, les problèmes de prédiction des intervalles de confiance à partir de modèles mixtes et de modèles non linéaires sont plus ou moins orthogonaux , c'est-à-dire que vous devez vous soucier des deux ensembles de problèmes, mais ils ne le font pas (ce que je sais de) interagir de manière étrange.

• Problèmes de modèles mixtes : essayez-vous de prédire au niveau de la population ou du groupe? Comment expliquez-vous la variabilité des paramètres d'effets aléatoires? Êtes-vous conditionné ou non aux observations au niveau du groupe?
• Problèmes du modèle non linéaire : la distribution d'échantillonnage des paramètres est-elle normale? Comment tenir compte de la non-linéarité lors de la propagation d'une erreur?

Tout au long, je suppose que vous prédisez au niveau de la population et construisez des intervalles de confiance en tant que niveau de la population - en d'autres termes, vous essayez de tracer les valeurs prédites d'un groupe typique , et n'incluez pas la variation entre les groupes de votre confiance intervalles. Cela simplifie les problèmes de modèle mixte. Les graphiques suivants comparent trois approches (voir ci-dessous pour le vidage de code):

• intervalles de prédiction de la population : c'est l'approche que vous avez essayée ci-dessus. Il suppose que le modèle est correct et que les distributions d'échantillonnage des paramètres à effet fixe sont normales à plusieurs variables; il ignore également l'incertitude dans les paramètres des effets aléatoires
• bootstrapping : j'ai implémenté le bootstrapping hiérarchique; nous rééchantillons à la fois au niveau des groupes et au sein des groupes. L'échantillonnage intra-groupe échantillonne les résidus et les ajoute aux prévisions. Cette approche fait le moins d'hypothèses.
• méthode delta : cela suppose à la fois une normalité multivariée des distributions d'échantillonnage et que la non-linéarité est suffisamment faible pour permettre une approximation de second ordre.

On pourrait aussi faire du bootstrap paramétrique ...

Voici les CI tracés avec les données ...

... mais nous pouvons à peine voir les différences.

Zoom avant en soustrayant les valeurs prévues (rouge = bootstrap, bleu = PPI, cyan = méthode delta)

Dans ce cas, les intervalles de bootstrap sont en fait les plus étroits (par exemple, vraisemblablement, les distributions d'échantillonnage des paramètres sont en fait légèrement plus minces que Normal), tandis que les intervalles PPI et delta-method sont très similaires les uns aux autres.

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)