Байесовская оценка


16

Этот вопрос является техническим продолжением этого вопроса .

У меня проблемы с пониманием и тиражированием модели, представленной в Raftery (1988): Вывод для биномиального параметра : иерархический байесовский подходN в WinBUGS / OpenBUGS / JAGS. Речь идет не только о коде, поэтому он должен быть здесь по теме.

Фон

Пусть - набор отсчетов успеха из биномиального распределения с неизвестными N и θ . Далее, я предполагаю, что N следует распределению Пуассона с параметром μ (как обсуждалось в статье). Тогда каждый x i имеет распределение Пуассона со средним λ = µ θ . Я хочу указать приоры в терминах λ и θ .x=(x1,,xn)NθNμxiλ=μθλθ

Предполагая, что у меня нет хороших предварительных знаний о или θ , я хочу назначить неинформативные априорные значения как λ, так и θ . Скажем, мои априорные являются λ ~ G м м ( 0,001 , 0,001 ) и & thetas ; ~ U н я е ö г м ( 0 , 1 ) .NθλθλGamma(0.001,0.001)θUniform(0,1)

Автор использует неправильный априор но WinBUGS не принимает неправильные априорные значения.p(N,θ)N1

пример

В статье (стр. 226) приводятся следующие показатели успеха наблюдаемых водяных козлов: . Я хочу оценить N , численность населения.53,57,66,67,72N

Вот как я пытался отработать пример в WinBUGS ( обновлено после комментария @ 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)

Модель не подоконник не сходится хорошо после 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

Вопросов

Я явно что-то упускаю, но не вижу, что именно. Я думаю, что моя формулировка модели где-то не так. Итак, мои вопросы:

  • Почему моя модель и ее реализация не работают?
  • Как правильно сформулировать и реализовать модель, предложенную Рэфтери (1988)?

Спасибо за вашу помощь.


2
После статьи вы должны добавить mu=lambda/thetaи заменить n ~ dpois(lambda)наn ~ dpois(mu)
Стефан Лоран

@ StéphaneLaurent Спасибо за предложение. Я изменил код соответственно. К сожалению, модель все еще не сходится.
COOLSerdash

1
Что происходит, когда вы берете образец ? N<72
Sycorax говорит восстановить Монику

1
Если , вероятность равна нулю, потому что ваша модель предполагает, что есть как минимум 72 водяных козла. Мне интересно, если это вызывает проблемы для сэмплера. N<72
Sycorax говорит восстановить Монику

3
Я не думаю, что проблема в конвергенции. Я думаю , что проблема в том , что пробоотборник неэффективные из-за высокой степени корреляции на нескольких уровнях R^neffθ,N

Ответы:


7

Ну, так как ваш код работает, похоже, что этот ответ уже слишком поздний. Но я уже написал код, так что ...

Для чего это стоит, это та же * модель подходит с rstan. Он оценивается в 11 секунд на моем потребительском ноутбуке, что позволяет получить более эффективный размер выборки для наших параметров за меньшее количество итераций.(N,θ)

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

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,θy~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 

rstanNy¯=θ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, поскольку мы должны нарисовать границу (и конечные точки сетки), чтобы задача была вычислимой (я все еще жду на бесконечной ОЗУ). По правде говоря, наша модель имеет положительную вероятность(0,1)×{N|NZN72)}


+1 и принято. Я впечатлен! Я также пытался использовать Стэна для сравнения, но не смог перенести модель. Моя модель занимает около 2 минут, чтобы оценить.
COOLSerdash

Единственное отклонение от stan для этой проблемы - все параметры должны быть действительными, что делает его немного неудобным. Но так как вы можете оштрафовать правдоподобие любой произвольной функцией, вам просто нужно пройти через программирование ... И выкопать составные функции, чтобы сделать это ...
Sycorax говорит восстановить Monica

Да! Это была именно моя проблема. nне может быть объявлено как целое число, и я не знаю обходной путь для этой проблемы.
COOLSerdash

Около 2 минут на моем рабочем столе.
COOLSerdash

1
@COOLSerdash Вас может заинтересовать [этот] [1] вопрос, где я спрашиваю, какие из результатов сетки или rstanрезультаты являются более правильными. [1] stats.stackexchange.com/questions/114366/…
Sycorax сообщает, что восстановит Монику

3

λ

Вот мой сценарий анализа и результаты с использованием 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

N522233N

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

И 80% -HPD 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

N150(78;578)(80;598) .

Используя наш сайт, вы подтверждаете, что прочитали и поняли нашу Политику в отношении файлов cookie и Политику конфиденциальности.
Licensed under cc by-sa 3.0 with attribution required.