Khoảng tin cậy đối với các dự đoán cho mô hình hỗn hợp phi tuyến tính (nlme)

Tôi muốn đạt được khoảng tin cậy 95% cho các dự đoán của nlmemô hình hỗn hợp phi tuyến tính . Vì không có tiêu chuẩn nào được cung cấp để thực hiện điều này bên trong nlme, tôi đã tự hỏi liệu có đúng không khi sử dụng phương pháp "khoảng dự đoán dân số", như được nêu trong chương sách của Ben Bolker trong bối cảnh các mô hình phù hợp với khả năng tối đa , dựa trên ý tưởng của lấy mẫu lại các tham số hiệu ứng cố định dựa trên ma trận phương sai hiệp phương sai của mô hình được trang bị, mô phỏng dự đoán dựa trên điều này và sau đó lấy 95% phần trăm của các dự đoán này để có khoảng tin cậy 95%?

Mã để thực hiện việc này trông như sau: (Tôi ở đây sử dụng dữ liệu 'loblolly' từ nlmetệp trợ giúp)

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

Bây giờ tôi có giới hạn tự tin của mình, tôi tạo một biểu đồ:

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

Đây là âm mưu với khoảng tin cậy 95% thu được theo cách này:

Cách tiếp cận này có hợp lệ không, hoặc có cách tiếp cận nào khác hoặc tốt hơn để tính khoảng tin cậy 95% cho các dự đoán của mô hình hỗn hợp phi tuyến? Tôi không hoàn toàn chắc chắn về cách xử lý cấu trúc hiệu ứng ngẫu nhiên của mô hình ... Có nên trung bình một mức có thể vượt quá mức hiệu ứng ngẫu nhiên? Hoặc sẽ ổn khi có khoảng tin cậy cho một đối tượng trung bình, dường như gần với những gì tôi có bây giờ?

Những gì bạn đã làm ở đây có vẻ hợp lý. Câu trả lời ngắn gọn là phần lớn các vấn đề dự đoán khoảng tin cậy từ các mô hình hỗn hợp và từ các mô hình phi tuyến đều ít nhiều trực giao , nghĩa là bạn cần phải lo lắng về cả hai vấn đề, nhưng chúng không biết (mà tôi biết của) tương tác theo bất kỳ cách lạ nào.

• Các vấn đề mô hình hỗn hợp : bạn đang cố gắng dự đoán ở cấp độ dân số hoặc nhóm? Làm thế nào để bạn tính đến sự thay đổi trong các tham số hiệu ứng ngẫu nhiên? Bạn có điều chỉnh các quan sát cấp nhóm hay không?
• Các vấn đề mô hình phi tuyến : phân phối lấy mẫu của các tham số Bình thường? Làm thế nào để tôi tính đến sự phi tuyến khi lan truyền lỗi?

Trong suốt, tôi sẽ cho rằng bạn dự đoán ở cấp độ dân số và xây dựng các khoảng tin cậy là cấp độ dân số - nói cách khác, bạn đang cố gắng vẽ các giá trị dự đoán của một nhóm điển hình và không bao gồm sự thay đổi độ tin cậy giữa các nhóm khoảng thời gian. Điều này đơn giản hóa các vấn đề mô hình hỗn hợp. Các sơ đồ sau so sánh ba cách tiếp cận (xem bên dưới để kết xuất mã):

• khoảng dự đoán dân số : đây là cách tiếp cận bạn đã thử ở trên. Nó giả định mô hình là chính xác và các phân phối lấy mẫu của các tham số hiệu ứng cố định là đa biến Bình thường; nó cũng bỏ qua sự không chắc chắn trong các tham số hiệu ứng ngẫu nhiên
• bootstrapping : Tôi đã triển khai bootstrapping phân cấp; chúng tôi lấy mẫu lại ở cả cấp độ nhóm và trong nhóm. Việc lấy mẫu trong nhóm lấy mẫu dư và thêm chúng trở lại dự đoán. Cách tiếp cận này làm cho các giả định ít nhất.
• Phương pháp delta : điều này giả định cả Định mức đa biến của phân phối lấy mẫu và tính phi tuyến tính đủ yếu để cho phép xấp xỉ bậc hai.

Chúng tôi cũng có thể làm tham số bootstrapping ...

Dưới đây là các TCTD được vẽ cùng với dữ liệu ...

... nhưng chúng ta khó có thể thấy sự khác biệt.

Phóng to bằng cách trừ đi các giá trị dự đoán (red = bootstrap, blue = PPI, cyan = delta method)

Trong trường hợp này, các khoảng thời gian bootstrap thực sự hẹp nhất (ví dụ, có lẽ các phân phối lấy mẫu của các tham số thực sự mỏng hơn một chút so với Bình thường), trong khi các khoảng PPI và phương thức delta rất giống nhau.

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)