二项式分布的贝叶斯估计

这个问题的技术跟进这个问题。

我在理解和复制Raftery（1988）中$N$提出的模型时遇到了麻烦：二项式参数的推论： WinBUGS / OpenBUGS / JAGS中的分层贝叶斯方法。它不仅与代码有关，因此在这里应该是主题。

背景

令是一组来自未知和的二项式分布的成功计数。此外，我假设遵循参数的泊松分布（如本文所述）。然后，每个的泊松分布均值为。我想根据和指定先验。ñ θ Ñ μ X 我 λ = μ θ λ $x=(x_{1},\ldots,x_{n})$$N$$\theta$$N$$\mu$$x_{i}$$\lambda = \mu \theta$$\lambda$$\theta$

假设我对或没有任何先验知识，我想为和分配非信息先验。说，我的先验是和。θ λ θ λ 〜ģ 一米米一（0.001 ，0.001 ）θ 〜ü Ñ 我˚F ö ř 米（0 ，1 $N$$\theta$$\lambda$$\theta$$\lambda\sim \mathrm{Gamma}(0.001, 0.001)$$\theta\sim \mathrm{Uniform}(0, 1)$

作者使用不当先验，但WinBUGS不接受不当先验。$p(N,\theta)\propto N^{-1}$

例

在纸（第226）中，提供了观察到的水羚的以下成功计数：。我想估计，即人口的大小。$53, 57, 66, 67, 72$$N$

这是我尝试在WinBUGS中创建示例的方法（在@StéphaneLaurent评论后更新）：

model {

# Likelihood
  for (i in 1:N) {
    x[i] ~ dbin(theta, n)
  }

# Priors

n ~ dpois(mu)
lambda ~ dgamma(0.001, 0.001)
theta ~ dunif(0, 1)
mu <- lambda/theta

}

# Data

list(x = c(53, 57, 66, 67, 72), N = 5)

# Initial values

list(n = 100, lambda = 100, theta  = 0.5)
list(n = 1000, lambda = 1000, theta  = 0.8)
list(n = 5000, lambda = 10, theta  = 0.2)

该模型没有门槛后不500'000样品很好地衔接与20'000老化样品。这是JAGS运行的输出：

Inference for Bugs model at "jags_model_binomial.txt", fit using jags,
 5 chains, each with 5e+05 iterations (first 20000 discarded), n.thin = 5
 n.sims = 480000 iterations saved
         mu.vect  sd.vect   2.5%     25%     50%     75%    97.5%  Rhat  n.eff
lambda    63.081    5.222 53.135  59.609  62.938  66.385   73.856 1.001 480000
mu       542.917 1040.975 91.322 147.231 231.805 462.539 3484.324 1.018    300
n        542.906 1040.762 95.000 147.000 231.000 462.000 3484.000 1.018    300
theta      0.292    0.185  0.018   0.136   0.272   0.428    0.668 1.018    300
deviance  34.907    1.554 33.633  33.859  34.354  35.376   39.213 1.001  43000

问题

显然，我缺少一些东西，但是我看不到确切的东西。我认为我对模型的表述在某处是错误的。所以我的问题是：

• 为什么我的模型及其实现不起作用？
• Raftery（1988）给出的模型如何正确制定和实施？

谢谢你的帮助。

好吧，既然您的代码可以正常工作，那么这个答案似乎为时已晚。但是我已经写了代码，所以...

就其价值而言，这是与相同的*模型rstan。估计在我的家用笔记本电脑上可以在11秒内完成在更少的迭代中获得我们感兴趣的参数更高的有效样本量。$(N, \theta)$

raftery.model   <- "
    data{
        int     I;
        int     y[I];
    }
    parameters{
        real<lower=max(y)>  N;
        simplex[2]      theta;
    }
    transformed parameters{
    }
    model{
        vector[I]   Pr_y;

        for(i in 1:I){
            Pr_y[i] <-  binomial_coefficient_log(N, y[i])
                        +multiply_log(y[i],         theta[1])
                        +multiply_log((N-y[i]),     theta[2]);
        }
        increment_log_prob(sum(Pr_y));
        increment_log_prob(-log(N));            
    }
