Stima bayesiana di

Questa domanda è un seguito tecnico di questa domanda .

Ho difficoltà a comprendere e replicare il modello presentato in Raftery (1988): Inferenza per il parametro binomiale $N$ : un approccio gerarchico di Bayes in WinBUGS / OpenBUGS / JAGS. Non si tratta solo di codice, quindi dovrebbe essere in argomento qui.

sfondo

Sia un insieme di conteggi di successo da una distribuzione binomiale con N e θ sconosciuti . Inoltre, suppongo che N segua una distribuzione di Poisson con il parametro μ (come discusso nel documento). Quindi, ogni x i ha una distribuzione di Poisson con media λ = μ θ . Voglio specificare i priori in termini di λ e θ .$x=(x_{1},\ldots,x_{n})$$N$$\theta$$N$$\mu$$x_{i}$$\lambda = \mu \theta$$\lambda$$\theta$

Supponendo che non ho alcuna buona conoscenza preliminare di o θ , voglio assegnare i priori non informativi sia a λ che a θ . Supponiamo che i miei priori siano λ ∼ G a m m a ( 0,001 , 0,001 ) e θ ∼ U n i f o r m ( 0 , 1 ) .$N$$\theta$$\lambda$$\theta$$\lambda\sim \mathrm{Gamma}(0.001, 0.001)$$\theta\sim \mathrm{Uniform}(0, 1)$

L'autore utilizza un priore improprio di ma WinBUGS non accetta priori impropri.$p(N,\theta)\propto N^{-1}$

Esempio

Nel documento (pagina 226) vengono forniti i seguenti conteggi di successo di waterbucks osservati: . Voglio stimare N , la dimensione della popolazione.$53, 57, 66, 67, 72$$N$

Ecco come ho provato a elaborare l'esempio in WinBUGS ( aggiornato dopo il commento di @ 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)

Il modello non Sill non converge bene dopo 500'000 campioni con i campioni 20'000 burn-in. Ecco l'output di una corsa 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

Domande

Chiaramente, mi manca qualcosa, ma non riesco a vedere cosa esattamente. Penso che la mia formulazione del modello sia sbagliata da qualche parte. Quindi le mie domande sono:

• Perché il mio modello e la sua implementazione non funzionano?
• Come si potrebbe formulare e implementare correttamente il modello fornito da Raftery (1988)?

Grazie per l'aiuto.

Bene, dal momento che il tuo codice funziona, sembra che questa risposta sia un po 'troppo tardi. Ma ho già scritto il codice, quindi ...

Per quello che vale, questo è lo stesso * modello adatto rstan. Viene stimato in 11 secondi sul mio laptop consumer, ottenendo una dimensione del campione effettiva più elevata per i nostri parametri di interesse in meno iterazioni.$(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))

Nota che ho lanciato thetacome 2-simplex. Questo è solo per stabilità numerica. La quantità di interesse è theta[1]; ovviamente theta[2]è un'informazione superflua.

* Come puoi vedere, il riassunto posteriore è praticamente identico e la promozione di in una quantità reale non sembra avere un impatto sostanziale sulle nostre inferenze.$N$

Il quantile del 97,5% per $N$ è più grande del 50% per il mio modello, ma penso che sia perché il campionatore di Stan è migliore nell'esplorare l'intera gamma del posteriore rispetto a una semplice camminata casuale, quindi può farlo più facilmente nelle code. Potrei sbagliarmi, però.

            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

Prendendo i valori di generati da stan, li utilizzo per disegnare valori predittivi posteriori ˜ y . Non dovremmo essere sorpresi che la media delle previsioni posteriori ˜ y sia molto vicina alla media dei dati del campione!$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 

Per verificare se il rstancampionatore è un problema o no, ho calcolato il posteriore su una griglia. Possiamo vedere che il posteriore è a forma di banana; questo tipo di posteriore può essere problematico per la metrica euclidea HMC. Ma controlliamo i risultati numerici. (La gravità della forma di banana è in realtà soppressa qui dal è sulla scala logaritmica.) Se si pensa alla forma di banana per un minuto, vi renderete conto che esso deve trovarsi sulla linea ˉ y = θ N .$N$$\bar{y}=\theta N$

Il codice seguente può confermare che i nostri risultati da Stan hanno senso.

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

Grazie ancora a @ StéphaneLaurent e @ user777 per il loro prezioso contributo nei commenti. Dopo qualche modifica del precedente per$\lambda$ Ora posso replicare i risultati dall'articolo di Raftery (1988).

Ecco il mio script di analisi e i risultati usando JAGS e 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")

Il calcolo ha richiesto circa 98 secondi sul mio PC desktop.

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

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

I risultati sono:

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 posteriore di $N$ è $522$ e la mediana posteriore è $233$. Ho calcolato la modalità posteriore di$N$ sulla scala logaritmica e trasformato indietro la stima:

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

E l'80% -HPD di $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

La modalità posteriore per $N$ è $150$ e l'80% di HPD è $(78; 578)$ che è molto vicino ai limiti indicati nel documento che sono $(80; 598)$.