비선형 혼합 모형 (nlme) 예측에 대한 신뢰 구간

비선형 혼합 nlme모형 의 예측에 대한 95 % 신뢰 구간을 얻고 싶습니다 . 아무것도 표준 내에서이 작업을 수행하기 위해 제공되기 때문에 nlme, 나는 "인구 예측 간격"의 방법을 사용하는 것이 올바른 것처럼, 궁금 모델의 맥락에서 벤 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) 어떤 이상한 방식으로 상호 작용합니다.

• 혼합 모델 문제 : 인구 또는 그룹 수준에서 예측하려고합니까? 랜덤 효과 매개 변수의 변동성을 어떻게 설명합니까? 당신은 그룹 수준의 관찰을 조절하고 있습니까?
• 비선형 모델 문제 : 모수의 표본 분포가 정상입니까? 오류 전파시 비선형 성을 어떻게 설명합니까?

전체적으로, 나는 당신이 모집단 수준에서 예측하고 신뢰 구간을 모집단 수준으로 구성한다고 가정합니다. 다시 말하면 전형적인 그룹 의 예측 된 값을 플롯하려고 노력 하고 있으며, 그룹 간 변동을 포함하지 않습니다. 간격. 이는 혼합 모형 문제를 단순화합니다. 다음 그림은 세 가지 접근 방식을 비교합니다 (코드 덤프는 아래 참조).

• 모집단 예측 간격 : 이것은 위에서 시도한 접근법입니다. 모형이 정확하고 고정-효과 매개 변수의 표본 분포가 다변량 표준이라고 가정합니다. 또한 랜덤 효과 매개 변수의 불확실성을 무시합니다.
• 부트 스트랩 : 계층 적 부트 스트랩을 구현했습니다. 그룹 수준과 그룹 내에서 모두 다시 샘플링합니다. 그룹 내 샘플링은 잔차를 샘플링 하여 예측에 다시 추가합니다. 이 접근법은 가장 적은 가정을합니다.
• 델타 방법 : 샘플링 분포의 다변량 정규성과 두 번째 근사치를 허용하기에 비선형 성이 약하다고 가정합니다.

파라 메트릭 부트 스트랩 도 할 수 있습니다 ...

다음은 데이터와 함께 플롯 된 CI입니다 ...

...하지만 차이점을 거의 볼 수 없습니다.

예측 된 값을 빼서 확대 (빨간색 = 부트 스트랩, 파랑 = PPI, 시안 = 델타 방법)

이 경우 부트 스트랩 간격은 실제로 가장 좁습니다 (예 : 매개 변수의 샘플링 분포는 실제로 Normal보다 약간 얇 습니다). 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)