Question

一些基本问题是-不是如何运行程序，而是程序实际在计算什么。我无法通过键入bsts来获得答案，这会导致我无法访问并且可能无法理解的Call（“ analysis_common_r_fit_bsts_model _” ...）。我已经尝试过r-help并通过电子邮件发送软件包维护者。我希望你们中的一个可以帮助或指出答案。

对于没有回归变量和局部级别模型的高斯情况，下面的代码似乎模仿了bsts。它产生类似于模型图的图形，并通过状态贡献确认sigma.level和sigma.obs的输出之间的关系。但是，针对这些sigma的后验分布的直接方法与bsts输出不匹配。我不确定这是否是一个简单的错误，是否误解了SdPrior或差异是否涉及mcmc ...

dict

Answer 1

现在有所改善，主要是通过更改先验中的最大值。

后验均值更接近bsts的输出，但是分布仍然不同。我不知道在bsts中使用了什么mcmc实现。

格雷格

＃

setwd("/home/greg/Documents/rwork/incid/bayes")
library(bsts)
library(mcmc)
library(coda)

#simulate some data

y<-rep(NA,50)

y[1]=1
y[2]=1
s=2
set.seed(5)
for (k in 1:48)
{
y[2+k]=y[1+k]+0.1*y[k]+s*rnorm(1)
}
plot(1:50,y[1:50],main=paste("seed =",5))

#bsts model

ss<-AddLocalLevel(list(),y)
mod1<-bsts(y,state.specification=ss,niter=5000)
plot(mod1)

#has mod1 converged?
sigmc<-as.mcmc(cbind(mod1$sigma.level,mod1$sigma.obs))
plot(sigmc)
acf(sigmc)
#highly correlated
heidel.diag(sigmc)
geweke.plot(sigmc)
#looks ok

#skipping the discussion of what is being plotted

#the likelihood, using the kalman filter, as a function of the error variances and the initial state

kal<-function(par)
{
a<-par[1]
b<-par[2]
init<-par[3]

H=matrix(1,1,1)
F=matrix(1,1,1)
#1-dimensional state
N=50
dim(y)=c(1,N)

xe<-ye<-matrix(NA,1,N)
xe[,1]<-init
ye[,1]<-H%*%xe[,1]

P<-K<-array(data=NA,dim=c(N,1,1))
#P[1,,] initial guess
P[1,,]<-b

for (i in 1:(N-1))
{
P[i+1,,]<-F%*%P[i,,]%*%t(F)+a
K[i+1,,]<-P[i+1,,]%*%t(H)%*%solve(b+H%*%P[i+1,,]%*%t(H))
xe[1,i+1]<-F%*%xe[,i]+K[i+1,,]%*%(y[,i+1]-H%*%F%*%xe[,i])
P[i+1,,]<-(diag(1,1)-K[i+1,,]%*%H)%*%P[i+1,,]
}

-1/2*(log(abs(b))+(1/b)*sum((y[1,]-xe[1,])^2))
}


#priors

lpr1<-function(a)
{
v=0.01
ifelse((a<=0)|a>sd(y),-Inf,-(v/2+1)*log(a)-v*(sd(y)/100)^2/(2*a))
}

lpr2<-function(b)
{
v=0.01
ifelse((b<=0)|b>1.2*sd(y),-Inf,-(v/2+1)*log(b)-v*(sd(y))^2/(2*b))
}

lpr3<-function(c)
{
-1/(2*(sd(y))^2)*(c-1)^2
}

lpost1<-function(par)
{
a<-par[1]
b<-par[2]
init<-par[3]
lpr1(a)+lpr2(b)+lpr3(init)+kal(par)
}

par0<-c(sd(y)/100,sd(y),1)

nb=5000
out<-metrop(lpost1,par0,nb,blen=5,nspac=5,scale=0.3)
out$acc
sam<-out$batch
samc<-as.mcmc(sam)
plot(samc)
heidel.diag(samc)
geweke.plot(samc)
acf(samc)

#plot kalman using samc

ax<-samc[2501:5000,1]
bx<-samc[2501:5000,2]
initx<-samc[2501:5000,3]

state<-matrix(NA,2500,50)

for (j in 1:2500)
{
a<-ax[j]
b<-bx[j]
init<-initx[j]

H=matrix(1,1,1)
F=matrix(1,1,1)
N=50
dim(y)=c(1,N)

xe<-ye<-matrix(NA,1,N)
xe[,1]<-init
ye[,1]<-H%*%xe[,1]

P<-K<-array(data=NA,dim=c(N,1,1))
P[1,,]<-b
for (i in 1:(N-1))
{
P[i+1,,]<-F%*%P[i,,]%*%t(F)+a
K[i+1,,]<-P[i+1,,]%*%t(H)%*%solve(b+H%*%P[i+1,,]%*%t(H))
P[i+1,,]<-(diag(1,1)-K[i+1,,]%*%H)%*%P[i+1,,]
xe[1,i+1]<-F%*%xe[,i]+K[i+1,,]%*%(y[,i+1]-H%*%F%*%xe[,i])
}

state[j,]<-rnorm(N,xe[1,1:N],P[1:N,,]^0.5)
}

par(mfrow=c(1,2))
plot(1:N,y,col="blue",ylim=c(-12,8))
for (i in 1:99)
{
qi<-qin<-rep(NA,N)
tj<-1:N
for (k in 1:N)
{
qi[k]<-quantile(state[,k],(i-0.5)/100)
qin[k]<-quantile(state[,k],(i+1-0.5)/100)
}
polygon(c(tj,rev(tj)),c(qi[1:N],rev(qin[1:N])),col=rgb(0,0,0,40*dnorm(i,mean=50,sd=20)),border=FALSE)
}
plot(mod1,ylim=c(-12,8))
par(mfrow=c(1,1))

#plausible
#but

mean(ax^0.5)
mean(mod1$sigma.level[2501:5000])
#better
qqplot(ax^0.5,mod1$sigma.level[2501:5000])
lines(ax^0.5,ax^0.5,col="red")

mean(bx^0.5)
mean(mod1$sigma.obs[501:1000])
qqplot(bx^0.5,mod1$sigma.obs[501:1000])
lines(bx^0.5,bx^0.5,col="red")

#so ax^0.5 is still not sampling sigma.level
#bx^0.5 still not sampling sigma.obs

bsts后验分布

1 个答案:

＃