Часто буває так, що довірчий інтервал з покриттям 95% дуже схожий на достовірний інтервал, який містить 95% задньої щільності. Це відбувається, коли попередній є рівномірним або майже однорідним в останньому випадку. Таким чином, довірчий інтервал часто можна використовувати для наближення достовірного інтервалу і навпаки. Важливо, що з цього можна зробити висновок, що сильно неправильне трактування довірчого інтервалу як достовірного інтервалу мало практичне значення для багатьох простих випадків використання.
Існує ряд прикладів випадків, коли цього не відбувається, однак, схоже, всі вони прихильники байєсівської статистики намагаються довести, що у частолістському підході щось не так. У цих прикладах ми бачимо, що інтервал довіри містить неможливі значення тощо, що повинно показувати, що вони є нісенітницею.
Я не хочу повертатися до цих прикладів або філософської дискусії Баєсіана проти Частота.
Я просто шукаю приклади навпаки. Чи існують випадки, коли довірчі та достовірні інтервали істотно відрізняються, а інтервал, передбачений процедурою довіри, явно перевершує?
Для уточнення: мова йде про ситуацію, коли, як правило, очікується, що достовірний інтервал збігається з відповідним довірчим інтервалом, тобто при використанні плоских, рівномірних тощо. Мене не цікавить випадок, коли хтось обирає довільно поганого попереднього.
EDIT: У відповідь на відповідь @JaeHyeok Shin нижче, я повинен погодитися, що його приклад використовує правильну ймовірність. Я використав приблизну байєсівську обчислення, щоб оцінити правильний задній розподіл для тети нижче в R:
### Methods ###
# Packages
require(HDInterval)
# Define the likelihood
like <- function(k = 1.2, theta = 0, n_print = 1e5){
x = NULL
rule = FALSE
while(!rule){
x = c(x, rnorm(1, theta, 1))
n = length(x)
x_bar = mean(x)
rule = sqrt(n)*abs(x_bar) > k
if(n %% n_print == 0){ print(c(n, sqrt(n)*abs(x_bar))) }
}
return(x)
}
# Plot results
plot_res <- function(chain, i){
par(mfrow = c(2, 1))
plot(chain[1:i, 1], type = "l", ylab = "Theta", panel.first = grid())
hist(chain[1:i, 1], breaks = 20, col = "Grey", main = "", xlab = "Theta")
}
### Generate target data ###
set.seed(0123)
X = like(theta = 0)
m = mean(X)
### Get posterior estimate of theta via ABC ###
tol = list(m = 1)
nBurn = 1e3
nStep = 1e4
# Initialize MCMC chain
chain = as.data.frame(matrix(nrow = nStep, ncol = 2))
colnames(chain) = c("theta", "mean")
chain$theta[1] = rnorm(1, 0, 10)
# Run ABC
for(i in 2:nStep){
theta = rnorm(1, chain[i - 1, 1], 10)
prop = like(theta = theta)
m_prop = mean(prop)
if(abs(m_prop - m) < tol$m){
chain[i,] = c(theta, m_prop)
}else{
chain[i, ] = chain[i - 1, ]
}
if(i %% 100 == 0){
print(paste0(i, "/", nStep))
plot_res(chain, i)
}
}
# Remove burn-in
chain = chain[-(1:nBurn), ]
# Results
plot_res(chain, nrow(chain))
as.numeric(hdi(chain[, 1], credMass = 0.95))
Це 95% надійний інтервал:
> as.numeric(hdi(chain[, 1], credMass = 0.95))
[1] -1.400304 1.527371
ЗРІД №2:
Ось оновлення після коментарів @JaeHyeok Shin. Я намагаюсь зробити це максимально просто, але сценарій трохи складніше. Основні зміни:
- Зараз використовуємо допуск 0,001 для середнього (це було 1)
- Збільшена кількість кроків до 500 тис. Для врахування меншої толерантності
- Зменшила скорочення розподілу пропозицій до 1, щоб зменшити допуск (було 10)
- Додано просту ймовірність простої рнорми з n = 2k для порівняння
- Додано розмір вибірки (n) як підсумкову статистику, встановити допуск до 0,5 * n_target
Ось код:
### Methods ###
# Packages
require(HDInterval)
# Define the likelihood
like <- function(k = 1.3, theta = 0, n_print = 1e5, n_max = Inf){
x = NULL
rule = FALSE
while(!rule){
x = c(x, rnorm(1, theta, 1))
n = length(x)
x_bar = mean(x)
rule = sqrt(n)*abs(x_bar) > k
if(!rule){
rule = ifelse(n > n_max, TRUE, FALSE)
}
if(n %% n_print == 0){ print(c(n, sqrt(n)*abs(x_bar))) }
}
return(x)
}
# Define the likelihood 2
like2 <- function(theta = 0, n){
x = rnorm(n, theta, 1)
return(x)
}
# Plot results
plot_res <- function(chain, chain2, i, main = ""){
par(mfrow = c(2, 2))
plot(chain[1:i, 1], type = "l", ylab = "Theta", main = "Chain 1", panel.first = grid())
hist(chain[1:i, 1], breaks = 20, col = "Grey", main = main, xlab = "Theta")
plot(chain2[1:i, 1], type = "l", ylab = "Theta", main = "Chain 2", panel.first = grid())
hist(chain2[1:i, 1], breaks = 20, col = "Grey", main = main, xlab = "Theta")
}
### Generate target data ###
set.seed(01234)
X = like(theta = 0, n_print = 1e5, n_max = 1e15)
m = mean(X)
n = length(X)
main = c(paste0("target mean = ", round(m, 3)), paste0("target n = ", n))
### Get posterior estimate of theta via ABC ###
tol = list(m = .001, n = .5*n)
nBurn = 1e3
nStep = 5e5
# Initialize MCMC chain
chain = chain2 = as.data.frame(matrix(nrow = nStep, ncol = 2))
colnames(chain) = colnames(chain2) = c("theta", "mean")
chain$theta[1] = chain2$theta[1] = rnorm(1, 0, 1)
# Run ABC
for(i in 2:nStep){
# Chain 1
theta1 = rnorm(1, chain[i - 1, 1], 1)
prop = like(theta = theta1, n_max = n*(1 + tol$n))
m_prop = mean(prop)
n_prop = length(prop)
if(abs(m_prop - m) < tol$m &&
abs(n_prop - n) < tol$n){
chain[i,] = c(theta1, m_prop)
}else{
chain[i, ] = chain[i - 1, ]
}
# Chain 2
theta2 = rnorm(1, chain2[i - 1, 1], 1)
prop2 = like2(theta = theta2, n = 2000)
m_prop2 = mean(prop2)
if(abs(m_prop2 - m) < tol$m){
chain2[i,] = c(theta2, m_prop2)
}else{
chain2[i, ] = chain2[i - 1, ]
}
if(i %% 1e3 == 0){
print(paste0(i, "/", nStep))
plot_res(chain, chain2, i, main = main)
}
}
# Remove burn-in
nBurn = max(which(is.na(chain$mean) | is.na(chain2$mean)))
chain = chain[ -(1:nBurn), ]
chain2 = chain2[-(1:nBurn), ]
# Results
plot_res(chain, chain2, nrow(chain), main = main)
hdi1 = as.numeric(hdi(chain[, 1], credMass = 0.95))
hdi2 = as.numeric(hdi(chain2[, 1], credMass = 0.95))
2*1.96/sqrt(2e3)
diff(hdi1)
diff(hdi2)
Результати, де hdi1 - це моя "ймовірність", а hdi2 - проста rnorm (n, theta, 1):
> 2*1.96/sqrt(2e3)
[1] 0.08765386
> diff(hdi1)
[1] 1.087125
> diff(hdi2)
[1] 0.07499163
Тож після достатнього зниження допуску та за рахунок багатьох інших кроків MCMC ми можемо побачити очікувану ширину CrI для моделі rnorm.
