添加置信區間以從 R 中的模擬數據繪制

Question

我創建了一個基於似然函數和模擬的概率模擬，所有這些都可以用下面的代碼復制。

這是似然函數：

probit.ll <- function(par,ytilde,x) {
   a <- par[1] 
   b <- par[2]
 return(  -sum( pnorm(ytilde*(a + b*x),log=TRUE) ))
}

這是進行估計的函數：

my.probit <- function(y,x) {
# use OLS to get start values
par <- lm(y~x)$coefficients
ytilde <- 2*y-1
# Run optim 
res <- optim(par,probit.ll,hessian=TRUE,ytilde=ytilde,x=x)
# Return point estimates and SE based on the inverse of Hessian
names(res$par) <- c('a','b')
se=sqrt(diag(solve(res$hessian)))
names(se) <- c('a','b')
return(list(par=res$par,se=se,cov=solve(res$hessian)))
}

這是生成模擬模型的函數：

probit.data <- function(N=100,a=1,b=1) {
x <- rnorm(N)
y.star <- a + b*x + rnorm(N)
y <- (y.star > 0)
return( as.data.frame(cbind(y,x,y.star)) )
}

這模擬了一個等於 100 的 n 大小：

probit.data100 <- function(N=100,a=2,b=1) {
x <- rnorm(N)
y.star <- a + b*x + rnorm(N)
y <- (y.star > 0)
return( as.data.frame(cbind(y,x,y.star)) )
}

#predicted value
se.probit.phat100 <- function(x, par, V) {
z <- par[1] + par[2] * x
# Derivative of q w.r.t. alpha and beta 
J <- c( dnorm(z), dnorm(z)*par[2] )
return( sqrt(t(J) %*% V %*% J)  )
}

dat100 <- probit.data100()
res100 <- my.probit(dat100$y,dat100$x)
res100

下面的這個函數將基於非參數引導方法計算置信區間（注意正在使用的樣本函數）：

N <- dim(probit.data(N=100, a=1, b=1))[1]
npb.par <- matrix(NA,100,2)
colnames(npb.par) <- c("alpha","beta")
npb.eystar <- matrix(NA,100,N)
for (t in 1:100) {
thisdta <- probit.data(N=100, a=1, b=1)[sample(1:N,N,replace=TRUE),]
npb.par[t,] <- my.probit(thisdta$y,thisdta$x)$par
}

下面的這個函數只是清理引導輸出，置信區間是我想要繪制的：

processres <- function(simres) {
z <- t(apply(simres,2,function(x) { c(mean(x),median(x),sd(x),quantile(x,c(0.05,0.95)))     } ))
rownames(z) <- colnames(simres)
colnames(z) <- c("mean","median","sd","5%","95%")
z
}

processres(npb.par)

我想繪制這樣的圖（下圖），但根據上面的 processres 函數添加置信區間。 如何將這些置信區間添加到圖中？

x <- seq(-5,5,length=100)
plot(x, pnorm(1 - 0.5*x), ty='l', lwd=2, bty='n', xlab='x', ylab="Pr(y=1)")
rug(dat100$x)

我也對不同的繪圖代碼和/或包持開放態度。 我只想要一個基於此模擬並增加置信區間的圖表。

謝謝！

Answer 1

下面是一種基於模擬結果添加陰影 CI 的方法：

更新：現在繪制預期曲線（即使用平均 alpha 和 beta 值），並正確地將這些均值傳遞給rnorm 。

x <- seq(-5,5,length=100)
plot(x, pnorm(1 - 0.5*x), ty='n', lwd=2, bty='n', xlab='x', ylab="Pr(y=1)", 
     xaxs = 'i', ylim=c(0, 1))

params <- processres(npb.par)
sims <- 100000
sim.mat <- matrix(NA, ncol=length(x), nrow=sims)
for (i in 1:sims) {
  alpha <- rnorm(1, params[1, 1], params[1, 3])
  beta <- rnorm(1, params[2, 1], params[2, 3])
  sim.mat[i, ] <- pnorm(alpha - beta*x)
}

CI <- apply(sim.mat, 2, function(x) quantile(x, c(0.05, 0.95)))
polygon(c(x, rev(x)), c(CI[1, ], rev(CI[2, ])), col='gray', border=NA)
lines(x, pnorm(params[1, 1] - params[2, 1]*x), lwd=2)
rug(dat100$x)
box()