Estimación bayesiana de

Esta pregunta es un seguimiento técnico de esta pregunta .

Tengo problemas para entender y replicar el modelo presentado en Raftery (1988): Inferencia para el parámetro binomial : un enfoque jerárquico de Bayes $N$ en WinBUGS / OpenBUGS / JAGS. Sin embargo, no se trata solo de código, por lo que debe ser sobre el tema aquí.

Antecedentes

Sea un conjunto de conteos exitosos de una distribución binomial con y desconocidos . Además, supongo que sigue una distribución de Poisson con el parámetro (como se discute en el documento). Entonces, cada tiene una distribución de Poisson con media . Quiero especificar los anteriores en términos de y . $x=(x_{1},\ldots,x_{n})$ $N$ $\theta$ $N$ $\mu$ $x_{i}$ $\lambda = \mu \theta$ $\lambda$ $\theta$

Suponiendo que no tengo ningún buen conocimiento previo sobre o , quiero asignar anteriores no informativos a y . Digamos, mis antecedentes son y . $N$ $\theta$ $\lambda$ $\theta$ $\lambda\sim \mathrm{Gamma}(0.001, 0.001)$ $\theta\sim \mathrm{Uniform}(0, 1)$

El autor utiliza un previo impropio de pero WinBUGS no acepta anteriores impropios. $p(N,\theta)\propto N^{-1}$

Ejemplo

En el documento (página 226), se proporcionan los siguientes recuentos de éxito de los waterbucks observados: . Quiero estimar , el tamaño de la población. $53, 57, 66, 67, 72$ $N$

Así es como traté de resolver el ejemplo en WinBUGS ( actualizado después del comentario de @ 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)

El modelo no alféizar no converge muy bien después de 500'000 muestras con 20'000 burn-en muestras. Aquí está el resultado de una ejecución 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

Preguntas

Claramente, me falta algo, pero no puedo ver qué exactamente. Creo que mi formulación del modelo es incorrecta en alguna parte. Entonces mis preguntas son:

¿Por qué mi modelo y su implementación no funcionan?
¿Cómo podría formularse e implementarse correctamente el modelo proporcionado por Raftery (1988)?

Gracias por tu ayuda.

— COOLSerdash
fuente

Siguiendo el documento debe agregar mu=lambda/thetay reemplazar n ~ dpois(lambda)conn ~ dpois(mu)

— Stéphane Laurent

@ StéphaneLaurent Gracias por la sugerencia. He cambiado el código en consecuencia. Lamentablemente, el modelo todavía no converge.

— COOLSerdash

¿Qué sucede cuando tomas muestras de

N < 72

$N<72$

— Sycorax dice Reinstate Monica

, la probabilidad es cero, porque su modelo supone que hay al menos 72 waterbuck. Me pregunto si eso está causando problemas a la muestra.

N < 72

$N<72$

— Sycorax dice Reinstate Monica el

\hat{R}

$\hat{R}$

n_{e f f}

$n_{eff}$

θ, N

$\theta, N$

Respuestas:

Bueno, ya que tienes tu código para trabajar, parece que esta respuesta es demasiado tarde. Pero ya escribí el código, así que ...

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

Tenga en cuenta que lanzo thetacomo un 2-simplex. Esto es solo para la estabilidad numérica. La cantidad de interés es theta[1]; Obviamente theta[2]es información superflua.

$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

$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 $N$ $\bar{y}=\theta N$

posterior over a grid

El siguiente código puede confirmar que nuestros resultados de Stan tienen sentido.

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\}$

— Sycorax dice reinstalar a Mónica
fuente

+1 y aceptado. ¡Estoy impresionado! También intenté usar Stan para una comparación, pero no pude transferir el modelo. Mi modelo tarda unos 2 minutos en estimarse.

— COOLSerdash

El único inconveniente con stan para este problema es que todos los parámetros deben ser reales, lo que lo hace un poco incómodo. Pero dado que puede penalizar la probabilidad de registro mediante cualquier función arbitraria, solo tiene que pasar por el problema para programarlo ... Y desenterrar las funciones compuestas para hacerlo ...

— Sycorax dice Reinstate Monica

¡Si! Ese fue exactamente mi problema. nno se puede declarar como un entero y no conocía una solución para el problema.

— COOLSerdash

Alrededor de 2 minutos en mi escritorio.

— COOLSerdash

@COOLSerdash Puede que le interese [esta] [1] pregunta, donde pregunto cuál de los resultados de la cuadrícula o los rstanresultados son más correctos. [1] stats.stackexchange.com/questions/114366/…

— Sycorax dice Reinstate Monica

$\lambda$

Aquí está mi script de análisis y resultados usando JAGS y 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")

La computación tomó alrededor de 98 segundos en mi PC de escritorio.

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

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

Los resultados son:

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

La media posterior de $N$ es $522$ y la mediana posterior es $233$ . Calculé el modo posterior de $N$ en la escala logarítmica y transformado de nuevo la estimació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

Y el 80% -HPD de $N$ es:

(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

El modo posterior para $N$ es $150$ y el 80% -HPD es $(78; 578)$ que está muy cerca de los límites dados en el documento que son $(80; 598)$ .

— COOLSerdash
fuente