"
raft.data           <- list(y=c(53,57,66,67,72), I=5)
system.time(fit.test    <- stan(model_code=raftery.model, data=raft.data,iter=10))
system.time(fit     <- stan(fit=fit.test, data=raft.data,iter=10000,chains=5))

请注意，我将theta其转换为2个单纯形。这只是为了数值稳定性。利息的数量是theta[1]; 显然theta[2]是多余的信息。

*如您所见，后验总结实际上是相同的，并且将提升为实际数量似乎对我们的推论没有实质性影响。$N$

对于我的模型，的97.5％的分位数要大50％，但这是因为stan的采样器比简单的随机游走更擅长探索后方的整个范围，因此它可以更轻松地进入尾部。我可能是错的。$N$

            mean se_mean       sd   2.5%    25%    50%    75%   97.5% n_eff Rhat
N        1078.75  256.72 15159.79  94.44 148.28 230.61 461.63 4575.49  3487    1
theta[1]    0.29    0.00     0.19   0.01   0.14   0.27   0.42    0.67  2519    1
theta[2]    0.71    0.00     0.19   0.33   0.58   0.73   0.86    0.99  2519    1
lp__      -19.88    0.02     1.11 -22.89 -20.31 -19.54 -19.09  -18.82  3339    1

取从stan生成的的值，我用它们绘制后验预测值。后验预测的平均值非常接近样本数据的平均值，我们不会感到惊讶！〜ÿ 〜$N, \theta$$\tilde{y}$$\tilde{y}$

N.samples   <- round(extract(fit, "N")[[1]])
theta.samples   <- extract(fit, "theta")[[1]]
y_pred  <- rbinom(50000, size=N.samples, prob=theta.samples[,1])
mean(y_pred)
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  32.00   58.00   63.00   63.04   68.00  102.00 

为了检查rstan采样器是否有问题，我在网格上计算了后验。我们可以看到后部是香蕉形的；对于欧洲公制HMC，这种后验可能会出现问题。但是，让我们检查一下数值结果。（由于在对数刻度上，因此实际上抑制了香蕉形状的严重性。）如果您想一想香蕉形状一分钟，就会意识到它必须位于线上。ˉ ÿ = θ $N$$\bar{y}=\theta N$

下面的代码可以确认stan的结果有意义。

theta   <- seq(0+1e-10,1-1e-10, len=1e2)
N       <- round(seq(72, 5e5, len=1e5)); N[2]-N[1]
grid    <- expand.grid(N,theta)
y   <- c(53,57,66,67,72)
raftery.prob    <- function(x, z=y){
    N       <- x[1]
    theta   <- x[2]
    exp(sum(dbinom(z, size=N, prob=theta, log=T)))/N
}

post    <- matrix(apply(grid, 1, raftery.prob), nrow=length(N), ncol=length(theta),byrow=F)    
approx(y=N, x=cumsum(rowSums(post))/sum(rowSums(post)), xout=0.975)
$x
[1] 0.975

$y
[1] 3236.665

嗯 这不是我所期望的。对97.5％的分位数的网格评估更接近JAGS结果而不是rstan结果。同时，我不认为网格结果应被视为福音，因为网格评估正在进行一些相当粗略的简化：一方面，网格分辨率不太好，另一方面，我们（错误地） ）断言网格中的总概率必须为1，因为我们必须绘制边界（和有限网格点）以使问题可计算（我仍在等待无限RAM）。实际上，我们的模型在具有正概率。但也许在这里有一些更微妙的事情。$(0,1)\times\left\{N|N\in\mathbb{Z}\land N\ge72)\right\}$

$\lambda$

这是我使用JAGS和R的分析脚本和结果：

#===============================================================================================================
# Load packages
#===============================================================================================================

