Ước lượng Bayes của của phân phối nhị thức

Câu hỏi này là một theo dõi kỹ thuật của câu hỏi này .

Tôi gặp khó khăn trong việc hiểu và sao chép mô hình được trình bày trong Raftery (1988): Suy luận về tham số nhị thức : cách tiếp cận Bayes phân cấp$N$ trong WinBUGS / OpenBUGS / JAGS. Nó không chỉ là về mã mặc dù vậy nó nên có chủ đề ở đây.

Lý lịch

Đặt là tập hợp các thành công được tính từ phân phối nhị thức với và không xác định . Hơn nữa, tôi giả sử rằng tuân theo phân phối Poisson với tham số (như được thảo luận trong bài báo). Sau đó, mỗi có phân phối Poisson với giá trị trung bình . Tôi muốn chỉ định các linh mục theo thuật ngữ và .$x=(x_{1},\ldots,x_{n})$$N$$\theta$$N$$\mu$$x_{i}$$\lambda = \mu \theta$$\lambda$$\theta$

Giả sử rằng tôi không có bất kỳ kiến ​​thức tốt nào về hoặc , tôi muốn chỉ định các linh mục không cung cấp thông tin cho cả và . Giả sử, các linh mục của tôi là và .$N$$\theta$$\lambda$$\theta$$\lambda\sim \mathrm{Gamma}(0.001, 0.001)$$\theta\sim \mathrm{Uniform}(0, 1)$

Tác giả sử dụng không đúng trước nhưng WinBUGS không chấp nhận các linh mục không phù hợp.$p(N,\theta)\propto N^{-1}$

Thí dụ

Trong bài báo (trang 226), số lượng thành công sau đây của waterbucks được quan sát được cung cấp: . Tôi muốn ước tính , kích thước của dân số.$53, 57, 66, 67, 72$$N$

Đây là cách tôi đã cố gắng đưa ra ví dụ trong WinBUGS ( được cập nhật sau bình luận của @ 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)

Mô hình này không Sill không hội tụ độc đáo sau 500'000 mẫu với 20'000 burn-in mẫu. Đây là đầu ra của một lần chạy 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

Câu hỏi

Rõ ràng, tôi đang thiếu một cái gì đó, nhưng tôi không thể thấy chính xác những gì. Tôi nghĩ rằng công thức của tôi về mô hình là sai ở đâu đó. Vì vậy, câu hỏi của tôi là:

• Tại sao mô hình của tôi và việc thực hiện nó không hoạt động?
• Làm thế nào mô hình được đưa ra bởi Raftery (1988) có thể được xây dựng và thực hiện chính xác?

Cảm ơn bạn đã giúp đỡ.

Chà, vì bạn đã có mã của mình để làm việc, có vẻ như câu trả lời này hơi muộn. Nhưng tôi đã viết mã rồi, nên ...

Đối với những gì nó có giá trị, đây là mô hình * tương tự phù hợp với rstan. Ước tính trong 11 giây trên máy tính xách tay tiêu dùng của tôi, đạt được kích thước mẫu hiệu quả cao hơn cho các tham số quan tâm của chúng tôi trong số lần lặp ít hơn.$(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))

Lưu ý rằng tôi chọn thetalà 2-đơn giản. Đây chỉ là cho sự ổn định số. Số lượng lãi là theta[1]; rõ ràng theta[2]là thông tin thừa.

* Như bạn có thể thấy, bản tóm tắt sau hầu như giống hệt nhau và việc quảng cáo đến một số lượng thực dường như không có tác động đáng kể đến các suy luận của chúng tôi.$N$

Định lượng 97,5% cho lớn hơn 50% cho mô hình của tôi, nhưng tôi nghĩ đó là vì bộ lấy mẫu của stan tốt hơn trong việc khám phá toàn bộ phạm vi phía sau so với đi bộ ngẫu nhiên đơn giản, vì vậy nó có thể dễ dàng đưa nó vào đuôi hơn. Tôi có thể đã sai.$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

Lấy các giá trị của được tạo từ stan, tôi sử dụng các giá trị này để vẽ các giá trị tiên đoán sau . Chúng ta không nên ngạc nhiên rằng giá trị trung bình của các dự đoán sau rất gần với giá trị trung bình của dữ liệu mẫu!~ y ~ $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 

Để kiểm tra xem rstanbộ lấy mẫu có phải là vấn đề hay không, tôi đã tính toán phần sau trên lưới. Chúng ta có thể thấy rằng phía sau có hình quả chuối; loại hậu thế này có thể gây rắc rối cho số liệu điện tử hạt nhân HMC. Nhưng hãy kiểm tra kết quả bằng số. (Mức độ nghiêm trọng của hình dạng quả chuối thực sự bị triệt tiêu ở đây vì nằm trên thang đo log.) Nếu bạn nghĩ về hình dạng quả chuối trong một phút, bạn sẽ nhận ra rằng nó phải nằm trên dòng .ˉ y = θ $N$$\bar{y}=\theta N$

Mã dưới đây có thể xác nhận rằng kết quả của chúng tôi từ stan có ý nghĩa.

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

Hừm. Đây không phải là những gì tôi mong đợi. Đánh giá lưới cho lượng tử 97,5% gần với kết quả JAGS hơn so với rstankết quả. Đồng thời, tôi không tin rằng các kết quả lưới nên được coi là phúc âm vì việc đánh giá lưới đang thực hiện một số đơn giản hóa khá thô: mặt khác, độ phân giải lưới không quá tốt, mặt khác, chúng ta (giả ) khẳng định rằng tổng xác suất trong lưới phải là 1, vì chúng ta phải vẽ một ranh giới (và các điểm lưới hữu hạn) để vấn đề có thể tính toán được (tôi vẫn đang chờ RAM vô hạn). Trong thực tế, mô hình của chúng tôi có xác suất dương trên . Nhưng có lẽ một cái gì đó tinh tế hơn đang chơi ở đây.$(0,1)\times\left\{N|N\in\mathbb{Z}\land N\ge72)\right\}$

$\lambda$

Đây là kịch bản phân tích và kết quả của tôi bằng JAGS và 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")

Tính toán mất khoảng 98 giây trên máy tính để bàn của tôi.

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

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

Kết quả là:

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