Estimasi Bayesian untuk

Pertanyaan ini merupakan tindak lanjut teknis dari pertanyaan ini .

Saya mengalami kesulitan memahami dan mereplikasi model yang disajikan dalam Raftery (1988): Inferensi untuk parameter binomial $N$: pendekatan hirarkis Bayes di WinBUGS / OpenBUGS / JAGS. Ini bukan hanya tentang kode, jadi itu harus sesuai topik di sini.

Latar Belakang

Misalkan $x=(x_{1},\ldots,x_{n})$ menjadi himpunan jumlah keberhasilan dari distribusi binomial dengan $N$ dan tidak diketahui $\theta$. Selanjutnya, saya berasumsi bahwa $N$ mengikuti distribusi Poisson dengan parameter $\mu$ (seperti yang dibahas dalam makalah ini). Kemudian, setiap $x_{i}$ memiliki distribusi Poisson dengan rata-rata $\lambda = \mu \theta$ . Saya ingin menentukan prior dalam hal $\lambda$ dan $\theta$ .

Dengan asumsi bahwa saya tidak memiliki pengetahuan sebelumnya yang baik tentang $N$ atau $\theta$ , saya ingin menetapkan prior non-informatif untuk $\lambda$ dan $\theta$ . Katakanlah, prior saya adalah $\lambda\sim \mathrm{Gamma}(0.001, 0.001)$ dan $\theta\sim \mathrm{Uniform}(0, 1)$ .

Penulis menggunakan prior yang tidak tepat dari $p(N,\theta)\propto N^{-1}$ tetapi WinBUGS tidak menerima prior yang tidak tepat.

Contoh

Dalam makalah (halaman 226), hitungan keberhasilan berikut dari waterbucks yang diamati disediakan: $53, 57, 66, 67, 72$ . Saya ingin memperkirakan $N$ , ukuran populasi.

Inilah cara saya mencoba mencari contoh di WinBUGS ( diperbarui setelah komentar @ Stéphane Laurent):

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)

Model ini tidak ambang tidak bertemu baik setelah 500'000 sampel dengan 20'000 burn-in sampel. Berikut ini adalah output dari menjalankan 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

Pertanyaan

Jelas, saya kehilangan sesuatu, tetapi saya tidak bisa melihat apa tepatnya. Saya pikir formulasi model saya salah di suatu tempat. Jadi pertanyaan saya adalah:

• Mengapa model saya dan implementasinya tidak berfungsi?
• Bagaimana model yang diberikan oleh Raftery (1988) dapat dirumuskan dan diimplementasikan dengan benar?

Terima kasih atas bantuan Anda.

Nah, karena kode Anda berfungsi, sepertinya jawaban ini agak terlambat. Tapi saya sudah menulis kode, jadi ...

Untuk apa nilainya, ini adalah * model yang cocok dengan rstan. Diperkirakan dalam 11 detik pada laptop konsumen saya, mencapai ukuran sampel efektif yang lebih tinggi untuk parameter minat kami dalam iterasi yang lebih sedikit.$(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))

Perhatikan bahwa saya berperan thetasebagai 2-simpleks. Ini hanya untuk stabilitas numerik. Jumlah bunga adalah theta[1]; jelas theta[2]informasi yang berlebihan.

* Seperti yang Anda lihat, ringkasan posterior sebenarnya identik, dan mempromosikan ke kuantitas nyata tampaknya tidak memiliki dampak substantif pada kesimpulan kami.$N$

Kuantil 97,5% untuk adalah 50% lebih besar untuk model saya, tapi saya pikir itu karena stan sampler lebih baik dalam mengeksplorasi berbagai posterior daripada jalan acak sederhana, sehingga lebih mudah membuatnya menjadi ekor. Tapi saya mungkin salah.$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

Mengambil nilai-nilai dihasilkan dari stan, saya menggunakan ini untuk menggambar nilai-nilai prediksi posterior ˜ y . Kita tidak perlu heran bahwa rata-rata prediksi posterior ˜ y sangat dekat dengan rata-rata data sampel!$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 

Untuk memeriksa apakah rstansampler bermasalah atau tidak, saya menghitung posterior di atas kisi. Kita dapat melihat bahwa posterior berbentuk pisang; posterior semacam ini dapat menjadi masalah untuk metrik HMC euclidian. Tapi mari kita periksa hasil numeriknya. (Keparahan bentuk pisang sebenarnya ditekan di sini karena berada pada skala log.) Jika Anda berpikir tentang bentuk pisang selama satu menit, Anda akan menyadari bahwa itu harus terletak pada garis ˉ y = θ $N$$\bar{y}=\theta N$ .

Kode di bawah ini dapat mengonfirmasi bahwa hasil kami dari stan masuk akal.

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

rstan$(0,1)\times\left\{N|N\in\mathbb{Z}\land N\ge72)\right\}$

$\lambda$

Berikut ini adalah skrip analisis dan hasil saya menggunakan JAGS dan 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")

Perhitungan memakan waktu sekitar 98 detik pada pc desktop saya.

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

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

Hasilnya adalah:

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)$