sapply(c("ggplot2"
         , "rjags"
         , "R2jags"
         , "hdrcde"
         , "runjags"
         , "mcmcplots"
         , "KernSmooth"), library, character.only = TRUE)

#===============================================================================================================
# Model file
#===============================================================================================================

cat("
    model {

    # Likelihood    
    for (i in 1:N) {
      x[i] ~ dbin(theta, n)
    }

    # Prior       
    n ~ dpois(mu)
    lambda ~ dgamma(0.005, 0.005)
#     lambda ~ dunif(0, 1000)
    mu <- lambda/theta
    theta ~ dunif(0, 1)    
}    
", file="jags_model_binomial.txt")


#===============================================================================================================
# Data
#===============================================================================================================

data.list <- list(x = c(53, 57, 66, 67, 72, NA), N = 6) # Waterbuck example from Raftery (1988)

#===============================================================================================================
# Inits
#===============================================================================================================

jags.inits <- function() { 
  list(
    n = sample(max(data.list$x, na.rm = TRUE):1000, size = 1) 
    , theta = runif(1, 0, 1)
    , lambda = runif(1, 1, 10)
#     , cauchy  = runif(1, 1, 1000)
    #     , mu = runif(1, 0, 5)
  )
}

#===============================================================================================================
# Run the chains
#===============================================================================================================

# Parameters to store

params <- c("n"
            , "theta"
            , "lambda"
            , "mu"
            , paste("x[", which(is.na(data.list[["x"]])), "]", sep = "")
)

# MCMC settings

niter <- 500000 # number of iterations
nburn <- 20000  # number of iterations to discard (the burn-in-period)
nchains <- 5    # number of chains

# Run JAGS

out <- jags(
  data                 = data.list
  , parameters.to.save = params
  , model.file         = "jags_model_binomial.txt"
  , n.chains           = nchains
  , n.iter             = niter
  , n.burnin           = nburn
  , n.thin             = 50
  , inits              = jags.inits
  , progress.bar       = "text")

在我的台式机上，计算耗时约98秒。

#===============================================================================================================
# Inspect results
#===============================================================================================================

print(out
      , digits = 2
      , intervals = c(0.025, 0.1, 0.25, 0.5, 0.75, 0.9,  0.975))

结果是：

Inference for Bugs model at "jags_model_binomial.txt", fit using jags,
 5 chains, each with 5e+05 iterations (first 20000 discarded), n.thin = 50
 n.sims = 48000 iterations saved
         mu.vect sd.vect  2.5%    10%    25%    50%    75%     90%   97.5% Rhat n.eff
lambda     62.90    5.18 53.09  56.47  59.45  62.74  66.19   69.49   73.49    1 48000
mu        521.28  968.41 92.31 113.02 148.00 232.87 467.10 1058.17 3014.82    1  1600
n         521.73  968.54 95.00 114.00 148.00 233.00 467.00 1060.10 3028.00    1  1600
theta       0.29    0.18  0.02   0.06   0.13   0.27   0.42    0.55    0.66    1  1600
x[6]       63.03    7.33 49.00  54.00  58.00  63.00  68.00   72.00   78.00    1 36000
deviance   34.88    1.53 33.63  33.70  33.85  34.34  35.34   36.81   39.07    1 48000

$N$$522$$233$$N$

jagsfit.mcmc <- as.mcmc(out)
jagsfit.mcmc <- combine.mcmc(jagsfit.mcmc)

hpd.80 <- hdr.den(log(as.vector(jagsfit.mcmc[, "n"])), prob = c(80), den = bkde(log(as.vector(jagsfit.mcmc[, "n"])), gridsize = 10000))

exp(hpd.80$mode)

[1] 149.8161

$N$

(hpd.ints <- HPDinterval(jagsfit.mcmc, prob = c(0.8)))

               lower      upper
deviance 33.61011007  35.677810
lambda   56.08842502  69.089507
mu       72.42307587 580.027182
n        78.00000000 578.000000
theta     0.01026193   0.465714
x[6]     53.00000000  71.000000

$N$$150$$(78; 578)$$(80; 598)$