bayestestR/ 0000755 0001762 0000144 00000000000 14650205472 012404 5 ustar ligges users bayestestR/tests/ 0000755 0001762 0000144 00000000000 14650200252 013535 5 ustar ligges users bayestestR/tests/testthat/ 0000755 0001762 0000144 00000000000 14650205472 015406 5 ustar ligges users bayestestR/tests/testthat/test-p_direction.R 0000644 0001762 0000144 00000002741 14505755602 021015 0 ustar ligges users test_that("p_direction", {
set.seed(333)
x <- distribution_normal(10000, 1, 1)
pd <- p_direction(x)
expect_equal(as.numeric(pd), 0.842, tolerance = 0.1)
expect_equal(as.numeric(p_direction(x, method = "kernel")), 0.842, tolerance = 0.1)
expect_s3_class(pd, "p_direction")
expect_s3_class(pd, "data.frame")
expect_identical(dim(pd), c(1L, 2L))
expect_identical(
capture.output(print(pd)),
c(
"Probability of Direction", "", "Parameter | pd", "------------------",
"Posterior | 84.13%"
)
)
df <- data.frame(replicate(4, rnorm(100)))
pd <- p_direction(df)
expect_s3_class(pd, "p_direction")
expect_s3_class(pd, "data.frame")
expect_identical(dim(pd), c(4L, 2L))
})
test_that("p_direction", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
m <- insight::download_model("stanreg_merMod_5")
p <- insight::get_parameters(m, effects = "all")
expect_equal(
p_direction(m, effects = "all")$pd,
p_direction(p)$pd,
tolerance = 1e-3
)
})
test_that("p_direction", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
m <- insight::download_model("brms_zi_3")
p <- insight::get_parameters(m, effects = "all", component = "all")
expect_equal(
p_direction(m, effects = "all", component = "all")$pd,
p_direction(p)$pd,
tolerance = 1e-3
)
})
bayestestR/tests/testthat/test-p_to_bf.R 0000644 0001762 0000144 00000000661 14410351152 020110 0 ustar ligges users test_that("p_to_bf works", {
skip_if_not_or_load_if_installed("parameters")
m <- lm(mpg ~ hp + cyl + am, data = mtcars)
p <- coef(summary(m))[-1, 4]
# BF by hand
bfs <- 3 * p * sqrt(insight::n_obs(m))
expect_equal(p_to_bf(m, log = FALSE)[-1, ]$BF, exp(-log(bfs)), tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(p_to_bf(m, log = TRUE)[-1, ]$log_BF, -log(bfs), tolerance = 1e-4, ignore_attr = TRUE)
})
bayestestR/tests/testthat/test-map_estimate.R 0000644 0001762 0000144 00000003276 14560763455 021200 0 ustar ligges users # numeric ----------------------
test_that("map_estimate", {
x <- distribution_normal(1000, 1)
MAP <- map_estimate(x)
expect_equal(as.numeric(MAP), 0.997, tolerance = 0.001, ignore_attr = TRUE)
expect_s3_class(MAP, "map_estimate")
expect_s3_class(MAP, "data.frame")
expect_identical(dim(MAP), c(1L, 2L))
expect_identical(
capture.output(print(MAP)),
c(
"MAP Estimate",
"",
"Parameter | MAP_Estimate",
"------------------------",
"x | 1.00"
)
)
})
# stanreg ----------------------
test_that("map_estimate", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("BayesFactor")
m <- insight::download_model("stanreg_merMod_5")
expect_equal(
map_estimate(m, effects = "all")$Parameter,
colnames(as.data.frame(m))[1:21]
)
})
# brms ----------------------
test_that("map_estimate", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("BayesFactor")
m <- insight::download_model("brms_zi_3")
expect_equal(
map_estimate(m, effects = "all", component = "all")$Parameter,
c(
"b_Intercept", "b_child", "b_camper", "r_persons[1,Intercept]",
"r_persons[2,Intercept]", "r_persons[3,Intercept]", "r_persons[4,Intercept]",
"sd_persons__Intercept", "b_zi_Intercept", "b_zi_child", "b_zi_camper",
"r_persons__zi[1,Intercept]", "r_persons__zi[2,Intercept]", "r_persons__zi[3,Intercept]",
"r_persons__zi[4,Intercept]", "sd_persons__zi_Intercept"
)
)
m <- correlationBF(y = iris$Sepal.Length, x = iris$Sepal.Width)
expect_error(map_estimate(m))
})
bayestestR/tests/testthat/test-print.R 0000644 0001762 0000144 00000000637 14560763455 017662 0 ustar ligges users test_that("print.describe_posterior", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
m <- insight::download_model("brms_zi_3")
expect_snapshot(describe_posterior(m, verbose = FALSE), variant = "windows")
expect_snapshot(describe_posterior(m, effects = "all", component = "all", verbose = FALSE), variant = "windows")
})
bayestestR/tests/testthat/test-format.R 0000644 0001762 0000144 00000003434 14560763455 020014 0 ustar ligges users test_that("p_significance", {
set.seed(333)
x <- rnorm(100)
expect_equal(
format(point_estimate(x)),
data.frame(Median = "0.05", Mean = "-0.02", MAP = "0.13", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
expect_equal(
format(ci(x)),
data.frame(`95% CI` = "[-1.93, 1.77]", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
expect_equal(
format(p_rope(x)),
data.frame(ROPE = "[-0.10, 0.10]", `p (ROPE)` = "0.100", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
expect_equal(
format(map_estimate(x)),
data.frame(Parameter = "x", MAP_Estimate = "0.13", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
expect_equal(
format(p_direction(x)),
data.frame(Parameter = "Posterior", pd = "51.00%", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
expect_equal(
format(p_map(x)),
data.frame(Parameter = "Posterior", p_MAP = "0.973", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
expect_equal(
format(p_significance(x)),
data.frame(Parameter = "Posterior", ps = "0.46", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
expect_equal(
format(rope(x)),
data.frame(CI = "0.95", ROPE = "[-0.10, 0.10]", `% in ROPE` = "10.64%", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
expect_equal(
format(equivalence_test(x)),
data.frame(
CI = "0.95", ROPE = "[-0.10, 0.10]", `% in ROPE` = "10.64%",
`Equivalence (ROPE)` = "Undecided", HDI_low = "-1.93", HDI_high = "1.77",
stringsAsFactors = FALSE
),
ignore_attr = TRUE
)
skip_if_not_installed("logspline")
expect_equal(
format(bayesfactor_parameters(x, verbose = FALSE)),
data.frame(BF = "1.00", stringsAsFactors = FALSE),
ignore_attr = TRUE
)
})
bayestestR/tests/testthat/test-hdi.R 0000644 0001762 0000144 00000005041 14461433341 017250 0 ustar ligges users # numeric -------------------------------
test_that("hdi", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
expect_equal(hdi(distribution_normal(1000), ci = 0.90)$CI_low[1], -1.64, tolerance = 0.02)
expect_equal(nrow(hdi(distribution_normal(1000), ci = c(0.80, 0.90, 0.95))), 3, tolerance = 0.01)
expect_equal(hdi(distribution_normal(1000), ci = 1)$CI_low[1], -3.29, tolerance = 0.02)
expect_identical(nchar(capture.output(print(hdi(distribution_normal(1000))))), 22L)
expect_length(capture.output(print(hdi(distribution_normal(1000), ci = c(0.80, 0.90)))), 5)
expect_message(hdi(c(2, 3, NA)))
expect_warning(hdi(c(2, 3)))
expect_message(hdi(distribution_normal(1000), ci = 0.0000001))
expect_warning(hdi(distribution_normal(1000), ci = 950))
expect_message(hdi(c(0, 0, 0)))
})
# stanreg ---------------------------
test_that("ci", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
m <- insight::download_model("stanreg_merMod_5")
p <- insight::get_parameters(m, effects = "all")
expect_equal(
hdi(m, ci = c(0.5, 0.8), effects = "all")$CI_low,
hdi(p, ci = c(0.5, 0.8))$CI_low,
tolerance = 1e-3
)
})
# brms ---------------------------
test_that("rope", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
m <- insight::download_model("brms_zi_3")
p <- insight::get_parameters(m, effects = "all", component = "all")
expect_equal(
hdi(m, ci = c(0.5, 0.8), effects = "all", component = "all")$CI_low,
hdi(p, ci = c(0.5, 0.8))$CI_low,
tolerance = 1e-3
)
})
# BayesFactor ---------------------------
test_that("ci - BayesFactor", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
mod_bf <- proportionBF(y = 15, N = 25, p = 0.5)
p_bf <- insight::get_parameters(mod_bf)
expect_equal(
hdi(mod_bf, ci = c(0.5, 0.8), effects = "all", component = "all")$CI_low,
hdi(p_bf, ci = c(0.5, 0.8))$CI_low,
tolerance = 0.1
)
})
bayestestR/tests/testthat/test-describe_prior.R 0000644 0001762 0000144 00000010437 14561435021 021502 0 ustar ligges users test_that("describe_prior", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
skip_on_os("linux")
# Bayes Factor ----------------------------------------
expect_equal(
describe_prior(correlationBF(mtcars$wt, mtcars$mpg, rscale = 0.5)),
structure(list(
Parameter = "rho", Prior_Distribution = "beta",
Prior_Location = 2, Prior_Scale = 2
), class = "data.frame", row.names = c(
NA,
-1L
))
)
expect_equal(
describe_prior(ttestBF(mtcars$wt, mu = 3)),
structure(list(
Parameter = "Difference", Prior_Distribution = "cauchy",
Prior_Location = 0, Prior_Scale = 0.707106781186548
), class = "data.frame", row.names = c(
NA,
-1L
))
)
expect_equal(
describe_prior(contingencyTableBF(
x = table(mtcars$am, mtcars$cyl),
sampleType = "poisson"
)),
structure(list(
Parameter = "Ratio", Prior_Distribution = "poisson",
Prior_Location = 0, Prior_Scale = 1
), class = "data.frame", row.names = c(
NA,
-1L
))
)
expect_equal(
describe_prior(contingencyTableBF(
x = table(mtcars$am, mtcars$cyl),
sampleType = "indepMulti",
fixedMargin = "cols",
priorConcentration = 1.6
)),
structure(list(
Parameter = "Ratio", Prior_Distribution = "independent multinomial",
Prior_Location = 0, Prior_Scale = 1.6
), class = "data.frame", row.names = c(
NA,
-1L
))
)
expect_equal(
describe_prior(anovaBF(extra ~ group, data = sleep, progress = FALSE)),
structure(list(Parameter = c(
"group-1", "group-2", "mu", "sig2",
"g_group"
), Prior_Distribution = c(
"cauchy", "cauchy", NA, NA,
NA
), Prior_Location = c(0, 0, NA, NA, NA), Prior_Scale = c(
0.5,
0.5, NA, NA, NA
)), row.names = c(NA, -5L), class = "data.frame")
)
# brms ----------------------------------------
mod_brms <- insight::download_model("brms_1")
expect_equal(
describe_prior(mod_brms),
structure(
list(
Parameter = c("b_Intercept", "b_wt", "b_cyl", "sigma"),
Prior_Distribution = c("student_t", "uniform", "uniform", "student_t"),
Prior_Location = c(19.2, NA, NA, 0),
Prior_Scale = c(5.4, NA, NA, 5.4),
Prior_df = c(3, NA, NA, 3)
),
row.names = c(NA, -4L),
class = "data.frame",
priors = structure(
list(
prior = c(
"(flat)", "(flat)", "(flat)", "student_t(3, 19.2, 5.4)",
"student_t(3, 0, 5.4)"
),
class = c("b", "b", "b", "Intercept", "sigma"),
coef = c("", "cyl", "wt", "", ""),
group = c("", "", "", "", ""),
resp = c("", "", "", "", ""),
dpar = c("", "", "", "", ""),
nlpar = c("", "", "", "", ""),
bound = c("", "", "", "", ""),
source = c(
"(unknown)", "(vectorized)", "(vectorized)", "(unknown)",
"(unknown)"
),
Parameter = c("b_", "b_cyl", "b_wt", "b_Intercept", "sigma")
),
special = list(mu = list()),
row.names = c(NA, -5L),
sample_prior = "no",
class = "data.frame"
)
),
ignore_attr = TRUE,
tolerance = 1e-2
)
# stanreg ----------------------------------------
mod_stanreg1 <- insight::download_model("stanreg_gamm4_1")
mod_stanreg2 <- insight::download_model("stanreg_merMod_1")
expect_equal(
describe_prior(mod_stanreg1),
structure(list(
Parameter = "(Intercept)", Prior_Distribution = "normal",
Prior_Location = 3.05733333333333, Prior_Scale = 1.08966571234175
), row.names = c(
NA,
-1L
), class = "data.frame")
)
expect_equal(
describe_prior(mod_stanreg2),
structure(
list(
Parameter = c("(Intercept)", "cyl"),
Prior_Distribution = c(
"normal",
"normal"
), Prior_Location = c(0, 0),
Prior_Scale = c(2.5, 1.39983744766986)
),
row.names = c(NA, -2L), class = "data.frame"
)
)
})
bayestestR/tests/testthat/test-p_map.R 0000644 0001762 0000144 00000003257 14505755602 017615 0 ustar ligges users test_that("p_map", {
x <- distribution_normal(1000, 0.4)
pmap <- p_map(x)
expect_equal(as.numeric(pmap), 0.9285376, tolerance = 0.001)
expect_s3_class(pmap, "p_map")
expect_s3_class(pmap, "data.frame")
expect_identical(dim(pmap), c(1L, 2L))
expect_identical(
capture.output(print(pmap)),
c(
"MAP-based p-value", "", "Parameter | p (MAP)",
"-------------------", "Posterior | 0.929"
)
)
expect_equal(as.numeric(p_map(distribution_normal(1000))), 1, tolerance = 0.1)
expect_equal(as.numeric(p_map(distribution_normal(1000, 1, 1))), 0.62, tolerance = 0.1)
expect_equal(as.numeric(p_map(distribution_normal(1000, 2, 1))), 0.15, tolerance = 0.1)
expect_equal(as.numeric(p_map(distribution_normal(1000, 3, 0.01))), 0, tolerance = 0.1)
})
test_that("p_map", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
m <- insight::download_model("stanreg_merMod_5")
p <- insight::get_parameters(m, effects = "all")
expect_equal(
p_map(m, effects = "all")$p_MAP,
p_map(p)$p_MAP,
tolerance = 0.1
)
})
test_that("p_map", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
m <- insight::download_model("brms_zi_3")
p <- insight::get_parameters(m, effects = "all", component = "all")
expect_equal(
p_map(m, effects = "all", component = "all")$p_MAP,
p_map(p)$p_MAP,
tolerance = 0.1
)
})
test_that("p_map | null", {
x <- distribution_normal(4000, mean = 1)
expect_equal(as.numeric(p_map(x)), 0.6194317, ignore_attr = TRUE, tolerance = 0.01)
expect_equal(as.numeric(p_map(x, null = 1)), 1, ignore_attr = TRUE, tolerance = 0.01)
})
bayestestR/tests/testthat/test-bayesian_as_frequentist.R 0000644 0001762 0000144 00000005300 14650172354 023415 0 ustar ligges users skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("httr2")
test_that("rstanarm to freq", {
skip_if_not_or_load_if_installed("rstanarm")
set.seed(333)
m <- insight::download_model("stanreg_glm_1")
m1 <- glm(vs ~ wt, data = mtcars, family = "binomial")
m2 <- convert_bayesian_as_frequentist(m)
expect_equal(coef(m1), coef(m2), tolerance = 1e-3)
})
test_that("rstanarm to freq", {
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("lme4")
set.seed(333)
m <- insight::download_model("stanreg_lmerMod_1")
m1 <- lme4::lmer(wt ~ cyl + (1 | gear), data = mtcars)
m2 <- convert_bayesian_as_frequentist(m)
expect_equal(lme4::fixef(m1), lme4::fixef(m2), tolerance = 1e-3)
})
test_that("brms beta to freq", {
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("glmmTMB")
skip_if_not_or_load_if_installed("lme4")
skip_if_not_or_load_if_installed("betareg")
set.seed(333)
m <- insight::download_model("brms_beta_1")
data(FoodExpenditure, package = "betareg")
m1 <- glmmTMB::glmmTMB(
I(food / income) ~ income + (1 | persons),
data = FoodExpenditure,
family = glmmTMB::beta_family()
)
m2 <- convert_bayesian_as_frequentist(m)
expect_equal(lme4::fixef(m1)$cond[2], lme4::fixef(m2)$cond[2], tolerance = 1e-2)
})
test_that("ordbetareg to freq", {
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("ordbetareg")
skip_if_not_or_load_if_installed("glmmTMB")
skip_if_not_or_load_if_installed("lme4")
skip_if_not_or_load_if_installed("datawizard")
set.seed(333)
data(sleepstudy, package = "lme4")
m <- insight::download_model("ordbetareg_1")
sleepstudy$y <- datawizard::normalize(sleepstudy$Reaction)
m1 <- glmmTMB::glmmTMB(
y ~ Days + (Days | Subject),
data = sleepstudy,
family = glmmTMB::ordbeta()
)
m2 <- convert_bayesian_as_frequentist(m)
expect_equal(lme4::fixef(m1), lme4::fixef(m2), tolerance = 1e-1)
})
test_that("brms 0 + Intercept to freq", {
skip_if_not_or_load_if_installed("brms")
set.seed(333)
data(mtcars)
m <- brms::brm(qsec ~ 0 + Intercept + mpg, data = mtcars, refresh = 0)
m1 <- lm(qsec ~ mpg, data = mtcars)
m2 <- convert_bayesian_as_frequentist(m)
expect_equal(coef(m1), coef(m2), tolerance = 1e-2)
})
test_that("brms Interaction terms to freq", {
skip_if_not_or_load_if_installed("brms")
set.seed(333)
m <- brms::brm(qsec ~ mpg * as.factor(am), data = mtcars, refresh = 0)
m1 <- lm(qsec ~ mpg * as.factor(am), data = mtcars)
m2 <- convert_bayesian_as_frequentist(m)
expect_equal(coef(m1), coef(m2), tolerance = 1e-2)
})
bayestestR/tests/testthat/test-bayesfactor_parameters.R 0000644 0001762 0000144 00000010051 14561127323 023227 0 ustar ligges users test_that("bayesfactor_parameters data frame", {
skip_if_not_or_load_if_installed("logspline", "2.1.21")
Xprior <- data.frame(
x = distribution_normal(1e4),
y = distribution_normal(1e4)
)
Xposterior <- data.frame(
x = distribution_normal(1e4, mean = 0.5),
y = distribution_normal(1e4, mean = -0.5)
)
# point
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = 0, direction = 0, verbose = FALSE)
expect_equal(bfsd$log_BF, c(0.12, 0.12), tolerance = 0.1)
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = 0, direction = 1, verbose = FALSE)
expect_equal(bfsd$log_BF, c(0.44, -0.35), tolerance = 0.1)
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = 0, direction = -1, verbose = FALSE)
expect_equal(bfsd$log_BF, c(-0.35, 0.44), tolerance = 0.1)
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = 0.5, direction = 0, verbose = FALSE)
expect_equal(bfsd$log_BF, c(-0.12, 0.37), tolerance = 0.1)
expect_warning(bayesfactor_parameters(Xposterior, Xprior))
w <- capture_warnings(bfsd <- bayesfactor_parameters(Xposterior))
expect_match(w, "Prior", all = FALSE)
expect_match(w, "40", all = FALSE)
expect_equal(bfsd$log_BF, c(0, 0), tolerance = 0.1)
# interval
expect_warning(
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = c(-.1, .1), direction = 0),
regexp = NA
)
expect_equal(bfsd$log_BF, c(0.13, 0.13), tolerance = 0.1)
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = c(-.1, .1), direction = 1)
expect_equal(bfsd$log_BF, c(0.47, -0.39), tolerance = 0.1)
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = c(-.1, .1), direction = -1)
expect_equal(bfsd$log_BF, c(-0.39, 0.47), tolerance = 0.1)
# interval with inf
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = c(-.1, Inf))
expect_equal(bfsd$log_BF, c(-0.81, 0.80), tolerance = 0.1)
bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = c(-Inf, .1))
expect_equal(bfsd$log_BF, c(0.80, -0.81), tolerance = 0.1)
})
test_that("bayesfactor_parameters RSTANARM", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("logspline", "2.1.21")
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("httr")
fit <- suppressMessages(stan_glm(mpg ~ ., data = mtcars, refresh = 0))
set.seed(333)
fit_p <- unupdate(fit, verbose = FALSE)
expect_warning(BF2 <- bayesfactor_parameters(fit, fit_p))
set.seed(333)
BF1 <- bayesfactor_parameters(fit, verbose = FALSE)
BF3 <- bayesfactor_parameters(insight::get_parameters(fit), insight::get_parameters(fit_p), verbose = FALSE)
expect_equal(BF1, BF2)
expect_equal(BF1[["Parameter"]], BF3[["Parameter"]])
expect_equal(BF1[["log_BF"]], BF3[["log_BF"]])
model_flat <- suppressMessages(
stan_glm(extra ~ group, data = sleep, prior = NULL, refresh = 0)
)
suppressMessages(
expect_error(bayesfactor_parameters(model_flat))
)
skip_on_ci()
fit10 <- update(fit, chains = 10, iter = 5100, warmup = 100)
suppressMessages(
expect_warning(bayesfactor_parameters(fit10), regexp = NA)
)
})
# bayesfactor_parameters BRMS ---------------------------------------------
test_that("bayesfactor_parameters BRMS", {
skip_if_offline()
skip_if_not_or_load_if_installed("logspline", "2.1.21")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("cmdstanr")
brms_mixed_6 <- insight::download_model("brms_mixed_6")
set.seed(222)
brms_mixed_6_p <- unupdate(brms_mixed_6)
bfsd1 <- suppressWarnings(bayesfactor_parameters(brms_mixed_6, brms_mixed_6_p, effects = "fixed"))
set.seed(222)
bfsd2 <- suppressWarnings(bayesfactor_parameters(brms_mixed_6, effects = "fixed"))
expect_equal(bfsd1$log_BF, bfsd2$log_BF, tolerance = 0.11)
brms_mixed_1 <- insight::download_model("brms_mixed_1")
expect_error(bayesfactor_parameters(brms_mixed_1))
})
bayestestR/tests/testthat/test-contr.R 0000644 0001762 0000144 00000003465 14357655465 017662 0 ustar ligges users test_that("contr.equalprior | gen", {
skip_on_cran()
set.seed(1234)
k <- 3
g <- 4.1
contr1 <- contr.equalprior(k, contrasts = TRUE)
contr2 <- contr.equalprior(k, contrasts = FALSE)
samps1 <- replicate(ncol(contr1), {
rnorm(4e3, 0, g)
})
samps2 <- replicate(ncol(contr2), {
rnorm(4e3, 0, g)
})
means1 <- t(contr1 %*% t(samps1))
means2 <- t(contr2 %*% t(samps2))
expect_equal(mean(apply(means1, 2, sd)), mean(apply(means2, 2, sd)), tolerance = 0.1)
})
test_that("contr.equalprior | pairs", {
skip_on_cran()
set.seed(1234)
k <- 3
g <- 4.1
contr1 <- contr.equalprior_pairs(k, contrasts = TRUE)
contr2 <- contr.equalprior_pairs(k, contrasts = FALSE)
samps1 <- replicate(ncol(contr1), {
rnorm(4e3, 0, g)
})
samps2 <- replicate(ncol(contr2), {
rnorm(4e3, 0, g)
})
means1 <- t(contr1 %*% t(samps1))
means2 <- t(contr2 %*% t(samps2))
w <- matrix(c(
-1, 1, 0,
1, 0, -1,
0, -1, 1
), 3, 3)
pairs1 <- t(w %*% t(means1))
pairs2 <- t(w %*% t(means2))
expect_equal(mean(apply(pairs1, 2, sd)), g, tolerance = 0.1)
expect_equal(mean(apply(pairs1, 2, sd)), mean(apply(pairs2, 2, sd)), tolerance = 0.1)
})
test_that("contr.equalprior | dev", {
skip_on_cran()
set.seed(1234)
k <- 3
g <- 4.1
contr1 <- contr.equalprior_deviations(k, contrasts = TRUE)
contr2 <- contr.equalprior_deviations(k, contrasts = FALSE)
samps1 <- replicate(ncol(contr1), {
rnorm(4e3, 0, g)
})
samps2 <- replicate(ncol(contr2), {
rnorm(4e3, 0, g)
})
means1 <- t(contr1 %*% t(samps1))
means2 <- t(contr2 %*% t(samps2))
expect_equal(mean(apply(means1, 2, sd)), g, tolerance = 0.1)
expect_equal(mean(apply(means1, 2, sd)), mean(apply(means2, 2, sd)), tolerance = 0.1)
})
bayestestR/tests/testthat/test-spi.R 0000644 0001762 0000144 00000004654 14410351152 017301 0 ustar ligges users # numeric -------------------------------
test_that("spi", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
expect_equal(spi(distribution_normal(1000), ci = .90)$CI_low[1], -1.65, tolerance = 0.02)
expect_equal(nrow(spi(distribution_normal(1000), ci = c(.80, .90, .95))), 3, tolerance = 0.01)
expect_equal(spi(distribution_normal(1000), ci = 1)$CI_low[1], -3.29, tolerance = 0.02)
expect_equal(nchar(capture.output(print(spi(distribution_normal(1000))))), 22)
expect_equal(length(capture.output(print(spi(distribution_normal(1000), ci = c(.80, .90))))), 5)
expect_error(spi(c(2, 3, NA)))
expect_warning(spi(c(2, 3)))
expect_message(spi(distribution_normal(1000), ci = 0.0000001))
expect_warning(spi(distribution_normal(1000), ci = 950))
expect_message(spi(c(0, 0, 0)))
})
test_that("ci", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
m <- insight::download_model("stanreg_merMod_5")
p <- insight::get_parameters(m, effects = "all")
expect_equal(
spi(m, ci = c(0.5, 0.8), effects = "all")$CI_low,
spi(p, ci = c(0.5, 0.8))$CI_low,
tolerance = 1e-3
)
})
test_that("spi brms", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
m <- insight::download_model("brms_zi_3")
p <- insight::get_parameters(m, effects = "all", component = "all")
expect_equal(
spi(m, ci = c(0.5, 0.8), effects = "all", component = "all")$CI_low,
spi(p, ci = c(0.5, 0.8))$CI_low,
tolerance = 1e-3
)
})
test_that("ci - BayesFactor", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
mod_bf <- proportionBF(y = 15, N = 25, p = .5)
p_bf <- insight::get_parameters(mod_bf)
expect_equal(
spi(mod_bf, ci = c(0.5, 0.8), effects = "all", component = "all")$CI_low,
spi(p_bf, ci = c(0.5, 0.8))$CI_low,
tolerance = 0.1
)
})
bayestestR/tests/testthat/test-weighted_posteriors.R 0000644 0001762 0000144 00000005261 14561435021 022577 0 ustar ligges users skip_on_os("linux")
test_that("weighted_posteriors for BayesFactor", {
skip_on_cran()
skip_if_not_or_load_if_installed("BayesFactor")
set.seed(123)
# compute Bayes Factor for 31 different regression models
null_den <- regressionBF(
mpg ~ cyl + disp + hp + drat + wt,
data = mtcars,
progress = FALSE
)
wBF <- weighted_posteriors(null_den)
expect_s3_class(wBF, "data.frame")
expect_equal(
attr(wBF, "weights")$weights,
c(
0, 13, 9, 0, 0, 55, 11, 4, 4, 1246, 6, 2, 38, 4, 946, 12, 3,
3, 209, 3, 491, 174, 4, 134, 7, 293, 1, 123, 35, 92, 51, 27
),
ignore_attr = TRUE
)
})
test_that("weighted_posteriors for BayesFactor (intercept)", {
# fails for win old-release
skip_on_ci()
skip_on_cran()
skip_if_not_or_load_if_installed("BayesFactor")
set.seed(123)
dat <- data.frame(
x1 = rnorm(10),
x2 = rnorm(10),
y = rnorm(10)
)
BFmods <- regressionBF(y ~ x1 + x2, data = dat, progress = FALSE)
res <- weighted_posteriors(BFmods)
expect_equal(attr(res, "weights")$weights, c(1032, 805, 1388, 775))
wHDI <- hdi(res[c("x1", "x2")], ci = 0.9)
expect_equal(wHDI$CI_low, c(-0.519, -0.640), tolerance = 0.01)
expect_equal(wHDI$CI_high, c(0.150, 0.059), tolerance = 0.01)
})
test_that("weighted_posteriors for nonlinear BayesFactor", {
skip_on_cran()
skip_if_not_or_load_if_installed("BayesFactor")
set.seed(123)
data(sleep)
BFS <- ttestBF(
x = sleep$extra[sleep$group == 1],
y = sleep$extra[sleep$group == 2],
nullInterval = c(-Inf, 0),
paired = TRUE
)
res <- weighted_posteriors(BFS)
expect_equal(attributes(res)$weights$weights, c(113, 3876, 11))
})
test_that("weighted_posteriors vs posterior_average", {
skip("Test creates error, must check why...")
skip_on_cran()
skip_if_not_or_load_if_installed("BayesFactor")
skip_if_not_or_load_if_installed("brms")
fit1 <- brm(rating ~ treat + period + carry,
data = inhaler,
refresh = 0,
silent = TRUE,
save_pars = save_pars(all = TRUE)
)
fit2 <- brm(rating ~ period + carry,
data = inhaler,
refresh = 0,
silent = TRUE,
save_pars = save_pars(all = TRUE)
)
set.seed(444)
expect_warning(res_BT <- weighted_posteriors(fit1, fit2))
set.seed(444)
res_brms <- brms::posterior_average(fit1, fit2, weights = "bma", missing = 0)
res_brms <- res_brms[, 1:4]
res_BT1 <- eti(res_BT)
res_brms1 <- eti(res_brms)
expect_equal(res_BT1$Parameter, res_brms1$Parameter)
expect_equal(res_BT1$CI, res_brms1$CI)
expect_equal(res_BT1$CI_low, res_brms1$CI_low)
expect_equal(res_BT1$CI_high, res_brms1$CI_high)
})
bayestestR/tests/testthat/test-emmGrid.R 0000644 0001762 0000144 00000015215 14413523767 020105 0 ustar ligges users # TODO: decide how to rearrange the tests
skip_on_ci()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("emmeans")
set.seed(300)
model <- stan_glm(extra ~ group,
data = sleep,
refresh = 0,
chains = 6, iter = 7000, warmup = 200
)
em_ <- emmeans(model, ~group)
c_ <- pairs(em_)
emc_ <- emmeans(model, pairwise ~ group)
all_ <- rbind(em_, c_)
all_summ <- summary(all_)
set.seed(4)
model_p <- unupdate(model, verbose = FALSE)
set.seed(300)
# estimate + hdi ----------------------------------------------------------
test_that("emmGrid hdi", {
xhdi <- hdi(all_, ci = 0.95)
expect_equal(xhdi$CI_low, all_summ$lower.HPD, tolerance = 0.1)
expect_equal(xhdi$CI_high, all_summ$upper.HPD, tolerance = 0.1)
xhdi2 <- hdi(emc_, ci = 0.95)
expect_equal(xhdi$CI_low, xhdi2$CI_low)
})
test_that("emmGrid point_estimate", {
xpest <- point_estimate(all_, centrality = "all", dispersion = TRUE)
expect_equal(xpest$Median, all_summ$emmean, tolerance = 0.1)
xpest2 <- point_estimate(emc_, centrality = "all", dispersion = TRUE)
expect_equal(xpest$Median, xpest2$Median)
})
# Basics ------------------------------------------------------------------
test_that("emmGrid ci", {
xci <- ci(all_, ci = 0.9)
expect_equal(length(xci$CI_low), 3)
expect_equal(length(xci$CI_high), 3)
})
test_that("emmGrid eti", {
xeti <- eti(all_, ci = 0.9)
expect_equal(length(xeti$CI_low), 3)
expect_equal(length(xeti$CI_high), 3)
})
test_that("emmGrid equivalence_test", {
xeqtest <- equivalence_test(all_, ci = 0.9, range = c(-0.1, 0.1))
expect_equal(length(xeqtest$ROPE_Percentage), 3)
expect_equal(length(xeqtest$ROPE_Equivalence), 3)
})
test_that("emmGrid estimate_density", {
xestden <- estimate_density(c_, method = "logspline", precision = 5)
expect_equal(length(xestden$x), 5)
})
test_that("emmGrid map_estimate", {
xmapest <- map_estimate(all_, method = "kernel")
expect_equal(length(xmapest$MAP_Estimate), 3)
})
test_that("emmGrid p_direction", {
xpd <- p_direction(all_, method = "direct")
expect_equal(length(xpd$pd), 3)
})
test_that("emmGrid p_map", {
xpmap <- p_map(all_, precision = 2^9)
expect_equal(length(xpmap$p_MAP), 3)
})
test_that("emmGrid p_rope", {
xprope <- p_rope(all_, range = c(-0.1, 0.1))
expect_equal(length(xprope$p_ROPE), 3)
})
test_that("emmGrid p_significance", {
xsig <- p_significance(all_, threshold = c(-0.1, 0.1))
expect_equal(length(xsig$ps), 3)
})
test_that("emmGrid rope", {
xrope <- rope(all_, range = "default", ci = .9)
expect_equal(length(xrope$ROPE_Percentage), 3)
})
# describe_posterior ------------------------------------------------------
test_that("emmGrid describe_posterior", {
expect_equal(
describe_posterior(all_)$median,
describe_posterior(emc_)$median
)
skip_on_cran()
expect_equal(
describe_posterior(all_, bf_prior = model_p, test = "bf")$log_BF,
describe_posterior(emc_, bf_prior = model_p, test = "bf")$log_BF
)
})
# BFs ---------------------------------------------------------------------
test_that("emmGrid bayesfactor_parameters", {
skip_on_cran()
set.seed(4)
expect_equal(
bayesfactor_parameters(all_, prior = model, verbose = FALSE),
bayesfactor_parameters(all_, prior = model_p, verbose = FALSE),
tolerance = 0.001
)
emc_p <- emmeans(model_p, pairwise ~ group)
xbfp <- bayesfactor_parameters(all_, prior = model_p, verbose = FALSE)
xbfp2 <- bayesfactor_parameters(emc_, prior = model_p, verbose = FALSE)
xbfp3 <- bayesfactor_parameters(emc_, prior = emc_p, verbose = FALSE)
expect_equal(xbfp$log_BF, xbfp2$log_BF, tolerance = 0.1)
expect_equal(xbfp$log_BF, xbfp3$log_BF, tolerance = 0.1)
expect_warning(
suppressMessages(
bayesfactor_parameters(all_)
),
regexp = "Prior not specified"
)
# error - cannot deal with regrid / transform
e <- capture_error(suppressMessages(bayesfactor_parameters(regrid(all_), prior = model)))
expect_match(as.character(e), "Unable to reconstruct prior estimates")
})
test_that("emmGrid bayesfactor_restricted", {
skip_on_cran()
set.seed(4)
hyps <- c("`1` < `2`", "`1` < 0")
xrbf <- bayesfactor_restricted(em_, prior = model_p, hypothesis = hyps)
expect_equal(length(xrbf$log_BF), 2)
expect_equal(length(xrbf$p_prior), 2)
expect_equal(length(xrbf$p_posterior), 2)
expect_warning(bayesfactor_restricted(em_, hypothesis = hyps))
xrbf2 <- bayesfactor_restricted(emc_, prior = model_p, hypothesis = hyps)
expect_equal(xrbf, xrbf2, tolerance = 0.1)
})
test_that("emmGrid si", {
skip_on_cran()
set.seed(4)
xrsi <- si(all_, prior = model_p, verbose = FALSE)
expect_equal(length(xrsi$CI_low), 3)
expect_equal(length(xrsi$CI_high), 3)
xrsi2 <- si(emc_, prior = model_p, verbose = FALSE)
expect_equal(xrsi$CI_low, xrsi2$CI_low)
expect_equal(xrsi$CI_high, xrsi2$CI_high)
})
# For non linear models ---------------------------------------------------
set.seed(333)
df <- data.frame(
G = rep(letters[1:3], each = 2),
Y = rexp(6)
)
fit_bayes <- stan_glm(Y ~ G,
data = df,
family = Gamma(link = "identity"),
refresh = 0
)
fit_bayes_prior <- unupdate(fit_bayes, verbose = FALSE)
bayes_sum <- emmeans(fit_bayes, ~G)
bayes_sum_prior <- emmeans(fit_bayes_prior, ~G)
test_that("emmGrid bayesfactor_parameters", {
set.seed(333)
skip_on_cran()
xsdbf1 <- bayesfactor_parameters(bayes_sum, prior = fit_bayes, verbose = FALSE)
xsdbf2 <- bayesfactor_parameters(bayes_sum, prior = bayes_sum_prior, verbose = FALSE)
expect_equal(xsdbf1$log_BF, xsdbf2$log_BF, tolerance = 0.1)
})
# link vs response
test_that("emmGrid bayesfactor_parameters / describe w/ nonlinear models", {
skip_on_cran()
model <- stan_glm(vs ~ mpg,
data = mtcars,
family = "binomial",
refresh = 0
)
probs <- emmeans(model, "mpg", type = "resp")
link <- emmeans(model, "mpg")
probs_summ <- summary(probs)
link_summ <- summary(link)
xhdi <- hdi(probs, ci = 0.95)
xpest <- point_estimate(probs, centrality = "median", dispersion = TRUE)
expect_equal(xhdi$CI_low, probs_summ$lower.HPD, tolerance = 0.1)
expect_equal(xhdi$CI_high, probs_summ$upper.HPD, tolerance = 0.1)
expect_equal(xpest$Median, probs_summ$prob, tolerance = 0.1)
xhdi <- hdi(link, ci = 0.95)
xpest <- point_estimate(link, centrality = "median", dispersion = TRUE)
expect_equal(xhdi$CI_low, link_summ$lower.HPD, tolerance = 0.1)
expect_equal(xhdi$CI_high, link_summ$upper.HPD, tolerance = 0.1)
expect_equal(xpest$Median, link_summ$emmean, tolerance = 0.1)
})
bayestestR/tests/testthat/test-ci.R 0000644 0001762 0000144 00000004075 14505757365 017123 0 ustar ligges users test_that("ci", {
skip_on_os(c("mac", "linux"))
skip_if_not_or_load_if_installed("quadprog")
set.seed(123)
x <- rnorm(1000, 3, 2)
expect_error(ci(x, method = "FDI"), regex = "`method` should be 'ETI'")
out <- capture.output(print(ci(x, method = "SPI")))
expect_identical(out, "95% SPI: [-1.16, 6.76]")
out <- capture.output(print(ci(x, method = "BCI")))
expect_identical(out, "95% ETI: [-0.88, 7.08]")
})
test_that("ci", {
expect_equal(ci(distribution_normal(1000), ci = 0.90)$CI_low[1], -1.6361, tolerance = 0.02)
expect_equal(nrow(ci(distribution_normal(1000), ci = c(0.80, 0.90, 0.95))), 3, tolerance = 0.01)
expect_equal(ci(distribution_normal(1000), ci = 1)$CI_low[1], -3.29, tolerance = 0.02)
expect_length(capture.output(print(ci(distribution_normal(1000), ci = c(0.80, 0.90)))), 5)
expect_equal(ci(c(2, 3, NA))$CI_low, 2.02, tolerance = 1e-2)
expect_warning(ci(c(2, 3)))
expect_warning(ci(distribution_normal(1000), ci = 950))
x <- data.frame(replicate(4, rnorm(100)))
x <- ci(x, ci = c(0.68, 0.89, 0.95))
a <- datawizard::reshape_ci(x)
expect_identical(c(nrow(x), ncol(x)), c(12L, 4L))
expect_true(all(datawizard::reshape_ci(a) == x))
})
test_that("ci", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("brms")
m <- insight::download_model("stanreg_merMod_5")
p <- insight::get_parameters(m, effects = "all")
expect_equal(
ci(m, ci = c(0.5, 0.8), effects = "all")$CI_low,
ci(p, ci = c(0.5, 0.8))$CI_low,
tolerance = 1e-3
)
})
test_that("rope", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("brms")
m <- insight::download_model("brms_zi_3")
p <- insight::get_parameters(m, effects = "all", component = "all")
expect_equal(
ci(m, ci = c(0.5, 0.8), effects = "all", component = "all")$CI_low,
ci(p, ci = c(0.5, 0.8))$CI_low,
tolerance = 1e-3
)
})
bayestestR/tests/testthat/test-posterior.R 0000644 0001762 0000144 00000010732 14410351152 020526 0 ustar ligges users test_that("mp-posterior-draws", {
skip_if_offline()
skip_if_not_or_load_if_installed("posterior")
skip_if_not_or_load_if_installed("brms")
model <- insight::download_model("brms_1")
x <- posterior::as_draws(model)
mp <- describe_posterior(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_equal(mp$pd, c(1, 0.9995, 0.9995, 1, 1), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
expect_identical(
colnames(mp),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI",
"ROPE_low", "ROPE_high", "ROPE_Percentage"
)
)
})
test_that("mp-posterior-draws_list", {
skip_if_offline()
skip_if_not_or_load_if_installed("posterior")
skip_if_not_or_load_if_installed("brms")
model <- insight::download_model("brms_1")
x <- posterior::as_draws_list(model)
mp <- describe_posterior(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_equal(mp$pd, c(1, 0.9995, 0.9995, 1, 1), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
expect_identical(
colnames(mp),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI",
"ROPE_low", "ROPE_high", "ROPE_Percentage"
)
)
})
test_that("mp-posterior-draws_df", {
skip_if_offline()
skip_if_not_or_load_if_installed("posterior")
skip_if_not_or_load_if_installed("brms")
model <- insight::download_model("brms_1")
x <- posterior::as_draws_df(model)
mp <- describe_posterior(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_equal(mp$pd, c(1, 0.9995, 0.9995, 1, 1), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
expect_identical(
colnames(mp),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI",
"ROPE_low", "ROPE_high", "ROPE_Percentage"
)
)
})
test_that("mp-posterior-draws_matrix", {
skip_if_offline()
skip_if_not_or_load_if_installed("posterior")
skip_if_not_or_load_if_installed("brms")
model <- insight::download_model("brms_1")
x <- posterior::as_draws_matrix(model)
mp <- describe_posterior(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_equal(mp$pd, c(1, 0.9995, 0.9995, 1, 1), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
expect_identical(
colnames(mp),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI",
"ROPE_low", "ROPE_high", "ROPE_Percentage"
)
)
})
test_that("mp-posterior-draws_array", {
skip_if_offline()
skip_if_not_or_load_if_installed("posterior")
skip_if_not_or_load_if_installed("brms")
model <- insight::download_model("brms_1")
x <- posterior::as_draws_array(model)
mp <- describe_posterior(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_equal(mp$pd, c(1, 0.9995, 0.9995, 1, 1), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
expect_identical(
colnames(mp),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI",
"ROPE_low", "ROPE_high", "ROPE_Percentage"
)
)
})
test_that("mp-posterior-draws_rvar", {
skip_if_offline()
skip_if_not_or_load_if_installed("posterior")
skip_if_not_or_load_if_installed("brms")
model <- insight::download_model("brms_1")
# Create random vectors by adding an additional dimension:
n <- 4 # length of output vector
set.seed(123)
x <- rvar(array(rnorm(4000 * n, mean = rep(1:n, each = 4000), sd = 1), dim = c(4000, n)))
mp <- describe_posterior(x)
expect_equal(mp$Median, c(0.99503, 1.99242, 2.9899, 3.99362), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("x[1]", "x[2]", "x[3]", "x[4]"))
expect_identical(
colnames(mp),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI",
"ROPE_low", "ROPE_high", "ROPE_Percentage"
)
)
})
bayestestR/tests/testthat/test-bayesfactor_models.R 0000644 0001762 0000144 00000015025 14560763455 022370 0 ustar ligges users # bayesfactor_models BIC --------------------------------------------------
test_that("bayesfactor_models BIC", {
skip_if_not_or_load_if_installed("lme4")
set.seed(444)
void <- suppressMessages(capture.output({
mo1 <- lme4::lmer(Sepal.Length ~ (1 | Species), data = iris)
mo2 <- lme4::lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris)
mo3 <- lme4::lmer(Sepal.Length ~ Petal.Length + (Petal.Length | Species), data = iris)
mo4 <- lme4::lmer(Sepal.Length ~ Petal.Length + Petal.Width + (Petal.Length | Species), data = iris)
mo5 <- lme4::lmer(Sepal.Length ~ Petal.Length * Petal.Width + (Petal.Length | Species), data = iris)
mo4_e <- lme4::lmer(Sepal.Length ~ Petal.Length + Petal.Width + (Petal.Length | Species), data = iris[-1, ])
}))
# both uses of denominator
BFM1 <<- bayesfactor_models(mo2, mo3, mo4, mo1, denominator = 4)
BFM2 <- bayesfactor_models(mo2, mo3, mo4, denominator = mo1)
BFM3 <- bayesfactor_models(mo2, mo3, mo4, mo1, denominator = mo1)
BFM4 <<- bayesfactor_models(mo2, mo3, mo4, mo5, mo1, denominator = mo1)
expect_equal(BFM1, BFM2)
expect_equal(BFM1, BFM3)
expect_equal(BFM1, bayesfactor_models(list(mo2 = mo2, mo3 = mo3, mo4 = mo4, mo1 = mo1), denominator = 4))
# only on same data!
expect_warning(bayesfactor_models(mo1, mo2, mo4_e))
# update models
expect_equal(update(BFM2, subset = c(1, 2))$log_BF, c(1, 57.3, 54.52), tolerance = 0.1)
# update reference
expect_equal(update(BFM2, reference = 1)$log_BF,
c(0, -2.8, -6.2, -57.4),
tolerance = 0.1
)
})
test_that("bayesfactor_models BIC, transformed responses", {
skip_if_not_or_load_if_installed("lme4")
m1 <- lm(mpg ~ 1, mtcars)
m2 <- lm(sqrt(mpg) ~ 1, mtcars)
BF1 <- bayesfactor_models(m1, m2, check_response = TRUE)
expect_equal(BF1$log_BF[2], 2.4404 / 2, tolerance = 0.01)
BF2 <- bayesfactor_models(m1, m2, check_response = FALSE)
expect_false(isTRUE(all.equal(BF1, BF2)))
})
test_that("bayesfactor_models BIC (unsupported / diff nobs)", {
skip_if_not_or_load_if_installed("lme4")
skip_on_cran()
set.seed(444)
fit1 <- lm(Sepal.Length ~ Sepal.Width + Petal.Length, iris)
fit2a <- lm(Sepal.Length ~ Sepal.Width, iris[-1, ]) # different number of objects
fit2b <- lm(Sepal.Length ~ Sepal.Width, iris) # not supported
class(fit2b) <- "NOTLM"
logLik.NOTLM <<- function(...) {
stats:::logLik.lm(...)
}
# Should warm
expect_warning(bayesfactor_models(fit1, fit2a))
# Should fail
suppressWarnings(expect_message(bayesfactor_models(fit1, fit2b), "Unable"))
})
# bayesfactor_models STAN ---------------------------------------------
test_that("bayesfactor_models STAN", {
skip_if_not_or_load_if_installed("lme4")
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("bridgesampling")
skip_if_not_or_load_if_installed("brms")
skip_on_cran()
set.seed(333)
stan_bf_0 <- rstanarm::stan_glm(
Sepal.Length ~ 1,
data = iris,
refresh = 0,
iter = 500,
diagnostic_file = file.path(tempdir(), "df0.csv")
)
stan_bf_1 <- suppressWarnings(rstanarm::stan_glm(
Sepal.Length ~ Species,
data = iris,
refresh = 0,
iter = 500,
diagnostic_file = file.path(tempdir(), "df1.csv")
))
set.seed(333) # compare against bridgesampling
bridge_BF <- bridgesampling::bayes_factor(
bridgesampling::bridge_sampler(stan_bf_1, silent = TRUE),
bridgesampling::bridge_sampler(stan_bf_0, silent = TRUE)
)
set.seed(333)
suppressMessages({
expect_warning(
stan_models <- bayesfactor_models(stan_bf_0, stan_bf_1)
)
})
expect_s3_class(stan_models, "bayesfactor_models")
expect_equal(length(stan_models$log_BF), 2)
expect_equal(stan_models$log_BF[2], log(bridge_BF$bf), tolerance = 0.1)
})
test_that("bayesfactor_models BRMS", {
# Checks for brms models
skip_on_cran()
skip_on_ci()
skip_if_not_or_load_if_installed("bridgesampling")
skip_if_not_or_load_if_installed("brms")
set.seed(333)
stan_brms_model_0 <- suppressWarnings(brms::brm(
Sepal.Length ~ 1,
data = iris,
iter = 500,
refresh = 0,
save_pars = brms::save_pars(all = TRUE),
silent = 2
))
stan_brms_model_1 <- suppressWarnings(brms::brm(
Sepal.Length ~ Petal.Length,
data = iris,
iter = 500,
refresh = 0,
save_pars = brms::save_pars(all = TRUE),
silent = 2
))
set.seed(444)
suppressWarnings(suppressMessages(
expect_message(
bfm <- bayesfactor_models(stan_brms_model_0, stan_brms_model_1),
regexp = "marginal"
)
))
set.seed(444)
stan_brms_model_0wc <- brms::add_criterion(
stan_brms_model_0,
criterion = "marglik",
repetitions = 5,
silent = 2
)
stan_brms_model_1wc <- brms::add_criterion(
stan_brms_model_1,
criterion = "marglik",
repetitions = 5,
silent = 2
)
suppressWarnings(expect_message(bfmwc <- bayesfactor_models(stan_brms_model_0wc, stan_brms_model_1wc), regexp = NA))
expect_equal(bfmwc$log_BF, bfm$log_BF, tolerance = 0.01)
})
# bayesfactor_inclusion ---------------------------------------------------
test_that("bayesfactor_inclusion | BayesFactor", {
skip_if_not_or_load_if_installed("lme4")
skip_if_not_or_load_if_installed("BayesFactor")
set.seed(444)
# BayesFactor
ToothGrowth$dose <- as.factor(ToothGrowth$dose)
BF_ToothGrowth <- BayesFactor::anovaBF(len ~ dose * supp, ToothGrowth)
expect_equal(
bayesfactor_inclusion(BF_ToothGrowth),
bayesfactor_inclusion(bayesfactor_models(BF_ToothGrowth))
)
})
test_that("bayesfactor_inclusion | LMM", {
skip_if_not_or_load_if_installed("lme4")
skip_if_not_or_load_if_installed("BayesFactor")
# with random effects in all models:
expect_true(is.nan(bayesfactor_inclusion(BFM1)["1:Species", "log_BF"]))
bfinc_all <- bayesfactor_inclusion(BFM4, match_models = FALSE)
expect_equal(bfinc_all$p_prior, c(1, 0.8, 0.6, 0.4, 0.2), tolerance = 0.1)
expect_equal(bfinc_all$p_posterior, c(1, 1, 0.12, 0.01, 0), tolerance = 0.1)
expect_equal(bfinc_all$log_BF, c(NaN, 57.651, -2.352, -4.064, -4.788), tolerance = 0.1)
# plus match_models
bfinc_matched <- bayesfactor_inclusion(BFM4, match_models = TRUE)
expect_equal(bfinc_matched$p_prior, c(1, 0.2, 0.6, 0.2, 0.2), tolerance = 0.1)
expect_equal(bfinc_matched$p_posterior, c(1, 0.875, 0.125, 0.009, 0.002), tolerance = 0.1)
expect_equal(bfinc_matched$log_BF, c(NaN, 58.904, -3.045, -3.573, -1.493), tolerance = 0.1)
})
bayestestR/tests/testthat/test-different_models.R 0000644 0001762 0000144 00000006537 14560763455 022044 0 ustar ligges users test_that("insight::get_predicted", {
skip_on_os("mac")
skip_if_not_or_load_if_installed("rstanarm")
x <- suppressWarnings(
insight::get_predicted(
stan_glm(hp ~ mpg, data = mtcars, iter = 500, refresh = 0)
)
)
rez <- point_estimate(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 4L))
rez <- point_estimate(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 3L))
rez <- hdi(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 4L))
rez <- hdi(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 3L))
rez <- eti(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 4L))
rez <- eti(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 3L))
rez <- ci(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 4L))
rez <- ci(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 3L))
rez <- map_estimate(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 2L))
rez <- map_estimate(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 2L))
rez <- p_direction(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 2L))
rez <- p_direction(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 2L))
rez <- p_map(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 2L))
rez <- p_map(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 2L))
rez <- p_significance(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 2L))
rez <- p_significance(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 2L))
rez <- rope(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 5L))
rez <- rope(x, use_iterations = FALSE)
expect_identical(c(nrow(rez), ncol(rez)), c(1L, 4L))
rez <- describe_posterior(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(32L, 5L))
rez <- estimate_density(x, use_iterations = TRUE)
expect_identical(c(nrow(rez), ncol(rez)), c(1024L, 2L))
})
test_that("bayesQR", {
skip_on_os("mac")
skip_if_not_or_load_if_installed("bayesQR")
invisible(capture.output({
x <- bayesQR(Sepal.Length ~ Petal.Width,
data = iris, quantile = 0.1,
alasso = TRUE, ndraw = 500
)
}))
rez <- p_direction(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 2L))
rez <- p_map(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 2L))
rez <- p_significance(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 2L))
rez <- rope(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 5L))
rez <- hdi(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 4L))
rez <- eti(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 4L))
rez <- map_estimate(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 2L))
rez <- point_estimate(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 4L))
rez <- describe_posterior(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2L, 10L))
rez <- estimate_density(x)
expect_identical(c(nrow(rez), ncol(rez)), c(2048L, 3L))
})
bayestestR/tests/testthat/helper.R 0000644 0001762 0000144 00000000504 14410351152 016776 0 ustar ligges users skip_if_not_or_load_if_installed <- function(package, minimum_version = NULL) {
testthat::skip_if_not_installed(package, minimum_version = minimum_version)
suppressMessages(suppressWarnings(suppressPackageStartupMessages(
require(package, warn.conflicts = FALSE, character.only = TRUE, quietly = TRUE)
)))
}
bayestestR/tests/testthat/test-bayesfactor_restricted.R 0000644 0001762 0000144 00000003121 14357655465 023254 0 ustar ligges users # bayesfactor_restricted data.frame ---------------------------------------
test_that("bayesfactor_restricted df", {
prior <- data.frame(
X = distribution_normal(100),
X1 = c(distribution_normal(50), distribution_normal(50)),
X3 = c(distribution_normal(80), distribution_normal(20))
)
posterior <- data.frame(
X = distribution_normal(100, .4, .2),
X1 = distribution_normal(100, -.2, .2),
X3 = distribution_normal(100, .2)
)
hyps <- c(
"X > X1 & X1 > X3",
"X > X1"
)
bfr <- bayesfactor_restricted(posterior, hypothesis = hyps, prior = prior)
expect_equal(bfr$p_prior, c(0.2, 0.5), tolerance = 0.1)
expect_equal(bfr$p_posterior, c(0.31, 1), tolerance = 0.1)
expect_equal(bfr$log_BF, c(0.43, 0.69), tolerance = 0.1)
expect_equal(exp(bfr$log_BF), bfr$p_posterior / bfr$p_prior, tolerance = 0.1)
expect_error(bayesfactor_restricted(posterior, prior, hypothesis = "Y < 0"))
})
# bayesfactor_restricted RSTANARM -----------------------------------------
test_that("bayesfactor_restricted RSTANARM", {
skip_on_cran()
skip_if_not_installed("rstanarm")
suppressWarnings(
fit_stan <- rstanarm::stan_glm(mpg ~ wt + cyl + am, data = mtcars, refresh = 0, iter = 200)
)
hyps <- c(
"am > 0 & cyl < 0",
"cyl < 0",
"wt - cyl > 0"
)
set.seed(444)
fit_p <- suppressMessages(unupdate(fit_stan))
bfr1 <- bayesfactor_restricted(fit_stan, prior = fit_p, hypothesis = hyps)
set.seed(444)
bfr2 <- bayesfactor_restricted(fit_stan, hypothesis = hyps)
expect_equal(bfr1, bfr2)
})
bayestestR/tests/testthat/test-pd_to_p.R 0000644 0001762 0000144 00000000374 14461433351 020135 0 ustar ligges users test_that("pd_to_p", {
pds <- c(0.7, 0.95, 0.99, 0.5)
expect_equal(pd_to_p(pds), c(0.6, 0.1, 0.02, 1))
expect_equal(pd_to_p(pds, direction = 1), c(0.3, 0.05, 0.01, 0.5))
expect_warning(p <- pd_to_p(0.3), "0.5")
expect_equal(p, 1)
})
bayestestR/tests/testthat/test-distributions.R 0000644 0001762 0000144 00000003126 14357655465 021431 0 ustar ligges users test_that("distributions", {
tolerance <- 0.01
expect_equal(mean(distribution_normal(10)), 0, tolerance = tolerance)
expect_equal(length(distribution_normal(10, random = TRUE)), 10, tolerance = tolerance)
expect_equal(mean(distribution_beta(10, 1, 1)), 0.5, tolerance = tolerance)
expect_equal(length(distribution_normal(10, 1, 1, random = TRUE)), 10, tolerance = tolerance)
expect_equal(mean(distribution_binomial(10, 0, 0.5)), 0, tolerance = tolerance)
expect_equal(length(distribution_binomial(10, 0, 0.5, random = TRUE)), 10, tolerance = tolerance)
expect_equal(mean(distribution_cauchy(10)), 0, tolerance = tolerance)
expect_equal(length(distribution_cauchy(10, random = TRUE)), 10, tolerance = tolerance)
expect_equal(mean(distribution_chisquared(10, 1)), 0.893, tolerance = tolerance)
expect_equal(length(distribution_chisquared(10, 1, random = TRUE)), 10, tolerance = tolerance)
expect_equal(mean(distribution_gamma(10, 1)), 0.9404, tolerance = tolerance)
expect_equal(length(distribution_gamma(10, 1, random = TRUE)), 10, tolerance = tolerance)
expect_equal(mean(distribution_poisson(10)), 1, tolerance = tolerance)
expect_equal(length(distribution_poisson(10, random = TRUE)), 10, tolerance = tolerance)
expect_equal(mean(distribution_student(10, 1)), 0, tolerance = tolerance)
expect_equal(length(distribution_student(10, 1, random = TRUE)), 10, tolerance = tolerance)
expect_equal(mean(distribution_uniform(10)), 0.5, tolerance = tolerance)
expect_equal(length(distribution_uniform(10, random = TRUE)), 10, tolerance = tolerance)
})
bayestestR/tests/testthat/test-rope_range.R 0000644 0001762 0000144 00000003134 14505757365 020644 0 ustar ligges users test_that("rope_range cor", {
x <- cor.test(ToothGrowth$len, ToothGrowth$dose)
expect_equal(rope_range(x), c(-0.05, 0.05), tolerance = 1e-3)
})
test_that("rope_range gaussian", {
data(mtcars)
mod <- lm(mpg ~ gear + hp, data = mtcars)
expect_equal(rope_range(mod), c(-0.1 * sd(mtcars$mpg), 0.1 * sd(mtcars$mpg)), tolerance = 1e-3)
})
test_that("rope_range log gaussian", {
data(iris)
mod <- lm(log(Sepal.Length) ~ Species, data = iris)
expect_equal(rope_range(mod), c(-0.01, 0.01), tolerance = 1e-3)
})
test_that("rope_range log gaussian 2", {
data(mtcars)
mod <- glm(mpg ~ gear + hp, data = mtcars, family = gaussian("log"))
expect_equal(rope_range(mod), c(-0.01, 0.01), tolerance = 1e-3)
})
test_that("rope_range logistic", {
data(mtcars)
mod <- glm(am ~ gear + hp, data = mtcars, family = binomial())
expect_equal(rope_range(mod), c(-1 * 0.1 * pi / sqrt(3), 0.1 * pi / sqrt(3)), tolerance = 1e-3)
})
test_that("rope_range", {
skip_if_not_or_load_if_installed("brms")
model <- suppressWarnings(brms::brm(mpg ~ wt + gear, data = mtcars, iter = 300))
expect_equal(
rope_range(model),
c(-0.6026948, 0.6026948),
tolerance = 0.01
)
})
test_that("rope_range (multivariate)", {
skip_if_not_or_load_if_installed("brms")
model <- suppressWarnings(
brms::brm(brms::bf(mvbind(mpg, disp) ~ wt + gear) + brms::set_rescor(TRUE), data = mtcars, iter = 300)
)
expect_equal(
rope_range(model),
list(
mpg = c(-0.602694, 0.602694),
disp = c(-12.393869, 12.393869)
),
tolerance = 0.01
)
})
bayestestR/tests/testthat/test-effective_sample.R 0000644 0001762 0000144 00000001647 14410351152 022006 0 ustar ligges users test_that("effective_sample", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("rstan")
brms_1 <- insight::download_model("brms_1")
res <- effective_sample(brms_1)
expect_equal(
res,
data.frame(
Parameter = c("b_Intercept", "b_wt", "b_cyl"),
ESS = c(5242, 2071, 1951),
stringsAsFactors = F
)
)
brms_null_1 <- insight::download_model("brms_null_1")
res <- effective_sample(brms_null_1)
expect_equal(
res,
data.frame(
Parameter = c("b_Intercept"),
ESS = c(2888),
stringsAsFactors = F
)
)
brms_null_2 <- insight::download_model("brms_null_2")
res <- effective_sample(brms_null_2)
expect_equal(
res,
data.frame(
Parameter = c("b_Intercept"),
ESS = c(1059),
stringsAsFactors = F
)
)
})
bayestestR/tests/testthat/test-density_at.R 0000644 0001762 0000144 00000000314 14276606713 020656 0 ustar ligges users test_that("density_at", {
expect_equal(density_at(distribution_normal(1000), 0), 0.389, tolerance = 0.1)
expect_equal(density_at(distribution_normal(1000), c(0, 1))[1], 0.389, tolerance = 0.1)
})
bayestestR/tests/testthat/test-estimate_density.R 0000644 0001762 0000144 00000002706 14650172354 022067 0 ustar ligges users test_that("estimate_density", {
skip_if_not_or_load_if_installed("logspline")
skip_if_not_or_load_if_installed("KernSmooth")
skip_if_not_or_load_if_installed("mclust")
set.seed(333)
x <- distribution_normal(500, 1)
# Methods
density_kernel <- estimate_density(x, method = "kernel")
density_logspline <- estimate_density(x, method = "logspline")
density_KernSmooth <- estimate_density(x, method = "KernSmooth")
density_mixture <- estimate_density(x, method = "mixture")
expect_equal(mean(density_kernel$y - density_logspline$y), 0, tolerance = 0.1)
expect_equal(mean(density_kernel$y - density_KernSmooth$y), 0, tolerance = 0.1)
expect_equal(mean(density_kernel$y - density_mixture$y), 0, tolerance = 0.1)
x <- iris
x$Fac <- rep_len(c("A", "B"), 150)
rez <- estimate_density(x, select = "Sepal.Length")
expect_identical(dim(rez), c(1024L, 3L))
rez <- estimate_density(x, select = c("Sepal.Length", "Petal.Length"))
expect_identical(dim(rez), c(2048L, 3L))
rez <- estimate_density(x, select = "Sepal.Length", by = "Species")
expect_identical(dim(rez), as.integer(c(1024 * 3, 4)))
rez <- estimate_density(x, select = c("Sepal.Length", "Petal.Length"), by = "Species")
expect_identical(dim(rez), as.integer(c(2048 * 3, 4)))
rez <- estimate_density(x, select = "Sepal.Length", by = c("Species", "Fac"), method = "KernSmooth")
expect_identical(dim(rez), as.integer(c(1024 * 3 * 2, 5)))
})
bayestestR/tests/testthat/test-as.data.frame.density.R 0000644 0001762 0000144 00000000176 14276606713 022603 0 ustar ligges users test_that("as.data.frame.density", {
expect_s3_class(as.data.frame(density(distribution_normal(1000))), "data.frame")
})
bayestestR/tests/testthat/test-brms.R 0000644 0001762 0000144 00000007147 14505754740 017470 0 ustar ligges users test_that("brms", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("brms_mixed_1")
expect_s3_class(hdi(model), "data.frame")
expect_s3_class(ci(model), "data.frame")
expect_s3_class(rope(model, verbose = FALSE), "data.frame")
expect_true("equivalence_test" %in% class(equivalence_test(model)))
expect_s3_class(map_estimate(model), "data.frame")
expect_s3_class(p_map(model), "data.frame")
expect_s3_class(p_direction(model), "data.frame")
expect_identical(colnames(hdi(model)), c("Parameter", "CI", "CI_low", "CI_high", "Effects", "Component"))
expect_identical(colnames(hdi(model, effects = "all")), c("Parameter", "CI", "CI_low", "CI_high", "Effects", "Component"))
expect_equal(nrow(equivalence_test(model)), 2L)
out <- describe_posterior(model, effects = "all", component = "all", centrality = "mean")
suppressWarnings({
s <- summary(model)
})
expect_identical(colnames(out), c(
"Parameter", "Effects", "Component", "Mean", "CI", "CI_low", "CI_high",
"pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage",
"Rhat", "ESS"
))
expect_equal(as.vector(s$fixed[, 1, drop = TRUE]), out$Mean[1:2], tolerance = 1e-3)
expect_equal(as.vector(s$fixed[, 5, drop = TRUE]), out$Rhat[1:2], tolerance = 1e-1)
expect_equal(as.vector(s$random$cyl[, 1, drop = TRUE]), out$Mean[12], tolerance = 1e-3)
expect_equal(as.vector(s$random$gear[, 1, drop = TRUE]), out$Mean[13:15], tolerance = 1e-3)
})
test_that("brms", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("brms_1")
out <- describe_posterior(model, effects = "all", component = "all", centrality = "mean")
s <- summary(model)
expect_identical(colnames(out), c(
"Parameter", "Component", "Mean", "CI", "CI_low", "CI_high", "pd", "ROPE_CI",
"ROPE_low", "ROPE_high", "ROPE_Percentage", "Rhat", "ESS"
))
expect_equal(as.vector(s$fixed[, 1, drop = TRUE]), out$Mean[1:3], tolerance = 1e-3)
expect_equal(as.vector(s$fixed[, 5, drop = TRUE]), out$Rhat[1:3], tolerance = 1e-1)
})
test_that("brms", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("brms_mv_2")
out <- describe_posterior(model, effects = "all", component = "all", centrality = "mean", test = NULL)
s <- suppressWarnings(summary(model))
expect_identical(colnames(out), c(
"Parameter", "Effects", "Component", "Mean", "CI", "CI_low", "CI_high",
"Rhat", "ESS"
))
known <- s$fixed
unknown <- out[out$Effects == "fixed" & out$Component == "conditional", ]
idx <- match(row.names(known), gsub("b_", "", unknown$Parameter, fixed = TRUE))
unknown <- unknown[idx, ]
expect_equal(unknown$Mean, known$Estimate, ignore_attr = TRUE)
expect_equal(unknown$Rhat, known$Rhat, tolerance = 1e-2, ignore_attr = TRUE)
})
test_that("brms", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("brms_2")
out <- describe_posterior(model, effects = "all", component = "all", centrality = "mean", test = NULL)
s <- summary(model)
expect_equal(as.vector(s$fixed[, 1, drop = TRUE]), out$Mean, tolerance = 1e-3)
expect_equal(as.vector(s$fixed[, 5, drop = TRUE]), out$Rhat, tolerance = 1e-1)
})
bayestestR/tests/testthat/test-p_significance.R 0000644 0001762 0000144 00000002205 14505757365 021462 0 ustar ligges users test_that("p_significance", {
# numeric
set.seed(333)
x <- distribution_normal(10000, 1, 1)
ps <- p_significance(x)
expect_equal(as.numeric(ps), 0.816, tolerance = 0.1)
expect_s3_class(ps, "p_significance")
expect_s3_class(ps, "data.frame")
expect_identical(dim(ps), c(1L, 2L))
expect_identical(
capture.output(print(ps)),
c(
"Practical Significance (threshold: 0.10)",
"",
"Parameter | ps",
"----------------",
"Posterior | 0.82"
)
)
x <- data.frame(replicate(4, rnorm(100)))
pd <- p_significance(x)
expect_identical(dim(pd), c(4L, 2L))
})
test_that("stanreg", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
m <- insight::download_model("stanreg_merMod_5")
expect_equal(
p_significance(m, effects = "all")$ps[1],
0.99,
tolerance = 1e-2
)
})
test_that("brms", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
m2 <- insight::download_model("brms_1")
expect_equal(
p_significance(m2, effects = "all")$ps,
c(1.0000, 0.9985, 0.9785),
tolerance = 0.01
)
})
bayestestR/tests/testthat/test-check_prior.R 0000644 0001762 0000144 00000010302 14650172354 020774 0 ustar ligges users skip_on_os(os = "mac")
test_that("check_prior - stanreg", {
skip_on_cran()
skip_on_os(os = c("windows", "mac"))
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("BH")
skip_if_not_or_load_if_installed("RcppEigen")
skip_if_not_or_load_if_installed("brms")
set.seed(333)
model1 <- insight::download_model("stanreg_lm_1")
expect_identical(
check_prior(model1)$Prior_Quality,
c("informative", "uninformative")
)
expect_identical(
check_prior(model1, method = "lakeland")$Prior_Quality,
c("informative", "informative")
)
})
test_that("check_prior - brms (linux)", {
skip("TODO: check hard-coded values")
skip_on_cran()
skip_on_os(os = c("windows", "mac", "solaris"))
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("BH")
skip_if_not_or_load_if_installed("RcppEigen")
skip_if_not_or_load_if_installed("brms")
# all `brms` examples in circus have uniform prior distribution, so
# need to use a custom example here
set.seed(333)
suppressMessages({
model2 <- brm(rating ~ period + carry + cs(treat),
data = inhaler, family = sratio("logit"),
prior = set_prior("normal(0,5)"),
chains = 2, silent = TRUE, refresh = 0
)
})
expect_warning(expect_identical(
check_prior(model2)$Prior_Quality,
c(
"uninformative", "informative", "informative", "uninformative",
"uninformative", "not determinable", "not determinable", "not determinable"
)
))
expect_warning(expect_identical(
check_prior(model2, method = "lakeland")$Prior_Quality,
c(
"informative", "informative", "informative", "informative",
"informative", "not determinable", "not determinable", "not determinable"
)
))
})
test_that("check_prior - brms (linux)", {
skip_on_cran()
skip_on_os(os = c("windows", "mac", "solaris"))
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("BH")
skip_if_not_or_load_if_installed("RcppEigen")
skip_if_not_or_load_if_installed("brms")
# all `brms` examples in circus have uniform prior distribution, so
# need to use a custom example here
set.seed(333)
model2 <- brm(rating ~ period + carry + cs(treat),
data = inhaler, family = sratio("logit"),
prior = set_prior("normal(0,5)"),
chains = 2, silent = TRUE, refresh = 0
)
# TODO: check hard-coded values
expect_warning(expect_identical(
check_prior(model2)$Prior_Quality,
c(
"uninformative", "informative", "informative", "uninformative",
"uninformative", "not determinable", "not determinable", "not determinable"
)
))
expect_warning(expect_identical(
check_prior(model2, method = "lakeland")$Prior_Quality,
c(
"informative", "misinformative", "informative", "informative",
"informative", "not determinable", "not determinable", "not determinable"
)
))
})
test_that("check_prior - brms (not linux or windows)", {
skip_on_cran()
skip_on_os(os = c("linux", "windows", "mac"))
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("BH")
skip_if_not_or_load_if_installed("RcppEigen")
skip_if_not_or_load_if_installed("brms")
# all `brms` examples in circus have uniform prior distribution, so
# need to use a custom example here
set.seed(333)
suppressMessages({
model2 <- brm(rating ~ period + carry + cs(treat),
data = inhaler, family = sratio("logit"),
prior = set_prior("normal(0,5)"),
chains = 2, silent = TRUE, refresh = 0
)
})
expect_warning(expect_identical(
check_prior(model2)$Prior_Quality,
c(
"uninformative", "uninformative", "informative", "uninformative",
"uninformative", "not determinable", "not determinable", "not determinable"
)
))
expect_warning(expect_identical(
check_prior(model2, method = "lakeland")$Prior_Quality,
c(
"informative", "informative", "informative", "informative",
"informative", "not determinable", "not determinable", "not determinable"
)
))
})
bayestestR/tests/testthat/test-rope.R 0000644 0001762 0000144 00000007731 14561435021 017457 0 ustar ligges users test_that("rope", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
expect_equal(as.numeric(rope(distribution_normal(1000, 0, 1), verbose = FALSE)), 0.084, tolerance = 0.01)
expect_identical(equivalence_test(distribution_normal(1000, 0, 1))$ROPE_Equivalence, "Undecided")
expect_length(capture.output(print(equivalence_test(distribution_normal(1000)))), 9)
expect_length(capture.output(print(equivalence_test(distribution_normal(1000), ci = c(0.8, 0.9)))), 14)
expect_equal(as.numeric(rope(distribution_normal(1000, 2, 0.01), verbose = FALSE)), 0, tolerance = 0.01)
expect_identical(equivalence_test(distribution_normal(1000, 2, 0.01))$ROPE_Equivalence, "Rejected")
expect_equal(as.numeric(rope(distribution_normal(1000, 0, 0.001), verbose = FALSE)), 1, tolerance = 0.01)
expect_identical(equivalence_test(distribution_normal(1000, 0, 0.001))$ROPE_Equivalence, "Accepted")
expect_identical(equivalence_test(distribution_normal(1000, 0, 0.001), ci = 1)$ROPE_Equivalence, "Accepted")
expect_equal(rope(rnorm(1000, mean = 0, sd = 3), ci = c(0.1, 0.5, 0.9), verbose = FALSE)$CI, c(0.1, 0.5, 0.9))
x <- equivalence_test(distribution_normal(1000, 1, 1), ci = c(0.50, 0.99))
expect_equal(x$ROPE_Percentage[2], 0.0484, tolerance = 0.01)
expect_identical(x$ROPE_Equivalence[2], "Undecided")
expect_error(rope(distribution_normal(1000, 0, 1), range = c(0.0, 0.1, 0.2)))
set.seed(333)
expect_s3_class(rope(distribution_normal(1000, 0, 1), verbose = FALSE), "rope")
expect_error(rope(distribution_normal(1000, 0, 1), range = c("A", 0.1)))
expect_equal(
as.numeric(rope(distribution_normal(1000, 0, 1),
range = c(-0.1, 0.1)
)), 0.084,
tolerance = 0.01
)
})
test_that("rope", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
m <- insight::download_model("stanreg_merMod_5")
p <- insight::get_parameters(m, effects = "all")
expect_equal(
# fix range to -.1/.1, to compare to data frame method
rope(m, range = c(-0.1, 0.1), effects = "all", verbose = FALSE)$ROPE_Percentage,
rope(p, verbose = FALSE)$ROPE_Percentage,
tolerance = 1e-3
)
})
test_that("rope", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
m <- insight::download_model("brms_zi_3")
p <- insight::get_parameters(m, effects = "all", component = "all")
expect_equal(
rope(m, effects = "all", component = "all", verbose = FALSE)$ROPE_Percentage,
rope(p, verbose = FALSE)$ROPE_Percentage,
tolerance = 1e-3
)
})
skip_if_not_or_load_if_installed("brms")
skip_on_os("windows")
set.seed(123)
model <- suppressWarnings(brms::brm(mpg ~ wt + gear, data = mtcars, iter = 500))
rope <- rope(model, verbose = FALSE)
test_that("rope (brms)", {
expect_equal(rope$ROPE_high, -rope$ROPE_low, tolerance = 0.01)
expect_equal(rope$ROPE_high[1], 0.6026948)
expect_equal(rope$ROPE_Percentage, c(0.00, 0.00, 0.50), tolerance = 0.1)
})
skip_on_os("mac")
model <- suppressWarnings(brm(bf(mvbind(mpg, disp) ~ wt + gear) + set_rescor(TRUE), data = mtcars, iter = 500, refresh = 0))
rope <- rope(model, verbose = FALSE)
test_that("rope (brms, multivariate)", {
expect_equal(rope$ROPE_high, -rope$ROPE_low, tolerance = 0.01)
expect_equal(rope$ROPE_high[1], 0.6026948, tolerance = 0.01)
expect_equal(rope$ROPE_high[4], 12.3938694, tolerance = 0.01)
expect_equal(
rope$ROPE_Percentage,
c(0, 0, 0.493457, 0.072897, 0, 0.508411),
tolerance = 0.1
)
})
skip_on_os("linux")
test_that("BayesFactor", {
skip_if_not_or_load_if_installed("BayesFactor")
mods <- regressionBF(mpg ~ am + cyl, mtcars, progress = FALSE)
rx <- suppressMessages(rope(mods, verbose = FALSE))
expect_equal(rx$ROPE_high, -rx$ROPE_low, tolerance = 0.01)
expect_equal(rx$ROPE_high[1], 0.6026948, tolerance = 0.01)
})
bayestestR/tests/testthat/_snaps/ 0000755 0001762 0000144 00000000000 14560756720 016700 5 ustar ligges users bayestestR/tests/testthat/_snaps/windows/ 0000755 0001762 0000144 00000000000 14560763455 020375 5 ustar ligges users bayestestR/tests/testthat/_snaps/windows/print.md 0000644 0001762 0000144 00000007501 14560763455 022056 0 ustar ligges users # print.describe_posterior
Code
describe_posterior(m, verbose = FALSE)
Output
Summary of Posterior Distribution
Parameter | Median | 95% CI | pd | ROPE | % in ROPE | Rhat | ESS
-------------------------------------------------------------------------------------------
(Intercept) | 0.96 | [-0.81, 2.51] | 90.00% | [-0.10, 0.10] | 2.54% | 1.011 | 110.00
child | -1.16 | [-1.36, -0.94] | 100% | [-0.10, 0.10] | 0% | 0.996 | 278.00
camper | 0.73 | [ 0.54, 0.91] | 100% | [-0.10, 0.10] | 0% | 0.996 | 271.00
---
Code
describe_posterior(m, effects = "all", component = "all", verbose = FALSE)
Output
Summary of Posterior Distribution
Parameter | Median | 95% CI | pd | ROPE | % in ROPE | Rhat | ESS
-------------------------------------------------------------------------------------------
(Intercept) | 0.96 | [-0.81, 2.51] | 90.00% | [-0.10, 0.10] | 2.54% | 1.011 | 110.00
child | -1.16 | [-1.36, -0.94] | 100% | [-0.10, 0.10] | 0% | 0.996 | 278.00
camper | 0.73 | [ 0.54, 0.91] | 100% | [-0.10, 0.10] | 0% | 0.996 | 271.00
# Fixed effects (zero-inflated)
Parameter | Median | 95% CI | pd | ROPE | % in ROPE | Rhat | ESS
-------------------------------------------------------------------------------------------
(Intercept) | -0.48 | [-2.03, 0.89] | 78.00% | [-0.10, 0.10] | 10.59% | 0.997 | 138.00
child | 1.85 | [ 1.19, 2.54] | 100% | [-0.10, 0.10] | 0% | 0.996 | 303.00
camper | -0.88 | [-1.61, -0.07] | 98.40% | [-0.10, 0.10] | 0.85% | 0.996 | 292.00
# Random effects (conditional) Intercept: persons
Parameter | Median | 95% CI | pd | ROPE | % in ROPE | Rhat | ESS
--------------------------------------------------------------------------------------------
persons.1 | -0.99 | [-2.68, 0.80] | 92.00% | [-0.10, 0.10] | 2.12% | 1.007 | 106.00
persons.2 | -4.65e-03 | [-1.63, 1.66] | 50.00% | [-0.10, 0.10] | 13.98% | 1.013 | 109.00
persons.3 | 0.69 | [-0.95, 2.34] | 79.60% | [-0.10, 0.10] | 5.08% | 1.010 | 114.00
persons.4 | 1.57 | [-0.05, 3.29] | 96.80% | [-0.10, 0.10] | 1.27% | 1.009 | 114.00
# Random effects (zero-inflated) Intercept: persons
Parameter | Median | 95% CI | pd | ROPE | % in ROPE | Rhat | ESS
-----------------------------------------------------------------------------------------
persons.1 | 1.10 | [-0.23, 2.72] | 94.80% | [-0.10, 0.10] | 3.39% | 0.997 | 166.00
persons.2 | 0.18 | [-0.94, 1.58] | 63.20% | [-0.10, 0.10] | 14.83% | 0.996 | 154.00
persons.3 | -0.30 | [-1.79, 1.02] | 64.00% | [-0.10, 0.10] | 12.29% | 0.997 | 154.00
persons.4 | -1.45 | [-2.90, -0.10] | 98.00% | [-0.10, 0.10] | 0% | 1.000 | 189.00
# Random effects (conditional) SD/Cor: persons
Parameter | Median | 95% CI | pd | ROPE | % in ROPE | Rhat | ESS
-----------------------------------------------------------------------------------------
(Intercept) | 1.42 | [ 0.71, 3.58] | 100% | [-0.10, 0.10] | 0% | 1.010 | 126.00
# Random effects (zero-inflated) SD/Cor: persons
Parameter | Median | 95% CI | pd | ROPE | % in ROPE | Rhat | ESS
-----------------------------------------------------------------------------------------
(Intercept) | 1.30 | [ 0.63, 3.41] | 100% | [-0.10, 0.10] | 0% | 0.996 | 129.00
bayestestR/tests/testthat/test-BFBayesFactor.R 0000644 0001762 0000144 00000006321 14561435021 021116 0 ustar ligges users skip_on_os("linux")
test_that("p_direction", {
skip_if_not_or_load_if_installed("BayesFactor")
set.seed(333)
x <- BayesFactor::correlationBF(y = iris$Sepal.Length, x = iris$Sepal.Width)
expect_equal(as.numeric(p_direction(x)), 0.9225, tolerance = 1)
})
test_that("p_direction: BF t.test one sample", {
skip_if_not_or_load_if_installed("BayesFactor")
data(sleep)
diffScores <- sleep$extra[1:10] - sleep$extra[11:20]
x <- BayesFactor::ttestBF(x = diffScores)
expect_equal(as.numeric(p_direction(x)), 0.99675, tolerance = 1)
})
test_that("p_direction: BF t.test two samples", {
skip_if_not_or_load_if_installed("BayesFactor")
data(chickwts)
chickwts <- chickwts[chickwts$feed %in% c("horsebean", "linseed"), ]
chickwts$feed <- factor(chickwts$feed)
x <- BayesFactor::ttestBF(formula = weight ~ feed, data = chickwts)
expect_equal(as.numeric(p_direction(x)), 1, tolerance = 1)
})
test_that("p_direction: BF t.test meta-analytic", {
skip_if_not_or_load_if_installed("BayesFactor")
t <- c(-0.15, 2.39, 2.42, 2.43)
N <- c(100, 150, 97, 99)
x <- BayesFactor::meta.ttestBF(t = t, n1 = N, rscale = 1)
expect_equal(as.numeric(p_direction(x)), 0.99975, tolerance = 1)
})
skip_if_not_or_load_if_installed("BayesFactor")
# ---------------------------
# "BF ANOVA"
data(ToothGrowth)
ToothGrowth$dose <- factor(ToothGrowth$dose)
levels(ToothGrowth$dose) <- c("Low", "Medium", "High")
x <- BayesFactor::anovaBF(len ~ supp * dose, data = ToothGrowth)
test_that("p_direction", {
expect_equal(as.numeric(p_direction(x)), c(1, 0.95675, 0.95675, 1, 1), tolerance = 0.1)
})
# BF ANOVA Random ---------------------------
data(puzzles)
x <- BayesFactor::anovaBF(RT ~ shape * color + ID, data = puzzles, whichRandom = "ID")
test_that("p_direction", {
expect_equal(as.numeric(p_direction(x)), c(
1, 0.98125, 0.98125, 0.995, 0.67725, 0.8285, 0.68425, 0.99975,
0.6725, 0.9995, 0.60275, 0.99525, 0.7615, 0.763, 1, 1, 1, 1
), tolerance = 0.1)
})
# ---------------------------
# "BF lm"
x <- BayesFactor::lmBF(len ~ supp + dose, data = ToothGrowth)
test_that("p_direction", {
expect_equal(as.numeric(p_direction(x)), c(1, 0.9995, 0.9995, 1, 0.903, 1, 1, 1, 1), tolerance = 0.1)
})
x2 <- BayesFactor::lmBF(len ~ supp + dose + supp:dose, data = ToothGrowth)
x <- x / x2
test_that("p_direction", {
expect_equal(as.numeric(p_direction(x)), c(1, 0.99925, 0.99925, 1, 0.89975, 1, 1, 1, 1), tolerance = 0.1)
})
test_that("rope_range", {
skip_if_not_or_load_if_installed("BayesFactor")
x <- BayesFactor::lmBF(len ~ supp + dose, data = ToothGrowth)
expect_equal(rope_range(x)[2], sd(ToothGrowth$len) / 10, tolerance = 1e-4)
x <- BayesFactor::ttestBF(
ToothGrowth$len[ToothGrowth$supp == "OJ"],
ToothGrowth$len[ToothGrowth$supp == "VC"]
)
expect_equal(rope_range(x)[2], sd(ToothGrowth$len) / 10, tolerance = 1e-4)
x <- BayesFactor::ttestBF(formula = len ~ supp, data = ToothGrowth)
expect_equal(rope_range(x)[2], sd(ToothGrowth$len) / 10, tolerance = 1e-4)
# else
x <- BayesFactor::correlationBF(ToothGrowth$len, as.numeric(ToothGrowth$dose))
expect_equal(rope_range(x, verbose = FALSE), c(-0.05, 0.05), tolerance = 1e-4)
})
bayestestR/tests/testthat/test-point_estimate.R 0000644 0001762 0000144 00000001576 14410351152 021532 0 ustar ligges users test_that("point_estimate: stanreg", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
m <- insight::download_model("stanreg_merMod_5")
p <- insight::get_parameters(m, effects = "all")
expect_equal(
point_estimate(m, effects = "all")$Median,
point_estimate(p)$Median,
tolerance = 1e-3
)
})
test_that("point_estimate: brms", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
m <- insight::download_model("brms_zi_3")
p <- insight::get_parameters(m, effects = "all", component = "all")
expect_equal(
point_estimate(m, effects = "all", component = "all")$Median,
point_estimate(p)$Median,
tolerance = 1e-3
)
})
bayestestR/tests/testthat/test-rstanarm.R 0000644 0001762 0000144 00000010677 14505754740 020356 0 ustar ligges users test_that("rstanarm", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("stanreg_lm_1")
expect_equal(rope_range(model, verbose = FALSE)[1], -0.602, tolerance = 0.1)
model <- insight::download_model("stanreg_meanfield_lm_1")
expect_equal(rope_range(model, verbose = FALSE)[1], -0.602, tolerance = 0.1)
model <- insight::download_model("stanreg_fullrank_lm_1")
expect_equal(rope_range(model, verbose = FALSE)[1], -0.602, tolerance = 0.1)
model <- insight::download_model("stanreg_lmerMod_1")
expect_equal(rope_range(model, verbose = FALSE)[1], -0.097, tolerance = 0.1)
model <- insight::download_model("stanreg_glm_1")
expect_equal(rope_range(model, verbose = FALSE)[1], -0.18, tolerance = 0.1)
model <- insight::download_model("stanreg_merMod_1")
expect_equal(rope_range(model, verbose = FALSE)[1], -0.18, tolerance = 0.1)
model <- insight::download_model("stanreg_gamm4_1")
expect_equal(rope_range(model, verbose = FALSE)[1], -0.043, tolerance = 0.1)
model <- insight::download_model("stanreg_gam_1")
invisible(capture.output(
expect_warning(params <- describe_posterior(model,
centrality = "all",
test = "all", dispersion = TRUE
))
))
expect_equal(c(nrow(params), ncol(params)), c(4, 22))
expect_s3_class(hdi(model), "data.frame")
expect_s3_class(ci(model), "data.frame")
expect_s3_class(rope(model, verbose = FALSE), "data.frame")
expect_true("equivalence_test" %in% class(equivalence_test(model)))
expect_s3_class(map_estimate(model), "data.frame")
expect_s3_class(p_map(model), "data.frame")
expect_s3_class(p_direction(model), "data.frame")
expect_error(equivalence_test(model, range = c(0.1, 0.3, 0.5)))
})
test_that("rstanarm", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("stanreg_glm_3")
out <- describe_posterior(model, effects = "all", component = "all", centrality = "mean")
s <- summary(model)
expect_identical(colnames(out), c(
"Parameter", "Mean", "CI", "CI_low", "CI_high", "pd", "ROPE_CI",
"ROPE_low", "ROPE_high", "ROPE_Percentage", "Rhat", "ESS"
))
expect_equal(as.vector(s[1:4, 1, drop = TRUE]), out$Mean, tolerance = 1e-3)
expect_equal(as.vector(s[1:4, 8, drop = TRUE]), out$Rhat, tolerance = 1e-1)
})
test_that("rstanarm", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("stanreg_merMod_3")
out <- describe_posterior(model, effects = "all", component = "all", centrality = "mean")
s <- summary(model)
expect_identical(colnames(out), c(
"Parameter", "Effects", "Mean", "CI", "CI_low", "CI_high",
"pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage",
"Rhat", "ESS"
))
expect_equal(as.vector(s[1:8, 1, drop = TRUE]), out$Mean, tolerance = 1e-3)
expect_equal(as.vector(s[1:8, 8, drop = TRUE]), out$Rhat, tolerance = 1e-1)
})
test_that("rstanarm", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("stanmvreg_1")
out <- describe_posterior(model, effects = "fixed", component = "all", centrality = "mean", test = NULL)
s <- summary(model)
expect_identical(colnames(out), c(
"Parameter", "Response", "Mean", "CI", "CI_low", "CI_high",
"Rhat", "ESS"
))
expect_equal(as.vector(s[c(1:2, 5:7), 1, drop = TRUE]), out$Mean, tolerance = 1e-3)
expect_equal(as.vector(s[c(1:2, 5:7), 10, drop = TRUE]), out$Rhat, tolerance = 1e-1)
})
test_that("rstanarm", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("httr")
set.seed(333)
model <- insight::download_model("stanmvreg_1")
out <- describe_posterior(
model,
effects = "fixed",
component = "all",
centrality = "mean",
test = NULL,
priors = TRUE
)
expect_identical(colnames(out), c(
"Parameter", "Response", "Mean", "CI", "CI_low", "CI_high",
"Rhat", "ESS", "Prior_Distribution", "Prior_Location",
"Prior_Scale"
))
expect_equal(nrow(out), 5)
})
bayestestR/tests/testthat/test-simulate_data.R 0000644 0001762 0000144 00000001454 14650172354 021330 0 ustar ligges users skip_if_not_installed("MASS")
test_that("simulate_correlation", {
set.seed(333)
data <- simulate_correlation(r = 0.5, n = 50)
expect_equal(as.numeric(cor.test(data$V1, data$V2)$estimate), 0.5, tolerance = 0.001)
data <- simulate_correlation(r = 0.5, n = 50, mean = c(0, 1), sd = c(0.7, 1.7))
expect_equal(as.numeric(cor.test(data$V1, data$V2)$estimate), 0.5, tolerance = 0.001)
expect_equal(c(mean(data$V1), sd(data$V1)), c(0, 0.7), tolerance = 0.001)
expect_equal(c(mean(data$V2), sd(data$V2)), c(1, 1.7), tolerance = 0.001)
cor_matrix <- matrix(
c(
1.0, 0.2, 0.4,
0.2, 1.0, 0.3,
0.4, 0.3, 1.0
),
nrow = 3
)
data <- simulate_correlation(r = cor_matrix)
expect_equal(matrix(cor(data), nrow = 3), cor_matrix, tolerance = 0.001)
})
bayestestR/tests/testthat/test-blavaan.R 0000644 0001762 0000144 00000005433 14650172354 020121 0 ustar ligges users test_that("blavaan, all", {
skip_on_cran()
skip_if_not_or_load_if_installed("blavaan")
skip_if_not_or_load_if_installed("lavaan")
skip_if_not_or_load_if_installed("cmdstanr")
skip_if_not_or_load_if_installed("rstan")
data("PoliticalDemocracy", package = "lavaan")
model <- "
# latent variable definitions
dem60 =~ y1 + a*y2
dem65 =~ y5 + a*y6
# regressions
dem65 ~ dem60
# residual correlations
y1 ~~ y5
"
model2 <- "
# latent variable definitions
dem60 =~ y1 + a*y2
dem65 =~ y5 + a*y6
# regressions
dem65 ~ 0*dem60
# residual correlations
y1 ~~ 0*y5
"
suppressWarnings(capture.output({
bfit <- blavaan::bsem(model,
data = PoliticalDemocracy,
n.chains = 1, burnin = 50, sample = 100
)
bfit2 <- blavaan::bsem(model2,
data = PoliticalDemocracy,
n.chains = 1, burnin = 50, sample = 100
)
}))
x <- point_estimate(bfit, centrality = "all", dispersion = TRUE)
expect_true(all(c("Median", "MAD", "Mean", "SD", "MAP", "Component") %in% colnames(x)))
expect_identical(nrow(x), 10L)
x <- eti(bfit)
expect_identical(nrow(x), 10L)
x <- hdi(bfit)
expect_identical(nrow(x), 10L)
x <- p_direction(bfit)
expect_identical(nrow(x), 10L)
x <- rope(bfit, range = c(-0.1, 0.1))
expect_identical(nrow(x), 10L)
x <- p_rope(bfit, range = c(-0.1, 0.1))
expect_identical(nrow(x), 10L)
x <- p_map(bfit)
expect_identical(nrow(x), 10L)
x <- p_significance(bfit, threshold = c(-0.1, 0.1))
expect_identical(nrow(x), 10L)
x <- equivalence_test(bfit, range = c(-0.1, 0.1))
expect_identical(nrow(x), 10L)
x <- estimate_density(bfit)
expect_length(unique(x$Parameter), 10)
## Bayes factors ----
# For these models, no BF available, see #627
expect_error(bayesfactor_models(bfit, bfit2), regex = "Could not calculate Bayes")
bfit_prior <- unupdate(bfit)
capture.output(x <- expect_warning(bayesfactor_parameters(bfit, prior = bfit_prior)))
expect_identical(nrow(x), 10L)
x <- expect_warning(si(bfit, prior = bfit_prior))
expect_identical(nrow(x), 10L)
## Prior/posterior checks ----
suppressWarnings(x <- check_prior(bfit))
expect_equal(nrow(x), 13)
x <- check_prior(bfit, simulate_priors = FALSE)
expect_identical(nrow(x), 10L)
x <- diagnostic_posterior(bfit)
expect_identical(nrow(x), 10L)
x <- simulate_prior(bfit)
expect_identical(ncol(x), 13L)
# YES this is 13! We have two parameters with the same prior.
x <- describe_prior(bfit)
expect_identical(nrow(x), 13L)
# YES this is 13! We have two parameters with the same prior.
x <- describe_posterior(bfit, test = "all", rope_range = c(-0.1, 0.1))
expect_identical(nrow(x), 10L)
})
bayestestR/tests/testthat/test-si.R 0000644 0001762 0000144 00000003560 14560763455 017137 0 ustar ligges users test_that("si.numeric", {
skip_if_not_installed("logspline")
set.seed(333)
prior <- distribution_normal(1000, mean = 0, sd = 1)
posterior <- distribution_normal(1000, mean = 0.5, sd = 0.3)
expect_warning(
{
res <- si(posterior, prior)
},
regexp = "40"
)
expect_equal(res$CI_low, 0.043, tolerance = 0.02)
expect_equal(res$CI_high, 1.053103, tolerance = 0.02)
expect_s3_class(res, "bayestestR_si")
res <- si(posterior, prior, BF = 3, verbose = FALSE)
expect_equal(res$CI_low, 0.35, tolerance = 0.02)
expect_equal(res$CI_high, 0.759, tolerance = 0.02)
res <- si(posterior, prior, BF = 100, verbose = FALSE)
expect_true(all(is.na(res$CI_low)))
expect_true(all(is.na(res$CI_high)))
res <- si(posterior, prior, BF = c(1 / 3, 1, 3), verbose = FALSE)
expect_equal(res$CI, c(1 / 3, 1, 3), tolerance = 0.02)
expect_equal(res$CI_low, c(-0.1277, 0.0426, 0.3549), tolerance = 0.02)
expect_equal(res$CI_high, c(1.213, 1.053, 0.759), tolerance = 0.02)
})
test_that("si.rstanarm", {
skip_on_cran()
skip_if_not_installed("rstanarm")
data(sleep)
contrasts(sleep$group) <- contr.equalprior_pairs # See vignette
stan_model <- suppressWarnings(rstanarm::stan_glmer(extra ~ group + (1 | ID), data = sleep, refresh = 0))
set.seed(333)
stan_model_p <- update(stan_model, prior_PD = TRUE)
res1 <- si(stan_model, stan_model_p, verbose = FALSE)
set.seed(333)
res2 <- si(stan_model, verbose = FALSE)
expect_s3_class(res1, "bayestestR_si")
expect_equal(res1, res2, ignore_attr = TRUE)
skip_if_not_installed("emmeans")
set.seed(123)
group_diff <- suppressWarnings(pairs(emmeans::emmeans(stan_model, ~group)))
res3 <- si(group_diff, prior = stan_model, verbose = FALSE)
expect_equal(res3$CI_low, -2.746, tolerance = 0.3)
expect_equal(res3$CI_high, -0.4, tolerance = 0.3)
})
bayestestR/tests/testthat/test-overlap.R 0000644 0001762 0000144 00000000452 14461433341 020155 0 ustar ligges users test_that("overlap", {
set.seed(333)
x <- distribution_normal(1000, 2, 0.5)
y <- distribution_normal(1000, 0, 1)
expect_equal(as.numeric(overlap(x, y)), 0.185, tolerance = 0.01)
out <- capture.output(print(overlap(x, y)))
expect_identical(out, c("# Overlap", "", "18.6%"))
})
bayestestR/tests/testthat/test-describe_posterior.R 0000644 0001762 0000144 00000043116 14650172354 022403 0 ustar ligges users test_that("describe_posterior", {
skip_if(getRversion() < "4.2")
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
skip_on_os("linux")
set.seed(333)
# numeric -------------------------------------------------
x <- distribution_normal(4000)
expect_silent(describe_posterior(
x,
centrality = "all",
dispersion = TRUE,
test = "all",
ci = 0.89,
verbose = FALSE
))
rez <- as.data.frame(suppressWarnings(describe_posterior(
x,
centrality = "all",
dispersion = TRUE,
test = "all",
ci = 0.89
)))
expect_identical(dim(rez), c(1L, 19L))
expect_identical(colnames(rez), c(
"Parameter", "Median", "MAD", "Mean", "SD", "MAP", "CI", "CI_low",
"CI_high", "p_MAP", "pd", "p_ROPE", "ps", "ROPE_CI", "ROPE_low",
"ROPE_high", "ROPE_Percentage", "ROPE_Equivalence", "log_BF"
))
expect_warning(expect_warning(expect_warning(describe_posterior(
x,
centrality = "all",
dispersion = TRUE,
test = "all",
ci = c(0.8, 0.9)
), regex = "ROPE range"), regex = "Prior not specified"), regex = "not be precise")
rez <- suppressWarnings(describe_posterior(
x,
centrality = "all",
dispersion = TRUE,
test = "all",
ci = c(0.8, 0.9)
))
expect_identical(dim(rez), c(2L, 19L))
rez <- describe_posterior(
x,
centrality = NULL,
dispersion = TRUE,
test = NULL,
ci_method = "quantile",
verbose = FALSE
)
expect_identical(dim(rez), c(1L, 4L))
# dataframes -------------------------------------------------
x <- data.frame(replicate(4, rnorm(100)))
expect_warning(expect_warning(
describe_posterior(
x,
centrality = "all",
dispersion = TRUE,
test = "all"
)
))
rez <- suppressWarnings(describe_posterior(x, centrality = "all", dispersion = TRUE, test = "all"))
expect_identical(dim(rez), c(4L, 19L))
expect_warning(expect_warning(
describe_posterior(
x,
centrality = "all",
dispersion = TRUE,
test = "all",
ci = c(0.8, 0.9)
)
))
rez <- suppressWarnings(describe_posterior(
x,
centrality = "all",
dispersion = TRUE,
test = "all",
ci = c(0.8, 0.9)
))
expect_identical(dim(rez), c(8L, 19L))
rez <- describe_posterior(
x,
centrality = NULL,
dispersion = TRUE,
test = NULL,
ci_method = "quantile"
)
expect_identical(dim(rez), c(4L, 4L))
})
test_that("describe_posterior", {
skip_on_os(c("mac", "linux"))
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
set.seed(333)
# Rstanarm
x <- rstanarm::stan_glm(mpg ~ wt, data = mtcars, refresh = 0, iter = 500)
expect_warning(
{
rez <- describe_posterior(x, centrality = "all", dispersion = TRUE, test = "all")
},
regex = "not be precise"
)
expect_identical(dim(rez), c(2L, 21L))
expect_identical(colnames(rez), c(
"Parameter", "Median", "MAD", "Mean", "SD", "MAP", "CI", "CI_low",
"CI_high", "p_MAP", "pd", "p_ROPE", "ps", "ROPE_CI", "ROPE_low",
"ROPE_high", "ROPE_Percentage", "ROPE_Equivalence", "log_BF", "Rhat",
"ESS"
))
expect_warning(
{
rez <- describe_posterior(
x,
centrality = "all",
dispersion = TRUE,
test = "all",
ci = c(0.8, 0.9)
)
},
regex = "not be precise"
)
expect_identical(dim(rez), c(4L, 21L))
rez <- describe_posterior(
x,
centrality = NULL,
dispersion = TRUE,
test = NULL,
ci_method = "quantile",
diagnostic = NULL,
priors = FALSE
)
expect_identical(dim(rez), c(2L, 4L))
# brms -------------------------------------------------
skip_on_os("windows")
x <- suppressWarnings(brms::brm(mpg ~ wt + (1 | cyl) + (1 + wt | gear), data = mtcars, refresh = 0))
rez <- describe_posterior(x, centrality = "all", dispersion = TRUE, ci = c(0.8, 0.9))
expect_identical(dim(rez), c(4L, 16L))
expect_identical(colnames(rez), c(
"Parameter", "Median", "MAD", "Mean", "SD", "MAP", "CI", "CI_low",
"CI_high", "pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage",
"Rhat", "ESS"
))
rez <- describe_posterior(
x,
centrality = NULL,
dispersion = TRUE,
test = NULL,
ci_method = "quantile",
diagnostic = NULL
)
expect_identical(dim(rez), c(2L, 4L))
model <- suppressWarnings(brms::brm(
mpg ~ drat,
data = mtcars,
chains = 2,
algorithm = "meanfield",
refresh = 0
))
expect_identical(nrow(describe_posterior(model)), 2L)
# rstanarm -------------------------------------------------
model <- rstanarm::stan_glm(mpg ~ drat,
data = mtcars,
algorithm = "meanfield",
refresh = 0
)
expect_identical(nrow(describe_posterior(model)), 2L)
model <- suppressWarnings(rstanarm::stan_glm(mpg ~ drat,
data = mtcars,
algorithm = "optimizing",
refresh = 0
))
expect_identical(nrow(describe_posterior(model)), 2L)
model <- rstanarm::stan_glm(mpg ~ drat,
data = mtcars,
algorithm = "fullrank",
refresh = 0
)
expect_identical(nrow(describe_posterior(model)), 2L)
## FIXME: always fails on CI
# model <- brms::brm(mpg ~ drat, data = mtcars, chains = 2, algorithm = "fullrank", refresh = 0)
# expect_equal(nrow(describe_posterior(model)), 2L)
# BayesFactor
x <- BayesFactor::ttestBF(x = rnorm(100, 1, 1))
rez <- describe_posterior(x, centrality = "all", dispersion = TRUE, test = "all")
expect_identical(dim(rez), c(1L, 23L))
rez <- describe_posterior(x, centrality = "all", dispersion = TRUE, test = "all", ci = c(0.8, 0.9))
expect_identical(dim(rez), c(2L, 23L))
rez <- describe_posterior(x, centrality = NULL, dispersion = TRUE, test = NULL, ci_method = "quantile")
expect_identical(dim(rez), c(1L, 7L))
})
test_that("describe_posterior", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
m <- insight::download_model("stanreg_merMod_5")
p <- insight::get_parameters(m, effects = "all")
expect_equal(
describe_posterior(m, effects = "all", verbose = FALSE)$Median,
describe_posterior(p, verbose = FALSE)$Median,
tolerance = 1e-3
)
})
test_that("describe_posterior", {
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
m <- insight::download_model("brms_zi_3")
p <- insight::get_parameters(m, effects = "all", component = "all")
expect_equal(
suppressWarnings(describe_posterior(m, effects = "all", component = "all", verbose = FALSE)$Median),
suppressWarnings(describe_posterior(p, verbose = FALSE)$Median),
tolerance = 1e-3
)
})
test_that("describe_posterior w/ BF+SI", {
skip_on_cran()
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
x <- insight::download_model("stanreg_lm_1")
set.seed(555)
expect_warning(expect_warning({
rez <- describe_posterior(x, ci_method = "SI", test = "bf")
}))
# test si
set.seed(555)
suppressMessages(
expect_warning(
{
rez_si <- si(x)
},
regex = "not be precise"
)
)
expect_equal(rez$CI_low, rez_si$CI_low, tolerance = 0.1)
expect_equal(rez$CI_high, rez_si$CI_high, tolerance = 0.1)
# test BF
set.seed(555)
rez_bf <- suppressWarnings(bayesfactor_parameters(x, verbose = FALSE))
expect_equal(rez$log_BF, log(as.numeric(rez_bf)), tolerance = 0.1)
})
# BayesFactor -------------------------------------------------
test_that("describe_posterior: BayesFactor", {
skip_if_not(getRversion() >= "4.0", "Don't run with R < 4.0")
skip_if_offline()
skip_if_not_or_load_if_installed("rstanarm")
skip_if_not_or_load_if_installed("brms")
skip_if_not_or_load_if_installed("httr")
skip_if_not_or_load_if_installed("BayesFactor")
set.seed(123)
expect_equal(
as.data.frame(describe_posterior(correlationBF(
mtcars$wt,
mtcars$mpg,
rscale = 0.5
))),
structure(
list(
Parameter = "rho",
Median = -0.833281858269296,
CI = 0.95,
CI_low = -0.919418102114416,
CI_high = -0.715602277241063,
pd = 1,
ROPE_CI = 0.95,
ROPE_low = -0.05,
ROPE_high = 0.05,
ROPE_Percentage = 0,
log_BF = 17.328704623688,
BF = 33555274.5519413,
Prior_Distribution = "beta",
Prior_Location = 2,
Prior_Scale = 2
),
row.names = 1L,
class = "data.frame",
ci_method = "hdi"
),
tolerance = 0.1,
ignore_attr = TRUE
)
set.seed(123)
expect_equal(
describe_posterior(ttestBF(mtcars$wt, mu = 3), ci = 0.95, ci_method = "hdi"),
structure(
list(
Parameter = "Difference",
Median = 0.192275922178887,
CI = 0.95,
CI_low = -0.172955539648102,
CI_high = 0.526426796879103,
pd = 0.85875,
ROPE_CI = 0.95,
ROPE_low = -0.0978457442989697,
ROPE_high = 0.0978457442989697,
ROPE_Percentage = 0.257300710339384,
log_BF = -0.94971351422473,
BF = 0.386851835128661,
Prior_Distribution = "cauchy",
Prior_Location = 0,
Prior_Scale = 0.707106781186548
),
row.names = 1L, class = c("describe_posterior", "see_describe_posterior", "data.frame"),
ci_method = "hdi", object_name = "ttestBF(mtcars$wt, mu = 3)"
),
tolerance = 0.1,
ignore_attr = TRUE
)
set.seed(123)
expect_warning(expect_equal(
describe_posterior(
contingencyTableBF(
x = table(mtcars$am, mtcars$cyl),
sampleType = "poisson"
),
ci = 0.95,
ci_method = "hdi"
),
structure(
list(
Parameter = c(
"cell[1,1]",
"cell[2,1]",
"cell[1,2]",
"cell[2,2]",
"cell[1,3]",
"cell[2,3]",
"Ratio"
),
Median = c(
3.04620767622137,
7.33170140780154,
3.96252503900368,
3.06206636495483,
10.7088156207511,
2.26008072419983,
NA
),
CI = c(
0.95, 0.95, 0.95, 0.95, 0.95, 0.95,
NA
),
CI_low = c(
0.537476720942068,
3.33553818106395,
1.05013765177975,
0.746538992318074,
5.49894434136364,
0.275642629940081,
NA
),
CI_high = c(
6.62852027141624,
12.6753970192515,
7.74693313388489,
6.87239730676778,
16.9198964674968,
5.4533083861175,
NA
),
pd = c(1, 1, 1, 1, 1, 1, NA),
ROPE_CI = c(
0.95, 0.95, 0.95,
0.95, 0.95, 0.95, NA
),
ROPE_low = c(
-0.1, -0.1, -0.1, -0.1,
-0.1, -0.1, NA
),
ROPE_high = c(
0.1, 0.1, 0.1, 0.1, 0.1, 0.1,
NA
),
ROPE_Percentage = c(0, 0, 0, 0, 0, 0, NA),
log_BF = c(
3.84187678153378,
3.84187678153378,
3.84187678153378,
3.84187678153378,
3.84187678153378,
3.84187678153378,
NA
),
BF = c(
46.6128745808996,
46.6128745808996,
46.6128745808996,
46.6128745808996,
46.6128745808996,
46.6128745808996,
NA
),
Prior_Distribution = c(NA, NA, NA, NA, NA, NA, "poisson"),
Prior_Location = c(NA, NA, NA, NA, NA, NA, 0),
Prior_Scale = c(
NA,
NA, NA, NA, NA, NA, 1
)
),
row.names = c(
1L, 4L, 2L, 5L, 3L,
6L, 7L
),
class = c("describe_posterior", "see_describe_posterior")
),
tolerance = 0.1,
ignore_attr = TRUE
))
set.seed(123)
expect_warning(expect_equal(
describe_posterior(
contingencyTableBF(
x = table(mtcars$am, mtcars$cyl),
sampleType = "indepMulti",
fixedMargin = "cols",
priorConcentration = 1.6
),
ci = 0.95
),
structure(
list(
Parameter = c(
"cell[1,1]",
"cell[2,1]",
"cell[1,2]",
"cell[2,2]",
"cell[1,3]",
"cell[2,3]",
"Ratio"
),
Median = c(
3.33359102240953,
7.27094924961528,
4.13335763121549,
3.36172537199681,
10.3872621523407,
2.56061336771352,
NA
),
CI = c(
0.95, 0.95, 0.95, 0.95, 0.95, 0.95,
NA
),
CI_low = c(
0.912122089726423,
3.51744611674693,
1.39218072401004,
0.923175932880601,
6.18021898129278,
0.465587711080369,
NA
),
CI_high = c(
6.61128887457661,
11.4058892728414,
7.61378018576518,
6.65522159416386,
15.1209075845299,
5.35853420162441,
NA
),
pd = c(1, 1, 1, 1, 1, 1, NA),
ROPE_CI = c(
0.95, 0.95, 0.95,
0.95, 0.95, 0.95, NA
),
ROPE_low = c(
-0.1, -0.1, -0.1, -0.1,
-0.1, -0.1, NA
),
ROPE_high = c(
0.1, 0.1, 0.1, 0.1, 0.1, 0.1,
NA
),
ROPE_Percentage = c(0, 0, 0, 0, 0, 0, NA),
log_BF = c(
2.49338780738881,
2.49338780738881,
2.49338780738881,
2.49338780738881,
2.49338780738881,
2.49338780738881,
NA
),
BF = c(
12.1022066941064,
12.1022066941064,
12.1022066941064,
12.1022066941064,
12.1022066941064,
12.1022066941064,
NA
),
Prior_Distribution = c(NA, NA, NA, NA, NA, NA, "independent multinomial"),
Prior_Location = c(NA, NA, NA, NA, NA, NA, 0),
Prior_Scale = c(
NA,
NA, NA, NA, NA, NA, 1.6
)
),
row.names = c(
1L, 4L, 2L, 5L,
3L, 6L, 7L
),
class = c(
"describe_posterior", "see_describe_posterior",
"data.frame"
),
ci_method = "hdi",
object_name = "contingencyTableBF(x = table(mtcars$am, mtcars$cyl), sampleType = \"indepMulti\", fixedMargin = \"cols\", priorConcentration = 1.6)"
),
tolerance = 0.1,
ignore_attr = TRUE
))
skip_on_os("linux")
set.seed(123)
expect_equal(
describe_posterior(anovaBF(extra ~ group, data = sleep, progress = FALSE), ci_method = "hdi", ci = 0.95),
structure(
list(
Parameter = c(
"mu", "group-1", "group-2", "sig2",
"g_group"
),
Median = c(
1.53667371296145,
-0.571674439385088,
0.571674439385088,
3.69268743002151,
0.349038661644431
),
CI = c(
0.95,
0.95, 0.95, 0.95, 0.95
),
CI_low = c(
0.691696017646264,
-1.31604531656452,
-0.229408603643392,
1.75779899540302,
0.0192738130412634
),
CI_high = c(
2.43317955922589,
0.229408603643392,
1.31604531656452,
6.88471056133351,
5.30402785651874
),
pd = c(0.99975, 0.927, 0.927, 1, 1),
ROPE_CI = c(
0.95, 0.95,
0.95, 0.95, 0.95
),
ROPE_low = c(
-0.201791972090071,
-0.201791972090071,
-0.201791972090071,
-0.201791972090071,
-0.201791972090071
),
ROPE_high = c(
0.201791972090071,
0.201791972090071,
0.201791972090071,
0.201791972090071,
0.201791972090071
),
ROPE_Percentage = c(
0,
0.162325703762168, 0.162325703762168, 0, 0.346487766377269
),
log_BF = c(
0.235803198474248,
0.235803198474248,
0.235803198474248,
0.235803198474248,
0.235803198474248
),
BF = c(
1.26592514964916,
1.26592514964916,
1.26592514964916,
1.26592514964916,
1.26592514964916
),
Prior_Distribution = c(NA, "cauchy", "cauchy", NA, NA),
Prior_Location = c(NA, 0, 0, NA, NA),
Prior_Scale = c(
NA,
0.5, 0.5, NA, NA
)
),
row.names = c(4L, 2L, 3L, 5L, 1L),
class = c(
"describe_posterior",
"see_describe_posterior", "data.frame"
),
ci_method = "hdi",
object_name = "anovaBF(extra ~ group, data = sleep, progress = FALSE)"
),
tolerance = 0.1,
ignore_attr = TRUE
)
})
bayestestR/tests/testthat.R 0000644 0001762 0000144 00000000104 14410351152 015513 0 ustar ligges users library(testthat)
library(bayestestR)
test_check("bayestestR")
bayestestR/MD5 0000644 0001762 0000144 00000024503 14650205472 012720 0 ustar ligges users 5467592e579e062f05eb04f6705cd86c *DESCRIPTION
24460cefb43f61eea3026c1a1759fd1a *NAMESPACE
279e607c0de731df7672fb01c368a67e *NEWS.md
0604665d2ad6f0c6a2f0307b6993f2c6 *R/area_under_curve.R
a990bddd4c54e18ca2bb3b5cf954cbee *R/as.list.R
c68f950221755d3f1012aaced44e8cb3 *R/bayesfactor.R
509235a62fe944c02c91cf7dd2f92320 *R/bayesfactor_inclusion.R
59dc23c9469cdec1872fca73d0a0abf4 *R/bayesfactor_models.R
b544b49858d3439fa3fbb4001e7e43ab *R/bayesfactor_parameters.R
74780cb7c8ae22c4241fd3d1aa1ec37a *R/bayesfactor_restricted.R
89fb8182fcba929c2bf1034641601fcc *R/bayestestR-package.R
2d06a4d59b55477bdee0ebe40f5c9ba3 *R/bci.R
f0d8bdbcd6e8008e09451fda7bff46d4 *R/bic_to_bf.R
9d76be7e7e78827898b6a79f72d7fb73 *R/check_prior.R
a53c51c3e6e39565d5c602e05bc4d965 *R/ci.R
cdc6feff5058d041bfadfc63262fab29 *R/contr.equalprior.R
8fd49be9f215e98477326851e5d404e8 *R/convert_bayesian_to_frequentist.R
7e69bc008c067c2f8be0b03774c8ad08 *R/convert_pd_to_p.R
190bd1fd94590a6066de0207c8d37908 *R/cwi.R
e87daed2f8a248c6d092f14fc1b1ce6e *R/datasets.R
5994aaddf4825acecedcc6170001a9a1 *R/describe_posterior.R
8cdee73fb7a11c1e358c00cbe271fb5f *R/describe_prior.R
07a3ef303d5edcf5a47f806de573ca14 *R/diagnostic_draws.R
546f941926feffb87ee1c7246b2e4d59 *R/diagnostic_posterior.R
2ef8f63bb10102f5e1dd466c8c89e7a3 *R/distribution.R
b3429b29a577a8d4edf92e42c9d7fbfa *R/effective_sample.R
c77e9f62dd7ed9d4271004fd2373b77c *R/equivalence_test.R
6a1687fc9485a89d8e276152e64b0ea6 *R/estimate_density.R
01e66af9e7aa940151ec9d0e9c35e848 *R/eti.R
66377d7815be6cd7ae9194aa58d34369 *R/format.R
b2bd5c0b68a38c528383b532bfe3c167 *R/hdi.R
b91452763f887f33e7edde633a4105c5 *R/map_estimate.R
5624d2d58f32cc6064256b6fd13773ea *R/mcse.R
3aacb0df3ceaa53e74a1828e198ef788 *R/mediation.R
daeae2872aabcd1eb4d829e7d433c4c9 *R/model_to_priors.R
a6bc5fac0c8d4c85cb6bbd1dbaf1c9de *R/overlap.R
1156ea6a4bf1ae4d9eabade4a94ded1a *R/p_direction.R
28f3dab6fc2ecf9f18135e75496d067f *R/p_map.R
1a1130aac70e2d36f5b704dcaa7f06f9 *R/p_rope.R
daeaffd7ab1e2a279acfafeafa84d589 *R/p_significance.R
69da1aac27160dd2868f6c60907e6e6f *R/p_to_bf.R
1ba410a92cded6f84210c41c6f77dff2 *R/plot.R
972fb4f3a7a98fcda8027aa7c82a1143 *R/point_estimate.R
79fedadc25e0f38db188ebcc7cba024e *R/print.R
a344d1b115e162c5529517c57e4de7ec *R/print.bayesfactor_models.R
f71a5c3ba3dc2b3164b949aba2127aa9 *R/print.equivalence_test.R
1bcea270139b446e8e6acdf3c781c219 *R/print.rope.R
22c987d2dcb8cd8e2f2e7db3fe3c4537 *R/print_html.R
fa25fa2a466d3f4345cb27818ceaad67 *R/print_md.R
220596108fa27b0f9a948182a1fdecf0 *R/reexports.R
b18d7f1c872653866dd87887788e3730 *R/reshape_iterations.R
ebdef9e9623dac52d34fb012912e0de0 *R/rope.R
84d63adce94f6341b19df51576c3bb26 *R/rope_range.R
858fa25d00f95ba6be4cb1e166f5c5b4 *R/sensitivity_to_prior.R
103bb63bb620db4c06320f4674d2fcda *R/sexit.R
9a7a7235e8c4f330b2a6d10cd0bec092 *R/sexit_thresholds.R
75f326db1a5b94d035f046b73d9c86c1 *R/si.R
5ed24ba2ca1e002e58c9fe32da6aa6c3 *R/simulate_data.R
a20aef6603c3d1260ffb22a11ed28335 *R/simulate_priors.R
0bee756e9222e11a6ac89a2ec9dd37a0 *R/simulate_simpson.R
907a80720b8ac659def948813989a116 *R/spi.R
b16770c848b5decb32e4fb993a6288f0 *R/unupdate.R
9a08b36c50f58f46baf2c1420b67db77 *R/utils.R
48ffcdebc53a98a332111d183a6cb28c *R/utils_bayesfactor.R
dc05f6b835fc003670256f8bc911fd8f *R/utils_check_collinearity.R
8117073ed9981ca4f4cc32780cbeffaf *R/utils_clean_stan_parameters.R
2f2430c0d399a8fd2281d4249a7f9134 *R/utils_hdi_ci.R
506839f138e42454411368529c153561 *R/utils_posterior.R
3c9efbb87da18038c6f02cbf3f50ee07 *R/utils_print_data_frame.R
4ba724c3b33f55809a282267ae264fe9 *R/weighted_posteriors.R
4533f523d6cb92676f1d7912e088e29b *R/zzz.R
752dc03e8a222205b8a0b7413b237cdf *README.md
b943a1546a1e17be4eea235ec7b4616b *build/partial.rdb
30d88039c6d0b1d25f5ccc87e8a0edd3 *build/vignette.rds
0ff3ea913147c5a1b14eb94d50333b98 *data/disgust.rdata
c5cfd3e44877e6f8487a7d57c28dd0e2 *inst/CITATION
699df22b7a5b577a474fc2d059dd5420 *inst/WORDLIST
7342a6d63f4cc4501afc55be1d148740 *inst/doc/overview_of_vignettes.R
d3047f8dd544e4791a13e4ede781199f *inst/doc/overview_of_vignettes.Rmd
0fc7c30724becb44d7363bfce3a337ad *inst/doc/overview_of_vignettes.html
261ba655620dfbd3001fa10238ff6d0e *man/area_under_curve.Rd
6860290cbdd452ec9f23f98ddf68fb99 *man/as.data.frame.density.Rd
3d348eff3f4bc590080a8cd696304d75 *man/as.numeric.p_direction.Rd
e855f04ef744f8385bb5ff8d729f1b30 *man/bayesfactor.Rd
33c0ddfd71b66f303b87e6f0940ae55c *man/bayesfactor_inclusion.Rd
3710a35648f2e0b6338e0912d20bde66 *man/bayesfactor_models.Rd
e44ccb4b3648e2261d208ab46af73953 *man/bayesfactor_parameters.Rd
1e9a9de38af2c28e52412c669fa50375 *man/bayesfactor_restricted.Rd
0e660b53f132dfe68cd3233473695d77 *man/bayestestR-package.Rd
630b700cf3884eddc9f6f762e79b80e7 *man/bci.Rd
0be80726d814018e2b8a86480ff4c64f *man/bic_to_bf.Rd
72fa3e2155d4f5f5d284d5098716b522 *man/check_prior.Rd
afcd326f7369466c25ab5cc368a45042 *man/ci.Rd
ade20e470426dcac15633c0337c8aea4 *man/contr.equalprior.Rd
5a4a4b98942ff65245147f8f2b8b2d25 *man/convert_bayesian_as_frequentist.Rd
245275e593fb278088d13ebac219334f *man/cwi.Rd
3b8a829f3b094fa97dccb2f654445209 *man/density_at.Rd
daf8d1ad4144ee9efa0cc5fbc298c51c *man/describe_posterior.Rd
a0e60315e5fe72edc67cbe0a5acebbb2 *man/describe_prior.Rd
20eef5a1b756669413a6b3f2a93ff7b4 *man/diagnostic_draws.Rd
daa029cf8953c9f4d1561d368d25bf21 *man/diagnostic_posterior.Rd
933a334f0afcb213569e4ad5d3446e6e *man/disgust.Rd
96a78333a48f5f062fc36ef2466fb1ad *man/distribution.Rd
0b1d93b59d19425ddb3a0d40f38210c1 *man/dot-extract_priors_rstanarm.Rd
e450b5ed09ce1a54bb53cf57a436a1a5 *man/dot-prior_new_location.Rd
1991efd66189082be157e0b5d706e148 *man/dot-select_nums.Rd
e2cedb0fc98aac7c152e1840196a9d3b *man/effective_sample.Rd
b20a411d7b2408d0da847d5639eba4c7 *man/equivalence_test.Rd
18b3fc96fb40db3d7ec32c4ca757adac *man/estimate_density.Rd
081cfc774dda48000f819c5958626070 *man/eti.Rd
27e0ea3ff40617aff2e5f74afd47970c *man/figures/logo.png
95eb48acb3a4398f6c648d3f209969c2 *man/figures/unnamed-chunk-10-1.png
fcc274e2a045a9904eb3f9807ec3bee5 *man/figures/unnamed-chunk-12-1.png
41e022a55f72d117bad753c6d163251a *man/figures/unnamed-chunk-14-1.png
0441a5adb59a4e71368ee1bf2f4e4622 *man/figures/unnamed-chunk-16-1.png
e51731eeb3c732505f0d2f6b6591b530 *man/figures/unnamed-chunk-7-1.png
54381c7e60fbcc47dc9121e99f37eab7 *man/figures/unnamed-chunk-8-1.png
4a500d7637d32889621e0577c4d7d623 *man/hdi.Rd
28fc4c311781c4cc4a14492d0cef6c7b *man/map_estimate.Rd
a70a9ca3050f68740a8b85ceeed2881f *man/mcse.Rd
e87f34c5d8460e2c972a928ab659157d *man/mediation.Rd
04325eac6de74b6fd291888e66cdfddd *man/model_to_priors.Rd
82e90642b674945fa11cf4523c4d170b *man/overlap.Rd
036d5b4161612507e5d07b01a2e4b28c *man/p_direction.Rd
27a7f5c1d23b2117c58900408eb6e5ca *man/p_map.Rd
264bdf29fe7885dca38b97356b065024 *man/p_rope.Rd
0637d164787411d5245a5459fa658275 *man/p_significance.Rd
3e828bec75a649c37ee6978a3ff49d91 *man/p_to_bf.Rd
e32f5525fbe34d074ea52011350fbfb7 *man/pd_to_p.Rd
3655cb85c451c7f5cdc0b3f99c29b2d9 *man/point_estimate.Rd
235c2dd7581167a298c050ad2e73827c *man/reexports.Rd
f9baf506f3a47e5e259a7417091cbce2 *man/reshape_iterations.Rd
ac2fd0cdae94977135db31bdc5afbcdb *man/rope.Rd
256ad54b0f558735148ed8b93082a06d *man/rope_range.Rd
a126edc6b223a27ef94790d33538e0f4 *man/sensitivity_to_prior.Rd
dac60eb2c7370097ecac4252da8dbc44 *man/sexit.Rd
88a10e6bed8b5ae44887dfaa551df89b *man/sexit_thresholds.Rd
ec48991d3db0362bc863ec434c928058 *man/si.Rd
701f0ff083a19850d80fca995be49f9b *man/simulate_correlation.Rd
16f1139bdacc05d480a244a582057ae0 *man/simulate_prior.Rd
c98afef9cd5b6e9161c9dbd20d605935 *man/simulate_simpson.Rd
25754b60ac0b04622b954a84ecc25b91 *man/spi.Rd
0e46ab795e2b2bece62bd73f17a092c1 *man/unupdate.Rd
d33463862f6c1c40a81597678cf0e833 *man/weighted_posteriors.Rd
ed019fb28c42d301a471042302b2215d *tests/testthat.R
de92b9f5e7eeb50216a96b2e24a5b895 *tests/testthat/_snaps/windows/print.md
0e84b6d82ae0c55225f7b5606bc6ab10 *tests/testthat/helper.R
77395e828ae6acde88f6ea2ca2f9b222 *tests/testthat/test-BFBayesFactor.R
a9cbb2928bdc3e39c85d40383e12f538 *tests/testthat/test-as.data.frame.density.R
eef4a1a72c092cab473b294c7a2982bf *tests/testthat/test-bayesfactor_models.R
a44963bbf8cd715f1723068ec282e10c *tests/testthat/test-bayesfactor_parameters.R
077031f36901d45428f91e05c024e261 *tests/testthat/test-bayesfactor_restricted.R
7fb6240e9b636e55c004aa5b797d2454 *tests/testthat/test-bayesian_as_frequentist.R
5c2df544d4445aaba6280d5dc2f537c5 *tests/testthat/test-blavaan.R
e2b86c6ab2d92428332b9ccb6f702f8b *tests/testthat/test-brms.R
7f86a30f5d30607dac38e0b0f775ae7c *tests/testthat/test-check_prior.R
cd1d3fdc35a5ab9386ac9474a1a717f6 *tests/testthat/test-ci.R
43dfdbc876dff66ea3914899c32f73c0 *tests/testthat/test-contr.R
8cfbb3b3a84cc76ad6fac4e191b705a7 *tests/testthat/test-density_at.R
fddfe8dda5d00d39f3059d4b532bb293 *tests/testthat/test-describe_posterior.R
c8a2b2e3280179cff311e949feeb11f0 *tests/testthat/test-describe_prior.R
db725a1034057c4cc62159b861fd88a1 *tests/testthat/test-different_models.R
ed8c019fa0e88ef258102036899bf543 *tests/testthat/test-distributions.R
155ca1bd378bdb782f3898979d552875 *tests/testthat/test-effective_sample.R
c682caf6c03880c4d4029de189650a46 *tests/testthat/test-emmGrid.R
72390c0791e5b44a7550bb9d5a06a677 *tests/testthat/test-estimate_density.R
a13a9f515a42098194c484317fc682e5 *tests/testthat/test-format.R
5bc1f532113a29c626fe3da1999240ed *tests/testthat/test-hdi.R
b8a239722c3e435c71c8cb3ccfae7310 *tests/testthat/test-map_estimate.R
7a8d3e0aff4d56f414f9adbc6f657275 *tests/testthat/test-overlap.R
72c5a037085079830860a8a642aae932 *tests/testthat/test-p_direction.R
fd9d374ddc9b21e245cb8288f824fd84 *tests/testthat/test-p_map.R
f0aa2987c5055958c8a8e8db2dc4e20b *tests/testthat/test-p_significance.R
339b310dff63000e06b2f5a03836fb71 *tests/testthat/test-p_to_bf.R
7af7475726cb85b9af8c37003d69e88a *tests/testthat/test-pd_to_p.R
a7f7028b1ceb5fa0047c559317f4ed1b *tests/testthat/test-point_estimate.R
f121cb3927a29cf5fc358b1c3b745434 *tests/testthat/test-posterior.R
b0f25e5267f9774b690ede04c7d92cbb *tests/testthat/test-print.R
845d09eb4c1df0e9cb8a6dcb3ba31339 *tests/testthat/test-rope.R
396302ad4ece0fced3d23ab54df63ec4 *tests/testthat/test-rope_range.R
b7e1493592ba286a01045eb5ff42c3e0 *tests/testthat/test-rstanarm.R
ff4c3c90dc4dce37fae9e8c3fef3787a *tests/testthat/test-si.R
97679c198087bafee22b280e9069032c *tests/testthat/test-simulate_data.R
755dca6c1088356016fc2907229f6410 *tests/testthat/test-spi.R
43b7ad10a9e4e086dcea0c246ad88153 *tests/testthat/test-weighted_posteriors.R
d3047f8dd544e4791a13e4ede781199f *vignettes/overview_of_vignettes.Rmd
bayestestR/R/ 0000755 0001762 0000144 00000000000 14650200252 012574 5 ustar ligges users bayestestR/R/format.R 0000644 0001762 0000144 00000024212 14560763455 014233 0 ustar ligges users #' @export
format.describe_posterior <- function(x,
cp = NULL,
digits = 2,
format = "text",
ci_string = "CI",
caption = NULL,
subtitles = NULL,
...) {
# reshape CI
if (is.data.frame(x) && insight::n_unique(x$CI) > 1) {
att <- attributes(x)
x <- datawizard::reshape_ci(x)
attributes(x) <- utils::modifyList(att, attributes(x))
}
# validation check
if (is.null(digits)) {
digits <- 2
}
# format columns and values of data frame
out <- insight::format_table(x, digits = digits, format = format, ...)
# different CI-types as column names?
if (ci_string != "CI" && any(endsWith(colnames(out), "CI"))) {
colnames(out) <- gsub("(.*)CI$", paste0("\\1", ci_string), colnames(out))
}
# match and split at components
if (!is.null(cp) && !all(is.na(match(cp$Parameter, out$Parameter)))) {
out <- insight::print_parameters(
cp,
out,
keep_parameter_column = FALSE,
remove_empty_column = TRUE,
titles = caption,
subtitles = subtitles,
format = format
)
} else {
attr(out, "table_caption") <- caption
attr(out, "table_subtitle") <- subtitles
}
out
}
#' @export
format.point_estimate <- format.describe_posterior
#' @export
format.p_rope <- format.describe_posterior
#' @export
format.p_direction <- format.describe_posterior
#' @export
format.p_map <- format.describe_posterior
#' @export
format.map_estimate <- format.describe_posterior
#' @export
format.p_significance <- format.describe_posterior
#' @export
format.bayestestR_hdi <- format.describe_posterior
#' @export
format.bayestestR_eti <- format.describe_posterior
#' @export
format.bayestestR_si <- format.describe_posterior
#' @export
format.equivalence_test <- format.describe_posterior
#' @export
format.rope <- format.describe_posterior
# special handling for bayes factors ------------------
#' @export
format.bayesfactor_models <- function(x,
digits = 3,
log = FALSE,
show_names = TRUE,
format = "text",
caption = NULL,
exact = TRUE,
...) {
BFE <- x
denominator <- attr(BFE, "denominator")
grid.type <- attr(BFE, "BF_method")
model_names <- attr(BFE, "model_names")
formula_length <- attr(BFE, "text_length")
BFE <- as.data.frame(BFE)
BFE$log_BF <- as.numeric(x, log = log)
BFE$BF <- insight::format_bf(abs(BFE$log_BF), name = NULL, exact = exact, ...)
if (any((sgn <- sign(BFE$log_BF) < 0)[!is.na(BFE$log_BF)])) {
BFE$BF[sgn] <- paste0("-", BFE$BF[sgn])
}
BFE$Model[BFE$Model == "1"] <- "(Intercept only)" # indicate null-model
# shorten model formulas?
if (!is.null(formula_length) && !is.null(BFE$Model)) {
BFE$Model <- insight::format_string(BFE$Model, length = formula_length)
}
if (isFALSE(show_names) || is.null(model_names) || length(model_names) != nrow(BFE)) {
BFE$i <- paste0("[", seq_len(nrow(BFE)), "]")
} else {
BFE$i <- paste0("[", model_names, "]")
}
# Denominator
denM <- insight::trim_ws(paste0(BFE$i, " ", BFE$Model)[denominator])
BFE <- BFE[-denominator, ]
BFE <- BFE[c("i", "Model", "BF")]
colnames(BFE)[1] <- ifelse(identical(format, "html"), "Name", "")
# footer
if (is.null(format) || format == "text") {
footer <- list(
"\n* Against Denominator: ",
c(denM, "cyan"),
"\n* Bayes Factor Type: ",
c(grid.type, "cyan"),
if (log) c("\n\nBayes Factors are on the log-scale.", "red")
)
# color formatting for caption
if (!is.null(caption)) {
caption <- c(caption, "blue")
}
} else {
footer <- insight::compact_list(list(
paste0("Against Denominator: ", denM),
paste0("Bayes Factor Type: ", grid.type),
if (log) "Bayes Factors are on the log-scale."
))
}
attr(BFE, "table_footer") <- footer
attr(BFE, "table_caption") <- caption
BFE
}
#' @export
format.bayesfactor_inclusion <- function(x,
digits = 3,
log = FALSE,
format = "text",
caption = NULL,
exact = TRUE,
...) {
priorOdds <- attr(x, "priorOdds")
matched <- attr(x, "matched")
# format table
BFE <- as.data.frame(x)
BFE$log_BF <- as.numeric(x, log = log)
BFE$BF <- insight::format_bf(abs(BFE$log_BF), name = NULL, exact = exact, ...)
if (any((sgn <- sign(BFE$log_BF) < 0)[!is.na(BFE$log_BF)])) {
BFE$BF[sgn] <- paste0("-", BFE$BF[sgn])
}
BFE <- BFE[c("p_prior", "p_posterior", "BF")]
BFE <- cbind(rownames(BFE), BFE)
colnames(BFE) <- c("", "P(prior)", "P(posterior)", "Inclusion BF")
colnames(BFE)[1] <- ifelse(identical(format, "html"), "Parameter", "")
# footer
if (is.null(format) || format == "text") {
footer <- list(
"\n* Compared among: ",
c(if (matched) "matched models only" else "all models", "cyan"),
"\n* Priors odds: ",
c(if (!is.null(priorOdds)) "custom" else "uniform-equal", "cyan"),
if (log) c("\n\nBayes Factors are on the log-scale.", "red")
)
# color formatting for caption
if (!is.null(caption)) {
caption <- c(caption, "blue")
}
} else {
footer <- insight::compact_list(list(
paste0("Compared among: ", if (matched) "matched models only" else "all models"),
paste0("Priors odds: ", if (!is.null(priorOdds)) "custom" else "uniform-equal"),
if (log) "Bayes Factors are on the log-scale."
))
}
attr(BFE, "table_footer") <- footer
attr(BFE, "table_caption") <- caption
BFE
}
#' @export
format.bayesfactor_restricted <- function(x,
digits = 3,
log = FALSE,
format = "text",
caption = NULL,
exact = TRUE,
...) {
BFE <- as.data.frame(x)
# Format
BFE$log_BF <- as.numeric(x, log = log)
BFE$BF <- insight::format_bf(abs(BFE$log_BF), name = NULL, exact = exact, ...)
if (any((sgn <- sign(BFE$log_BF) < 0)[!is.na(BFE$log_BF)])) {
BFE$BF[sgn] <- paste0("-", BFE$BF[sgn])
}
BFE$log_BF <- NULL
colnames(BFE) <- c("Hypothesis", "P(Prior)", "P(Posterior)", "BF")
# footer
if (is.null(format) || format == "text") {
footer <- list(
"\n* Bayes factors for the restricted model vs. the un-restricted model.\n",
if (log) c("\nBayes Factors are on the log-scale.\n", "red")
)
# color formatting for caption
if (!is.null(caption)) {
caption <- c(caption, "blue")
}
} else {
footer <- insight::compact_list(list(
"Bayes factors for the restricted model vs. the un-restricted model.",
if (log) "Bayes Factors are on the log-scale."
))
}
attr(BFE, "table_footer") <- footer
attr(BFE, "table_caption") <- caption
BFE
}
#' @export
format.bayesfactor_parameters <- function(x,
cp = NULL,
digits = 3,
log = FALSE,
format = "text",
exact = TRUE,
...) {
null <- attr(x, "hypothesis")
direction <- attr(x, "direction")
x$log_BF <- as.numeric(x, log = log)
x$BF_override <- insight::format_bf(abs(x$log_BF), name = NULL, exact = exact, ...)
if (any((sgn <- sign(x$log_BF) < 0)[!is.na(x$log_BF)])) {
x$BF_override[sgn] <- paste0("-", x$BF_override[sgn])
}
x$log_BF <- NULL
# format columns and values of data frame
out <- insight::format_table(x, digits = digits, format = format, ...)
colnames(out)[colnames(out) == "BF_override"] <- "BF"
# table caption
caption <- sprintf(
"Bayes Factor (%s)",
if (length(null) == 1) "Savage-Dickey density ratio" else "Null-Interval"
)
if (is.null(format) || format == "text") {
caption <- c(caption, "blue")
}
# format null-value
if (length(null) == 1) {
null <- insight::format_value(null, digits = digits, protect_integers = TRUE)
} else {
null <- insight::format_ci(null[1], null[2], ci = NULL, digits = digits)
}
# footer
if (is.null(format) || format == "text") {
footer <- list(
"\n* Evidence Against The Null: ",
c(paste0(null, "\n"), "cyan"),
if (direction) "* Direction: ",
if (direction < 0) c("Left-Sided test", "cyan"),
if (direction > 0) c("Right-Sided test", "cyan"),
if (direction) "\n",
if (log) c("\n\nBayes Factors are on the log-scale.\n", "red")
)
} else {
footer <- insight::compact_list(list(
paste0("Evidence Against The Null: ", null),
if (direction) "Direction: ",
if (direction < 0) "Left-Sided test",
if (direction > 0) "Right-Sided test",
if (log) "Bayes Factors are on the log-scale."
))
}
# match and split at components
if (!is.null(cp) && !all(is.na(match(cp$Parameter, out$Parameter)))) {
out <- insight::print_parameters(
cp,
out,
keep_parameter_column = FALSE,
remove_empty_column = TRUE,
format = format
)
attr(out[[1]], "table_caption") <- caption
attr(out[[length(out)]], "table_footer") <- footer
} else {
attr(out, "table_caption") <- caption
attr(out, "table_footer") <- footer
}
out
}
bayestestR/R/diagnostic_draws.R 0000644 0001762 0000144 00000003066 14560763455 016273 0 ustar ligges users #' Diagnostic values for each iteration
#'
#' Returns the accumulated log-posterior, the average Metropolis acceptance rate, divergent transitions, treedepth rather than terminated its evolution normally.
#' @inheritParams diagnostic_posterior
#'
#' @examples
#' \donttest{
#' set.seed(333)
#'
#' if (require("brms", quietly = TRUE)) {
#' model <- suppressWarnings(brm(mpg ~ wt * cyl * vs,
#' data = mtcars,
#' iter = 100, control = list(adapt_delta = 0.80),
#' refresh = 0
#' ))
#' diagnostic_draws(model)
#' }
#' }
#'
#' @export
diagnostic_draws <- function(posterior, ...) {
UseMethod("diagnostic_draws")
}
#' @export
diagnostic_draws.brmsfit <- function(posterior, ...) {
insight::check_if_installed("brms")
data <- brms::nuts_params(posterior)
data$idvar <- paste0(data$Chain, "_", data$Iteration)
out <- stats::reshape(
data,
v.names = "Value",
idvar = "idvar",
timevar = "Parameter",
direction = "wide"
)
out$idvar <- NULL
out <- merge(out, brms::log_posterior(posterior), by = c("Chain", "Iteration"), sort = FALSE)
# Rename
names(out)[names(out) == "Value.accept_stat__"] <- "Acceptance_Rate"
names(out)[names(out) == "Value.treedepth__"] <- "Tree_Depth"
names(out)[names(out) == "Value.stepsize__"] <- "Step_Size"
names(out)[names(out) == "Value.divergent__"] <- "Divergent"
names(out)[names(out) == "Value.n_leapfrog__"] <- "n_Leapfrog"
names(out)[names(out) == "Value.energy__"] <- "Energy"
names(out)[names(out) == "Value"] <- "LogPosterior"
out
}
bayestestR/R/effective_sample.R 0000644 0001762 0000144 00000014150 14650172354 016234 0 ustar ligges users #' Effective Sample Size (ESS)
#'
#' This function returns the effective sample size (ESS).
#'
#' @param model A `stanreg`, `stanfit`, `brmsfit`, `blavaan`, or `MCMCglmm` object.
#' @param ... Currently not used.
#' @inheritParams hdi
#'
#' @return A data frame with two columns: Parameter name and effective sample size (ESS).
#'
#' @details **Effective Sample (ESS)** should be as large as possible, altough
#' for most applications, an effective sample size greater than 1,000 is
#' sufficient for stable estimates (Bürkner, 2017). The ESS corresponds to the
#' number of independent samples with the same estimation power as the N
#' autocorrelated samples. It is is a measure of \dQuote{how much independent
#' information there is in autocorrelated chains} (*Kruschke 2015, p182-3*).
#'
#' @references
#' - Kruschke, J. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press.
#' - Bürkner, P. C. (2017). brms: An R package for Bayesian multilevel models using Stan. Journal of Statistical Software, 80(1), 1-28
#'
#' @examplesIf require("rstanarm")
#' \donttest{
#' library(rstanarm)
#' model <- suppressWarnings(
#' stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0)
#' )
#' effective_sample(model)
#' }
#' @export
effective_sample <- function(model, ...) {
UseMethod("effective_sample")
}
#' @export
effective_sample.default <- function(model, ...) {
insight::format_error(
paste0(
"'effective_sample()' is not yet implemented for objects of class '",
class(model)[1],
"'."
)
)
}
#' @rdname effective_sample
#' @export
effective_sample.brmsfit <- function(model,
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
...) {
# check arguments
effects <- match.arg(effects)
component <- match.arg(component)
pars <- insight::find_parameters(
model,
effects = effects,
component = component,
parameters = parameters,
flatten = TRUE
)
insight::check_if_installed("rstan")
s <- rstan::summary(model$fit)$summary
s <- subset(s, subset = rownames(s) %in% pars)
data.frame(
Parameter = rownames(s),
ESS = round(s[, "n_eff"]),
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @rdname effective_sample
#' @export
effective_sample.stanreg <- function(model,
effects = c("fixed", "random", "all"),
component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"),
parameters = NULL,
...) {
# check arguments
effects <- match.arg(effects)
component <- match.arg(component)
pars <- insight::find_parameters(
model,
effects = effects,
component = component,
parameters = parameters,
flatten = TRUE
)
s <- as.data.frame(summary(model))
s <- s[rownames(s) %in% pars, ]
data.frame(
Parameter = rownames(s),
ESS = s[["n_eff"]],
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @export
effective_sample.stanmvreg <- function(model,
effects = c("fixed", "random", "all"),
component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"),
parameters = NULL,
...) {
# check arguments
effects <- match.arg(effects)
component <- match.arg(component)
pars <- insight::get_parameters(
model,
effects = effects,
component = component,
parameters = parameters
)
s <- as.data.frame(summary(model))
s <- s[rownames(s) %in% colnames(pars), ]
data.frame(
Parameter = rownames(s),
ESS = s[["n_eff"]],
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @export
effective_sample.stanfit <- function(model,
effects = c("fixed", "random", "all"),
parameters = NULL,
...) {
# check arguments
effects <- match.arg(effects)
pars <-
insight::get_parameters(
model,
effects = effects,
parameters = parameters
)
insight::check_if_installed("rstan")
s <- as.data.frame(rstan::summary(model)$summary)
s <- s[rownames(s) %in% colnames(pars), ]
data.frame(
Parameter = rownames(s),
ESS = s[["n_eff"]],
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @export
effective_sample.blavaan <- function(model, parameters = NULL, ...) {
insight::check_if_installed("blavaan")
ESS <- blavaan::blavInspect(model, what = "neff")
data.frame(
Parameter = colnames(insight::get_parameters(model)),
ESS = ESS,
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @export
effective_sample.MCMCglmm <- function(model,
effects = c("fixed", "random", "all"),
parameters = NULL,
...) {
# check arguments
effects <- match.arg(effects)
pars <-
insight::get_parameters(
model,
effects = effects,
parameters = parameters,
summary = TRUE
)
s.fixed <- as.data.frame(summary(model)$solutions)
s.random <- as.data.frame(summary(model)$Gcovariances)
es <- data.frame(
Parameter = rownames(s.fixed),
ESS = round(s.fixed[["eff.samp"]]),
stringsAsFactors = FALSE,
row.names = NULL
)
if (nrow(s.random) > 0L) {
es <- rbind(es, data.frame(
Parameter = rownames(s.random),
ESS = round(s.random[["eff.samp"]]),
stringsAsFactors = FALSE,
row.names = NULL
))
}
es[match(pars[[1]], es$Parameter), ]
}
bayestestR/R/plot.R 0000644 0001762 0000144 00000004565 14505754740 013726 0 ustar ligges users #' @export
plot.equivalence_test <- function(x, ...) {
insight::check_if_installed("see", "to plot results from equivalence-test")
NextMethod()
}
#' @export
plot.p_direction <- function(x, ...) {
insight::check_if_installed("see", "to plot results from p_direction()")
NextMethod()
}
#' @export
plot.point_estimate <- function(x, ...) {
insight::check_if_installed("see", "to plot point-estimates")
NextMethod()
}
#' @export
plot.map_estimate <- function(x, ...) {
insight::check_if_installed("see", "to plot point-estimates")
NextMethod()
}
#' @export
plot.rope <- function(x, ...) {
insight::check_if_installed("see", "to plot ROPE")
NextMethod()
}
#' @export
plot.bayestestR_hdi <- function(x, ...) {
insight::check_if_installed("see", "to plot HDI")
NextMethod()
}
#' @export
plot.bayestestR_eti <- function(x, ...) {
insight::check_if_installed("see", "to plot credible intervals")
NextMethod()
}
#' @export
plot.bayestestR_si <- function(x, ...) {
insight::check_if_installed("see", "to plot support intervals")
NextMethod()
}
#' @export
plot.bayesfactor_parameters <- function(x, ...) {
insight::check_if_installed("see", "to plot Savage-Dickey Bayes factor")
NextMethod()
}
#' @export
plot.bayesfactor_models <- function(x, ...) {
insight::check_if_installed("see", "to plot models' Bayes factors")
NextMethod()
}
#' @export
plot.estimate_density <- function(x, ...) {
insight::check_if_installed("see", "to plot densities")
NextMethod()
}
#' @export
plot.estimate_density_df <- function(x, ...) {
insight::check_if_installed("see", "to plot models' densities")
NextMethod()
}
#' @export
plot.p_significance <- function(x, ...) {
insight::check_if_installed("see", "to plot practical significance")
NextMethod()
}
#' @export
plot.describe_posterior <- function(x, stack = FALSE, ...) {
insight::check_if_installed("see", "to plot posterior samples")
insight::check_if_installed("ggplot2", "to plot posterior samples")
model <- .retrieve_model(x)
if (!is.null(model)) {
graphics::plot(estimate_density(model), stack = stack, ...) +
ggplot2::labs(title = "Posterior Samples", x = NULL, y = NULL)
} else {
insight::format_alert("Could not find model-object. Try `plot(estimate_density(model))` instead.")
}
}
bayestestR/R/bic_to_bf.R 0000644 0001762 0000144 00000002326 14461433341 014637 0 ustar ligges users #' Convert BIC indices to Bayes Factors via the BIC-approximation method.
#'
#' The difference between two Bayesian information criterion (BIC) indices of
#' two models can be used to approximate Bayes factors via:
#' \cr
#' \deqn{BF_{10} = e^{(BIC_0 - BIC_1)/2}}{BF10 = exp((BIC0-BIC1)/2)}
#'
#' @param bic A vector of BIC values.
#' @param denominator The BIC value to use as a denominator (to test against).
#' @param log If `TRUE`, return the `log(BF)`.
#'
#' @references
#' Wagenmakers, E. J. (2007). A practical solution to the pervasive problems of
#' p values. Psychonomic bulletin & review, 14(5), 779-804
#'
#' @examples
#' bic1 <- BIC(lm(Sepal.Length ~ 1, data = iris))
#' bic2 <- BIC(lm(Sepal.Length ~ Species, data = iris))
#' bic3 <- BIC(lm(Sepal.Length ~ Species + Petal.Length, data = iris))
#' bic4 <- BIC(lm(Sepal.Length ~ Species * Petal.Length, data = iris))
#'
#' bic_to_bf(c(bic1, bic2, bic3, bic4), denominator = bic1)
#' @return The Bayes Factors corresponding to the BIC values against the denominator.
#'
#' @export
bic_to_bf <- function(bic, denominator, log = FALSE) {
delta <- (denominator - bic) / 2
if (log) {
return(delta)
} else {
return(exp(delta))
}
}
bayestestR/R/spi.R 0000644 0001762 0000144 00000033305 14560763455 013541 0 ustar ligges users #' Shortest Probability Interval (SPI)
#'
#' Compute the **Shortest Probability Interval (SPI)** of posterior distributions.
#' The SPI is a more computationally stable HDI. The implementation is based on
#' the algorithm from the **SPIn** package.
#'
#' @inheritParams hdi
#' @inherit ci return
#' @inherit hdi seealso
#' @family ci
#'
#' @note The code to compute the SPI was adapted from the **SPIn** package,
#' and slightly modified to be more robust for Stan models. Thus, credits go
#' to Ying Liu for the original SPI algorithm and R implementation.
#'
#' @details The SPI is an alternative method to the HDI ([hdi()]) to quantify
#' uncertainty of (posterior) distributions. The SPI is said to be more stable
#' than the HDI, because, the _"HDI can be noisy (that is, have a high Monte Carlo error)"_
#' (Liu et al. 2015). Furthermore, the HDI is sensitive to additional assumptions,
#' in particular assumptions related to the different estimation methods, which
#' can make the HDI less accurate or reliable.
#'
#' @references
#' Liu, Y., Gelman, A., & Zheng, T. (2015). Simulation-efficient shortest probability intervals. Statistics and Computing, 25(4), 809–819. https://doi.org/10.1007/s11222-015-9563-8
#'
#' @examplesIf require("quadprog") && require("rstanarm")
#' library(bayestestR)
#'
#' posterior <- rnorm(1000)
#' spi(posterior)
#' spi(posterior, ci = c(0.80, 0.89, 0.95))
#'
#' df <- data.frame(replicate(4, rnorm(100)))
#' spi(df)
#' spi(df, ci = c(0.80, 0.89, 0.95))
#' \donttest{
#' library(rstanarm)
#' model <- suppressWarnings(
#' stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0)
#' )
#' spi(model)
#' }
#'
#' @export
spi <- function(x, ...) {
UseMethod("spi")
}
#' @export
spi.default <- function(x, ...) {
insight::format_error(paste0("'spi()' is not yet implemented for objects of class '", class(x)[1], "'."))
}
#' @rdname spi
#' @export
spi.numeric <- function(x, ci = 0.95, verbose = TRUE, ...) {
out <- do.call(rbind, lapply(ci, function(i) {
.spi(x = x, ci = i, verbose = verbose)
}))
class(out) <- unique(c("bayestestR_hdi", "see_hdi", "bayestestR_ci", "see_ci", "bayestestR_spi", class(out)))
attr(out, "data") <- x
out
}
#' @export
spi.data.frame <- function(x, ci = 0.95, verbose = TRUE, ...) {
dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "spi")
attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
spi.MCMCglmm <- function(x, ci = 0.95, verbose = TRUE, ...) {
hdi(x, ci = ci, verbose = verbose, ci_method = "spi", ...)
}
#' @export
spi.bamlss <- function(x,
ci = 0.95,
component = c("all", "conditional", "location"),
verbose = TRUE,
...) {
component <- match.arg(component)
hdi(x, ci = ci, component = component, verbose = verbose, ci_method = "spi")
}
#' @export
spi.mcmc <- function(x, ci = 0.95, verbose = TRUE, ...) {
hdi(x, ci = ci, verbose = verbose, ci_method = "spi", ...)
}
#' @export
spi.bcplm <- spi.mcmc
#' @export
spi.bayesQR <- spi.mcmc
#' @export
spi.blrm <- spi.mcmc
#' @export
spi.mcmc.list <- spi.mcmc
#' @export
spi.BGGM <- spi.mcmc
#' @export
spi.sim.merMod <- function(x,
ci = 0.95,
effects = c("fixed", "random", "all"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
hdi(x, ci = ci, effects = effects, parameters = parameters, verbose = verbose, ci_method = "spi", ...)
}
#' @export
spi.sim <- function(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) {
hdi(x, ci = ci, parameters = parameters, verbose = verbose, ci_method = "spi", ...)
}
#' @export
spi.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) {
xdf <- insight::get_parameters(x)
out <- spi(xdf, ci = ci, verbose = verbose, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
spi.emm_list <- spi.emmGrid
#' @rdname spi
#' @export
spi.stanreg <- function(x,
ci = 0.95,
effects = c("fixed", "random", "all"),
component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
cleaned_parameters <- insight::clean_parameters(x)
out <- .prepare_output(
spi(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
ci = ci,
verbose = verbose,
...
),
cleaned_parameters,
inherits(x, "stanmvreg")
)
attr(out, "clean_parameters") <- cleaned_parameters
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(out) <- unique(c("bayestestR_hdi", "see_hdi", "bayestestR_spi", class(out)))
out
}
#' @export
spi.stanfit <- spi.stanreg
#' @export
spi.blavaan <- spi.stanreg
#' @rdname spi
#' @export
spi.brmsfit <- function(x,
ci = 0.95,
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
cleaned_parameters <- insight::clean_parameters(x)
out <- .prepare_output(
spi(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
ci = ci,
verbose = verbose,
...
),
cleaned_parameters
)
attr(out, "clean_parameters") <- cleaned_parameters
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(out) <- unique(c("bayestestR_hdi", "see_hdi", "bayestestR_spi", class(out)))
out
}
#' @export
spi.BFBayesFactor <- function(x, ci = 0.95, verbose = TRUE, ...) {
out <- spi(insight::get_parameters(x), ci = ci, verbose = verbose, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @rdname spi
#' @export
spi.get_predicted <- function(x, ci = 0.95, use_iterations = FALSE, verbose = TRUE, ...) {
if (isTRUE(use_iterations)) {
if ("iterations" %in% names(attributes(x))) {
out <- spi(as.data.frame(t(attributes(x)$iterations)), ci = ci, verbose = verbose, ...)
} else {
insight::format_error("No iterations present in the output.")
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
} else {
out <- spi(as.numeric(x), ci = ci, verbose = verbose, ...)
}
out
}
# Helper ------------------------------------------------------------------
# Code taken (and slightly simplified) from:
# SPIn::SPIn()
# Author: Ying Liu yliu@stat.columbia.edu
# Reference: Simulation efficient shortest probability intervals. (arXiv:1302.2142)
# Code licensed under License: GPL (>= 2)
.spi <- function(x, ci, verbose = TRUE) {
insight::check_if_installed("quadprog")
check_ci <- .check_ci_argument(x, ci, verbose)
if (!is.null(check_ci)) {
return(check_ci)
}
dens <- stats::density(x)
n.sims <- length(x)
conf <- 1 - ci
nn <- round(n.sims * conf)
# validation check for very low CI levels
if (nn >= n.sims) {
nn <- n.sims <- 1
}
x <- sort(x)
xx <- x[(n.sims - nn):n.sims] - x[1:(nn + 1)]
m <- min(xx)
k <- which(xx == m)[1]
l <- x[k]
ui <- n.sims - nn + k - 1
u <- x[ui]
bw <- round((sqrt(n.sims) - 1) / 2)
k <- which(x == l)[1]
ui <- which(x == u)[1]
# lower bound
if (!anyNA(k) && all(k == 1)) {
x.l <- l
} else {
x.l <- .safe(.spi_lower(bw = bw, n.sims = n.sims, k = k, l = l, dens = dens, x = x))
frac <- 1
while (is.null(x.l)) {
frac <- frac - 0.1
x.l <- .safe(.spi_lower(bw = frac * bw, n.sims = n.sims, k = k, l = l, dens = dens, x = x))
if (frac <= 0.1) {
insight::format_alert("Could not find a solution for the SPI lower bound.")
x.l <- NA
}
}
}
# upper bound
if (!anyNA(ui) && all(ui == n.sims)) {
x.u <- u
} else {
x.u <- .safe(.spi_upper(bw = bw, n.sims = n.sims, ui = ui, u = u, dens = dens, x = x))
frac <- 1
while (is.null(x.u)) {
frac <- frac - 0.1
x.u <- .safe(.spi_upper(bw = frac * bw, n.sims = n.sims, ui = ui, u = u, dens = dens, x = x))
if (frac <= 0.1) {
insight::format_alert("Could not find a solution for the SPI upper bound.")
x.u <- NA
}
}
}
# output
data.frame(
"CI" = ci,
"CI_low" = x.l,
"CI_high" = x.u
)
}
.spi_lower <- function(bw, n.sims, k, l, dens, x) {
l.l <- max(1, k - bw)
l.u <- k + (k - l.l)
range_ll_lu <- l.u - l.l
range_ll_k <- k - l.l
n.l <- range_ll_lu + 1
D.l <- matrix(nrow = n.l, ncol = n.l)
# create quadratic function
p <- (l.l:l.u) / (n.sims + 1)
q <- 1 - p
Q <- stats::quantile(x, p)
d.q <- rep(0, n.l)
for (r in 1:n.l) {
d.q[r] <- dens$y[which.min(abs(dens$x - Q[r]))]
}
Q. <- 1 / d.q
diag(D.l) <- 2 * (Q^2 + p * q * Q.^2 / (n.sims + 2))
d.l <- 2 * Q * l
if (n.l > 1) {
for (j in 1:(n.l - 1)) {
for (m in (j + 1):n.l) {
D.l[j, m] <- Q.[j] * Q.[m] * p[j] * q[m] * 2 / (n.sims + 2) + Q[j] * Q[m] * 2
D.l[m, j] <- D.l[j, m]
}
}
}
# create constraint matrix
A.l <- matrix(0, nrow = range_ll_lu + 3, ncol = range_ll_lu + 1)
A.l[1, ] <- 1
if (bw > 1 && k > 2) {
for (j in 1:(range_ll_k - 1)) {
if (x[l.l + j + 1] == x[l.l + j]) {
A.l[1 + j, j + 1] <- 1
A.l[1 + j, j + 2] <- -1
} else {
aa <- (x[l.l + j] - x[l.l + j - 1]) / (x[l.l + j + 1] - x[l.l + j])
A.l[1 + j, j] <- 1
A.l[1 + j, j + 1] <- -(aa + 1)
A.l[1 + j, j + 2] <- aa
}
}
for (j in 0:(l.u - k - 2)) {
if (x[k + j + 1] == x[k + j + 2]) {
A.l[range_ll_k + 1 + j, range_ll_k + 2 + j] <- 1
A.l[range_ll_k + 1 + j, range_ll_k + 3 + j] <- -1
} else {
aa <- (x[k + j] - x[k + j + 1]) / (x[k + j + 1] - x[k + j + 2])
A.l[range_ll_k + 1 + j, range_ll_k + 1 + j] <- -1
A.l[range_ll_k + 1 + j, range_ll_k + 2 + j] <- aa + 1
A.l[range_ll_k + 1 + j, range_ll_k + 3 + j] <- -aa
}
}
}
if (x[k + 1] == x[k]) {
aa <- (x[k] - x[k - 1]) / (x[k + 1] - x[k] + 0.000001)
} else {
aa <- (x[k] - x[k - 1]) / (x[k + 1] - x[k])
}
A.l[range_ll_lu, range_ll_k + 1] <- aa - 1
A.l[range_ll_lu, range_ll_k] <- 1
A.l[range_ll_lu, range_ll_k + 2] <- -aa
A.l[range_ll_lu + 1, range_ll_lu] <- 1
A.l[range_ll_lu + 1, range_ll_lu + 1] <- -1
A.l[range_ll_lu + 2, 1] <- 1
A.l[range_ll_lu + 3, range_ll_lu + 1] <- 1
A.l <- t(A.l)
w.l <- quadprog::solve.QP(D.l, d.l, A.l, c(1, rep(0, range_ll_lu + 2)), range_ll_lu)
x.l <- w.l$solution %*% x[l.l:l.u]
return(x.l)
}
.spi_upper <- function(bw, n.sims, ui, u, dens, x) {
u.u <- min(n.sims, ui + bw)
u.l <- ui - (u.u - ui)
range_ul_uu <- u.u - u.l
range_ul_ui <- ui - u.l
n.u <- range_ul_uu + 1
D.u <- matrix(nrow = n.u, ncol = n.u)
# create quadratic function
p <- (u.l:u.u) / (n.sims + 1)
q <- 1 - p
Q <- stats::quantile(x, p)
d.q <- rep(0, n.u)
for (r in 1:n.u) {
d.q[r] <- dens$y[which.min(abs(dens$x - Q[r]))]
}
Q. <- 1 / d.q
diag(D.u) <- 2 * (Q^2 + p * q * Q.^2 / (n.sims + 2))
d.u <- 2 * Q * u
if (n.u > 1) {
for (j in 1:(n.u - 1)) {
for (m in (j + 1):n.u) {
D.u[j, m] <- Q.[j] * Q.[m] * p[j] * q[m] * 2 / (n.sims + 2) + Q[j] * Q[m] * 2
D.u[m, j] <- D.u[j, m]
}
}
}
# create constraint matrix
A.u <- matrix(0, nrow = range_ul_uu + 3, ncol = range_ul_uu + 1)
A.u[1, ] <- 1
if (bw > 1 && range_ul_ui > 1) {
for (j in 1:(range_ul_ui - 1)) {
if (x[u.l + j + 1] == x[u.l + j]) {
A.u[1 + j, j + 1] <- 1
A.u[1 + j, j + 2] <- -1
} else {
aa <- (x[u.l + j] - x[u.l + j - 1]) / (x[u.l + j + 1] - x[u.l + j])
A.u[1 + j, j] <- 1
A.u[1 + j, j + 1] <- -(aa + 1)
A.u[1 + j, j + 2] <- aa
}
}
i <- 0
for (j in (range_ul_ui):(range_ul_uu - 2)) {
if (x[ui + i + 1] == x[ui + i + 2]) {
A.u[1 + j, j + 2] <- 1
A.u[1 + j, j + 3] <- -1
} else {
aa <- (x[ui + i] - x[ui + i + 1]) / (x[ui + i + 1] - x[ui + i + 2])
A.u[1 + j, j + 1] <- -1
A.u[1 + j, j + 2] <- aa + 1
A.u[1 + j, j + 3] <- -aa
}
i <- i + 1
}
}
if (x[ui + 1] == x[ui]) {
aa <- (x[ui] - x[ui - 1]) / (x[ui + 2] - x[ui])
A.u[range_ul_uu, range_ul_ui] <- 1
A.u[range_ul_uu, range_ul_ui + 1] <- aa - 1
A.u[range_ul_uu, range_ul_ui + 3] <- -aa
} else {
aa <- (x[ui] - x[ui - 1]) / (x[ui + 1] - x[ui])
A.u[range_ul_uu, range_ul_ui] <- 1
A.u[range_ul_uu, range_ul_ui + 1] <- aa - 1
A.u[range_ul_uu, range_ul_ui + 2] <- -aa
}
A.u[range_ul_uu + 1, range_ul_uu] <- 1
A.u[range_ul_uu + 1, range_ul_uu + 1] <- -1
A.u[range_ul_uu + 2, 1] <- 1
A.u[range_ul_uu + 3, range_ul_uu + 1] <- 1
A.u <- t(A.u)
w.u <- quadprog::solve.QP(D.u, d.u, A.u, c(1, rep(0, range_ul_uu + 2)), range_ul_uu)
x.u <- w.u$solution %*% x[u.l:u.u]
return(x.u)
}
bayestestR/R/p_direction.R 0000644 0001762 0000144 00000042330 14561246646 015242 0 ustar ligges users #' Probability of Direction (pd)
#'
#' Compute the **Probability of Direction** (***pd***, also known as the Maximum
#' Probability of Effect - *MPE*). This can be interpreted as the probability
#' that a parameter (described by its posterior distribution) is strictly
#' positive or negative (whichever is the most probable). Although differently
#' expressed, this index is fairly similar (*i.e.*, is strongly correlated) to
#' the frequentist **p-value** (see details).
#'
#' @param x A vector representing a posterior distribution, a data frame of
#' posterior draws (samples be parameter). Can also be a Bayesian model.
#' @param method Can be `"direct"` or one of methods of [`estimate_density()`],
#' such as `"kernel"`, `"logspline"` or `"KernSmooth"`. See details.
#' @param null The value considered as a "null" effect. Traditionally 0, but
#' could also be 1 in the case of ratios of change (OR, IRR, ...).
#' @inheritParams hdi
#'
#' @details
#' ## What is the *pd*?
#' The Probability of Direction (pd) is an index of effect existence, representing
#' the certainty with which an effect goes in a particular direction (i.e., is
#' positive or negative / has a sign), typically ranging from 0.5 to 1 (but see
#' next section for cases where it can range between 0 and 1). Beyond
#' its simplicity of interpretation, understanding and computation, this index
#' also presents other interesting properties:
#' - Like other posterior-based indices, *pd* is solely based on the posterior
#' distributions and does not require any additional information from the data
#' or the model (e.g., such as priors, as in the case of Bayes factors).
#' - It is robust to the scale of both the response variable and the predictors.
#' - It is strongly correlated with the frequentist p-value, and can thus
#' be used to draw parallels and give some reference to readers non-familiar
#' with Bayesian statistics (Makowski et al., 2019).
#'
#' ## Relationship with the p-value
#' In most cases, it seems that the *pd* has a direct correspondence with the
#' frequentist one-sided *p*-value through the formula (for two-sided *p*):
#' \deqn{p = 2 \times (1 - p_d)}{p = 2 * (1 - pd)}
#' Thus, a two-sided p-value of respectively `.1`, `.05`, `.01` and `.001` would
#' correspond approximately to a *pd* of `95%`, `97.5%`, `99.5%` and `99.95%`.
#' See [pd_to_p()] for details.
#'
#' ## Possible Range of Values
#' The largest value *pd* can take is 1 - the posterior is strictly directional.
#' However, the smallest value *pd* can take depends on the parameter space
#' represented by the posterior.
#' \cr\cr
#' **For a continuous parameter space**, exact values of 0 (or any point null
#' value) are not possible, and so 100% of the posterior has _some_ sign, some
#' positive, some negative. Therefore, the smallest the *pd* can be is 0.5 -
#' with an equal posterior mass of positive and negative values. Values close to
#' 0.5 _cannot_ be used to support the null hypothesis (that the parameter does
#' _not_ have a direction) is a similar why to how large p-values cannot be used
#' to support the null hypothesis (see [`pd_to_p()`]; Makowski et al., 2019).
#' \cr\cr
#' **For a discrete parameter space or a parameter space that is a mixture
#' between discrete and continuous spaces**, exact values of 0 (or any point
#' null value) _are_ possible! Therefore, the smallest the *pd* can be is 0 -
#' with 100% of the posterior mass on 0. Thus values close to 0 can be used to
#' support the null hypothesis (see van den Bergh et al., 2021).
#' \cr\cr
#' Examples of posteriors representing discrete parameter space:
#' - When a parameter can only take discrete values.
#' - When a mixture prior/posterior is used (such as the spike-and-slab prior;
#' see van den Bergh et al., 2021).
#' - When conducting Bayesian model averaging (e.g., [weighted_posteriors()] or
#' `brms::posterior_average`).
#'
#' ## Methods of computation
#' The *pd* is defined as:
#' \deqn{p_d = max({Pr(\hat{\theta} < \theta_{null}), Pr(\hat{\theta} > \theta_{null})})}{pd = max(mean(x < null), mean(x > null))}
#' \cr\cr
#' The most simple and direct way to compute the *pd* is to compute the
#' proportion of positive (or larger than `null`) posterior samples, the
#' proportion of negative (or smaller than `null`) posterior samples, and take
#' the larger of the two. This "simple" method is the most straightforward, but
#' its precision is directly tied to the number of posterior draws.
#' \cr\cr
#' The second approach relies on [density estimation][estimate_density]: It starts by
#' estimating the continuous-smooth density function (for which many methods are
#' available), and then computing the [area under the curve][area_under_curve]
#' (AUC) of the density curve on either side of `null` and taking the maximum
#' between them. Note the this approach assumes a continuous density function,
#' and so **when the posterior represents a (partially) discrete parameter
#' space, only the direct method _must_ be used** (see above).
#'
#' @return
#' Values between 0.5 and 1 *or* between 0 and 1 (see above) corresponding to
#' the probability of direction (pd).
#'
#' @seealso [pd_to_p()] to convert between Probability of Direction (pd) and p-value.
#'
#' @note There is also a [`plot()`-method](https://easystats.github.io/see/articles/bayestestR.html) implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}.
#'
#' @references
#' - Makowski, D., Ben-Shachar, M. S., Chen, S. A., & Lüdecke, D. (2019).
#' Indices of effect existence and significance in the Bayesian framework.
#' Frontiers in psychology, 10, 2767. \doi{10.3389/fpsyg.2019.02767}
#' - van den Bergh, D., Haaf, J. M., Ly, A., Rouder, J. N., & Wagenmakers, E. J.
#' (2021). A cautionary note on estimating effect size. Advances in Methods
#' and Practices in Psychological Science, 4(1). \doi{10.1177/2515245921992035}
#'
#' @examples
#' library(bayestestR)
#'
#' # Simulate a posterior distribution of mean 1 and SD 1
#' # ----------------------------------------------------
#' posterior <- rnorm(1000, mean = 1, sd = 1)
#' p_direction(posterior)
#' p_direction(posterior, method = "kernel")
#'
#' # Simulate a dataframe of posterior distributions
#' # -----------------------------------------------
#' df <- data.frame(replicate(4, rnorm(100)))
#' p_direction(df)
#' p_direction(df, method = "kernel")
#' \donttest{
#' # rstanarm models
#' # -----------------------------------------------
#' if (require("rstanarm")) {
#' model <- rstanarm::stan_glm(mpg ~ wt + cyl,
#' data = mtcars,
#' chains = 2, refresh = 0
#' )
#' p_direction(model)
#' p_direction(model, method = "kernel")
#' }
#'
#' # emmeans
#' # -----------------------------------------------
#' if (require("emmeans")) {
#' p_direction(emtrends(model, ~1, "wt", data = mtcars))
#' }
#'
#' # brms models
#' # -----------------------------------------------
#' if (require("brms")) {
#' model <- brms::brm(mpg ~ wt + cyl, data = mtcars)
#' p_direction(model)
#' p_direction(model, method = "kernel")
#' }
#'
#' # BayesFactor objects
#' # -----------------------------------------------
#' if (require("BayesFactor")) {
#' bf <- ttestBF(x = rnorm(100, 1, 1))
#' p_direction(bf)
#' p_direction(bf, method = "kernel")
#' }
#' }
#' @export
p_direction <- function(x, ...) {
UseMethod("p_direction")
}
#' @rdname p_direction
#' @export
pd <- p_direction
#' @export
p_direction.default <- function(x, ...) {
insight::format_error(paste0("'p_direction()' is not yet implemented for objects of class '", class(x)[1], "'."))
}
#' @rdname p_direction
#' @export
p_direction.numeric <- function(x, method = "direct", null = 0, ...) {
obj_name <- insight::safe_deparse_symbol(substitute(x))
out <- p_direction(data.frame(Posterior = x), method = method, null = null, ...)
attr(out, "object_name") <- obj_name
out
}
#' @rdname p_direction
#' @export
p_direction.data.frame <- function(x, method = "direct", null = 0, ...) {
obj_name <- insight::safe_deparse_symbol(substitute(x))
x <- .select_nums(x)
if (ncol(x) == 1) {
pd <- .p_direction(x[[1]], method = method, null = null, ...)
} else {
pd <- sapply(x, .p_direction, method = method, null = null, simplify = TRUE, ...)
}
out <- data.frame(
Parameter = names(x),
pd = pd,
row.names = NULL,
stringsAsFactors = FALSE
)
attr(out, "object_name") <- obj_name
class(out) <- unique(c("p_direction", "see_p_direction", class(out)))
out
}
#' @export
p_direction.draws <- function(x, method = "direct", null = 0, ...) {
p_direction(.posterior_draws_to_df(x), method = method, null = null, ...)
}
#' @export
p_direction.rvar <- p_direction.draws
#' @rdname p_direction
#' @export
p_direction.MCMCglmm <- function(x, method = "direct", null = 0, ...) {
nF <- x$Fixed$nfl
out <- p_direction(as.data.frame(x$Sol[, 1:nF, drop = FALSE]),
method = method,
null = null,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_direction.mcmc <- function(x, method = "direct", null = 0, ...) {
p_direction(as.data.frame(x), method = method, null = null, ...)
}
#' @export
p_direction.BGGM <- function(x, method = "direct", null = 0, ...) {
p_direction(as.data.frame(x), method = method, null = null, ...)
}
#' @export
p_direction.bcplm <- function(x, method = "direct", null = 0, ...) {
p_direction(insight::get_parameters(x), method = method, null = null, ...)
}
#' @export
p_direction.mcmc.list <- p_direction.bcplm
#' @export
p_direction.blrm <- p_direction.bcplm
#' @export
p_direction.bayesQR <- p_direction.bcplm
#' @export
p_direction.bamlss <- function(x,
method = "direct",
null = 0,
component = c("all", "conditional", "location"),
...) {
component <- match.arg(component)
out <- p_direction(
insight::get_parameters(x, component = component),
method = method,
null = null,
...
)
out <- .add_clean_parameters_attribute(out, x)
out
}
#' @rdname p_direction
#' @export
p_direction.emmGrid <- function(x, method = "direct", null = 0, ...) {
xdf <- insight::get_parameters(x)
out <- p_direction(xdf, method = method, null = null, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_direction.emm_list <- p_direction.emmGrid
#' @keywords internal
.p_direction_models <- function(x,
effects,
component,
parameters,
method = "direct",
null = 0,
...) {
p_direction(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
method = method,
null = null,
...
)
}
#' @export
p_direction.sim.merMod <- function(x,
effects = c("fixed", "random", "all"),
parameters = NULL,
method = "direct",
null = 0,
...) {
effects <- match.arg(effects)
out <- .p_direction_models(
x = x,
effects = effects,
component = "conditional",
parameters = parameters,
method = method,
null = null,
...
)
attr(out, "data") <- insight::get_parameters(x, effects = effects, parameters = parameters)
out
}
#' @export
p_direction.sim <- function(x,
parameters = NULL,
method = "direct",
null = 0,
...) {
out <- .p_direction_models(
x = x,
effects = "fixed",
component = "conditional",
parameters = parameters,
method = method,
null = null,
...
)
attr(out, "data") <- insight::get_parameters(x, parameters = parameters)
out
}
#' @rdname p_direction
#' @export
p_direction.stanreg <- function(x,
effects = c("fixed", "random", "all"),
component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"),
parameters = NULL,
method = "direct",
null = 0,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
cleaned_parameters <- insight::clean_parameters(x)
out <- .prepare_output(
p_direction(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
method = method,
null = null,
...
),
cleaned_parameters,
inherits(x, "stanmvreg")
)
attr(out, "clean_parameters") <- cleaned_parameters
class(out) <- unique(c("p_direction", "see_p_direction", class(out)))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_direction.stanfit <- p_direction.stanreg
#' @export
p_direction.blavaan <- p_direction.stanreg
#' @rdname p_direction
#' @export
p_direction.brmsfit <- function(x,
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
method = "direct",
null = 0,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
cleaned_parameters <- insight::clean_parameters(x)
out <- .prepare_output(
p_direction(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
method = method,
null = null,
...
),
cleaned_parameters
)
attr(out, "clean_parameters") <- cleaned_parameters
class(out) <- unique(c("p_direction", "see_p_direction", class(out)))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @rdname p_direction
#' @export
p_direction.BFBayesFactor <- function(x, method = "direct", null = 0, ...) {
out <- p_direction(insight::get_parameters(x), method = method, null = null, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @rdname p_direction
#' @export
p_direction.get_predicted <- function(x,
method = "direct",
null = 0,
use_iterations = FALSE,
verbose = TRUE,
...) {
if (isTRUE(use_iterations)) {
if ("iterations" %in% names(attributes(x))) {
out <- p_direction(
as.data.frame(t(attributes(x)$iterations)),
method = method,
null = null,
verbose = verbose,
...
)
} else {
insight::format_error("No iterations present in the output.")
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
} else {
out <- p_direction(as.numeric(x),
method = method,
null = null,
verbose = verbose,
...
)
}
out
}
#' @export
p_direction.parameters_model <- function(x, ...) {
out <- data.frame(
"Parameter" = x$Parameter,
"pd" = p_to_pd(p = x[["p"]]),
row.names = NULL,
stringsAsFactors = FALSE
)
if (!is.null(x$Component)) {
out$Component <- x$Component
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(out) <- unique(c("p_direction", "see_p_direction", class(out)))
out
}
# Definition --------------------------------------------------------------
#' @keywords internal
.p_direction <- function(x, method = "direct", null = 0, ...) {
if (method == "direct") {
pdir <- max(
length(x[x > null]), # pd positive
length(x[x < null]) # pd negative
) / length(x)
} else {
dens <- estimate_density(x, method = method, precision = 2^10, extend = TRUE, ...)
if (length(x[x > null]) > length(x[x < null])) {
dens <- dens[dens$x > null, ]
} else {
dens <- dens[dens$x < null, ]
}
pdir <- area_under_curve(dens$x, dens$y, method = "spline")
if (pdir >= 1) {
# Enforce bounds
pdir <- 1
}
}
pdir
}
# Methods -----------------------------------------------------------------
#' Convert to Numeric
#'
#' @inheritParams base::as.numeric
#' @method as.numeric p_direction
#' @export
as.numeric.p_direction <- function(x, ...) {
if (inherits(x, "data.frame")) {
return(as.numeric(as.vector(x$pd)))
} else {
return(as.vector(x))
}
}
#' @method as.double p_direction
#' @export
as.double.p_direction <- as.numeric.p_direction
bayestestR/R/cwi.R 0000644 0001762 0000144 00000005412 14407021360 013504 0 ustar ligges users #' Curvewise Intervals (CWI)
#'
#' Compute the **Curvewise interval (CWI)** (also called the "simultaneous interval" or "joint interval") of posterior distributions using \code{ggdist::curve_interval()}.
#' Whereas the more typical "pointwise intervals" contain xx% of the posterior for a single parameter,
#' joint/curvewise intervals contain xx% of the posterior distribution for **all** parameters.
#'
#' Applied model predictions, pointwise intervals contain xx% of the predicted response values **conditional** on specific predictor values.
#' In contrast, curvewise intervals contain xx% of the predicted response values across all predictor values.
#' Put another way, curvewise intervals contain xx% of the full **prediction lines** from the model.
#'
#' For more details, see the [*ggdist* documentation on curvewise intervals](https://mjskay.github.io/ggdist/articles/lineribbon.html#curve-boxplots-aka-lineribbons-with-joint-intervals-or-curvewise-intervals-).
#'
#' @inheritParams hdi
#' @inherit ci return
#' @inherit hdi details
#' @inherit hdi seealso
#' @family ci
#'
#' @examples
#' \donttest{
#' library(bayestestR)
#'
#' if (require("ggplot2") && require("rstanarm") && require("ggdist")) {
#' # Generate data =============================================
#' k <- 11 # number of curves (iterations)
#' n <- 201 # number of rows
#' data <- data.frame(x = seq(-15, 15, length.out = n))
#'
#' # Simulate iterations as new columns
#' for (i in 1:k) {
#' data[paste0("iter_", i)] <- dnorm(data$x, seq(-5, 5, length.out = k)[i], 3)
#' }
#'
#' # Note: first, we need to transpose the data to have iters as rows
#' iters <- datawizard::data_transpose(data[paste0("iter_", 1:k)])
#'
#' # Compute Median
#' data$Median <- point_estimate(iters)[["Median"]]
#'
#' # Compute Credible Intervals ================================
#'
#' # Compute ETI (default type of CI)
#' data[c("ETI_low", "ETI_high")] <- eti(iters, ci = 0.5)[c("CI_low", "CI_high")]
#'
#' # Compute CWI
#' # ggdist::curve_interval(reshape_iterations(data), iter_value .width = 0.5)
#'
#' # Visualization =============================================
#' ggplot(data, aes(x = x, y = Median)) +
#' geom_ribbon(aes(ymin = ETI_low, ymax = ETI_high), fill = "red", alpha = 0.3) +
#' geom_line(linewidth = 1) +
#' geom_line(
#' data = reshape_iterations(data),
#' aes(y = iter_value, group = iter_group),
#' alpha = 0.3
#' )
#' }
#' }
#' @export
cwi <- function(x, ...) {
UseMethod("cwi")
}
#' @rdname cwi
#' @export
cwi.data.frame <- function(x, ci = 0.95, ...) {
insight::check_if_installed("ggdist")
print("Comming soon!") # @DominiqueMakowski GitBlame says this was 2 years ago - when is "soon"? :-)
}
bayestestR/R/bci.R 0000644 0001762 0000144 00000017175 14560763455 013512 0 ustar ligges users #' Bias Corrected and Accelerated Interval (BCa)
#'
#' Compute the **Bias Corrected and Accelerated Interval (BCa)** of posterior
#' distributions.
#'
#' @inheritParams hdi
#' @inherit ci return
#' @inherit hdi details
#' @inherit hdi seealso
#' @family ci
#'
#' @references
#' DiCiccio, T. J. and B. Efron. (1996). Bootstrap Confidence Intervals.
#' Statistical Science. 11(3): 189–212. 10.1214/ss/1032280214
#'
#' @examples
#' posterior <- rnorm(1000)
#' bci(posterior)
#' bci(posterior, ci = c(0.80, 0.89, 0.95))
#' @export
bci <- function(x, ...) {
UseMethod("bci")
}
#' @rdname bci
#' @export
bcai <- bci
#' @rdname bci
#' @export
bci.numeric <- function(x, ci = 0.95, verbose = TRUE, ...) {
out <- do.call(rbind, lapply(ci, function(i) {
.bci(x = x, ci = i, verbose = verbose)
}))
class(out) <- unique(c("bayestestR_eti", "see_eti", "bayestestR_ci", "see_ci", class(out)))
attr(out, "data") <- x
out
}
#' @rdname bci
#' @export
bci.data.frame <- function(x, ci = 0.95, verbose = TRUE, ...) {
dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "bci")
attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
bci.draws <- function(x, ci = 0.95, verbose = TRUE, ...) {
dat <- .compute_interval_dataframe(x = .posterior_draws_to_df(x), ci = ci, verbose = verbose, fun = "bci")
attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
bci.rvar <- bci.draws
#' @rdname bci
#' @export
bci.MCMCglmm <- function(x, ci = 0.95, verbose = TRUE, ...) {
nF <- x$Fixed$nfl
d <- as.data.frame(x$Sol[, 1:nF, drop = FALSE])
dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = "bci")
attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
bci.mcmc <- function(x, ci = 0.95, verbose = TRUE, ...) {
d <- as.data.frame(x)
dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = "bci")
attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
bci.bamlss <- function(x,
ci = 0.95,
component = c("all", "conditional", "location"),
verbose = TRUE,
...) {
component <- match.arg(component)
d <- insight::get_parameters(x, component = component)
dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = "bci")
attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
bci.bcplm <- function(x, ci = 0.95, verbose = TRUE, ...) {
d <- insight::get_parameters(x)
dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = "bci")
attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
bci.bayesQR <- bci.bcplm
#' @export
bci.blrm <- bci.bcplm
#' @export
bci.mcmc.list <- bci.bcplm
#' @export
bci.BGGM <- bci.bcplm
#' @rdname bci
#' @export
bci.sim.merMod <- function(x,
ci = 0.95,
effects = c("fixed", "random", "all"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
dat <- .compute_interval_simMerMod(
x = x,
ci = ci,
effects = effects,
parameters = parameters,
verbose = verbose,
fun = "bci"
)
out <- dat$result
attr(out, "data") <- dat$data
out
}
#' @rdname bci
#' @export
bci.sim <- function(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) {
dat <- .compute_interval_sim(
x = x,
ci = ci,
parameters = parameters,
verbose = verbose,
fun = "bci"
)
out <- dat$result
attr(out, "data") <- dat$data
out
}
#' @rdname bci
#' @export
bci.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) {
xdf <- insight::get_parameters(x)
dat <- bci(xdf, ci = ci, verbose = verbose, ...)
attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
bci.emm_list <- bci.emmGrid
#' @rdname bci
#' @export
bci.stanreg <- function(x,
ci = 0.95,
effects = c("fixed", "random", "all"),
component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
out <- .prepare_output(
bci(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
ci = ci,
verbose = verbose,
...
),
insight::clean_parameters(x),
inherits(x, "stanmvreg")
)
class(out) <- unique(c("bayestestR_eti", "see_eti", class(out)))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
bci.stanfit <- bci.stanreg
#' @export
bci.blavaan <- bci.stanreg
#' @rdname bci
#' @export
bci.brmsfit <- function(x, ci = 0.95, effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL, verbose = TRUE, ...) {
effects <- match.arg(effects)
component <- match.arg(component)
out <- .prepare_output(
bci(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
ci = ci,
verbose = verbose,
...
),
insight::clean_parameters(x)
)
class(out) <- unique(c("bayestestR_eti", "see_eti", class(out)))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @rdname bci
#' @export
bci.BFBayesFactor <- function(x, ci = 0.95, verbose = TRUE, ...) {
out <- bci(insight::get_parameters(x), ci = ci, verbose = verbose, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @rdname bci
#' @export
bci.get_predicted <- function(x, ci = 0.95, use_iterations = FALSE, verbose = TRUE, ...) {
if (isTRUE(use_iterations)) {
if ("iterations" %in% names(attributes(x))) {
out <- bci(as.data.frame(t(attributes(x)$iterations)), ci = ci, verbose = verbose, ...)
} else {
insight::format_error("No iterations present in the output.")
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
} else {
out <- bci(as.numeric(x), ci = ci, verbose = verbose, ...)
}
out
}
# Helper ------------------------------------------------------------------
.bci <- function(x, ci, verbose = TRUE) {
check_ci <- .check_ci_argument(x, ci, verbose)
if (!is.null(check_ci)) {
return(check_ci)
}
low <- (1 - ci) / 2
high <- 1 - low
sims <- length(x)
z.inv <- length(x[x < mean(x, na.rm = TRUE)]) / sims
z <- stats::qnorm(z.inv)
U <- (sims - 1) * (mean(x, na.rm = TRUE) - x)
top <- sum(U^3)
under <- 6 * (sum(U^2))^1.5
a <- top / under
lower.inv <- stats::pnorm(z + (z + stats::qnorm(low)) / (1 - a * (z + stats::qnorm(low))))
lower <- stats::quantile(x, lower.inv, names = FALSE, na.rm = TRUE)
upper.inv <- stats::pnorm(z + (z + stats::qnorm(high)) / (1 - a * (z + stats::qnorm(high))))
upper <- stats::quantile(x, upper.inv, names = FALSE, na.rm = TRUE)
data.frame(
"CI" = ci,
"CI_low" = lower,
"CI_high" = upper
)
}
bayestestR/R/print.R 0000644 0001762 0000144 00000015657 14461433341 014100 0 ustar ligges users #' @export
print.describe_posterior <- function(x,
digits = 2,
caption = "Summary of Posterior Distribution",
...) {
.print_default(
x = x,
digits = digits,
caption = caption,
...
)
}
#' @export
print.point_estimate <- function(x,
digits = 2,
caption = "Point Estimate",
...) {
.print_default(
x = x,
digits = digits,
caption = caption,
...
)
}
#' @export
print.p_direction <- function(x,
digits = 2,
caption = "Probability of Direction",
...) {
.print_default(
x = x,
digits = digits,
caption = caption,
...
)
}
#' @export
print.p_map <- function(x,
digits = 2,
caption = "MAP-based p-value",
...) {
.print_default(
x = x,
digits = digits,
caption = caption,
...
)
}
#' @export
print.map_estimate <- function(x,
digits = 2,
caption = "MAP Estimate",
...) {
.print_default(
x = x,
digits = digits,
caption = caption,
...
)
}
#' @export
print.p_rope <- function(x, digits = 2, ...) {
caption <- sprintf(
"Proportion of samples inside the ROPE [%.*f, %.*f]",
digits,
x$ROPE_low[1],
digits,
x$ROPE_high[1]
)
x$ROPE_low <- x$ROPE_high <- NULL
.print_default(
x = x,
digits = digits,
caption = caption,
ci_string = "ROPE",
...
)
}
#' @export
print.p_significance <- function(x, digits = 2, ...) {
caption <- sprintf(
"Practical Significance (threshold: %s)",
insight::format_value(attributes(x)$threshold, digits = digits)
)
.print_default(
x = x,
digits = digits,
caption = caption,
...
)
}
#' @export
print.bayestestR_hdi <- function(x,
digits = 2,
caption = "Highest Density Interval",
...) {
ci_string <- "HDI"
if (inherits(x, "bayestestR_spi")) {
caption <- "Shortest Probability Interval"
ci_string <- "SPI"
}
.print_default(
x = x,
digits = digits,
caption = caption,
ci_string = ci_string,
...
)
}
#' @export
print.bayestestR_eti <- function(x,
digits = 2,
caption = "Equal-Tailed Interval",
...) {
.print_default(
x = x,
digits = digits,
caption = caption,
ci_string = "ETI",
...
)
}
#' @export
print.bayestestR_si <- function(x,
digits = 2,
caption = "Support Interval",
...) {
.print_default(
x = x,
digits = digits,
caption = caption,
ci_string = "SI",
...
)
}
# special handling for bayes factors ------------------
#' @export
print.bayesfactor_models <- function(x,
digits = 3,
log = FALSE,
show_names = TRUE,
caption = "Bayes Factors for Model Comparison",
...) {
show_names <- show_names & !attr(x, "unsupported_models")
.print_bf_default(
x = x,
digits = digits,
log = log,
show_names = show_names,
caption = caption,
align = "llr",
...
)
}
#' @export
print.bayesfactor_inclusion <- function(x,
digits = 3,
log = FALSE,
caption = "Inclusion Bayes Factors (Model Averaged)",
...) {
.print_bf_default(
x = x,
digits = digits,
log = log,
caption = caption,
...
)
}
#' @export
print.bayesfactor_restricted <- function(x,
digits = 3,
log = FALSE,
caption = "Bayes Factor (Order-Restriction)",
...) {
.print_bf_default(
x = x,
digits = digits,
log = log,
caption = caption,
...
)
}
#' @export
print.bayesfactor_parameters <- function(x, digits = 3, log = FALSE, ...) {
# retrieve information with cleaned parameter names
cp <- attr(x, "clean_parameters")
# format data frame and columns
formatted_table <- format(
x,
cp = cp,
digits = digits,
log = log,
format = "text",
...
)
cat(insight::export_table(formatted_table, format = "text"))
invisible(x)
}
# util ---------------------
.print_default <- function(x,
digits = 2,
caption = NULL,
subtitles = NULL,
ci_string = "CI",
...) {
# retrieve information with cleaned parameter names
cp <- attr(x, "clean_parameters")
# format data frame and columns
formatted_table <- format(
x,
cp = cp,
digits = digits,
format = "text",
ci_string = ci_string,
caption = caption,
subtitles = subtitles,
...
)
# check if we have a 1x1 data frame (i.e. a numeric input)
if (is.data.frame(formatted_table) && nrow(formatted_table) == 1 && ncol(formatted_table) == 1) {
# print for numeric
caption <- attr(formatted_table, "table_caption")
# if we have no useful column name and a caption, use caption
if (!is.null(caption) && !endsWith(colnames(formatted_table), ci_string)) {
cat(paste0(caption, ": "))
} else {
cat(paste0(colnames(formatted_table), ": "))
}
cat(formatted_table[1, 1])
cat("\n")
} else {
# print for data frame
cat(insight::export_table(
formatted_table,
caption = caption
))
}
invisible(x)
}
.print_bf_default <- function(x,
digits = 3,
log = FALSE,
caption = NULL,
align = NULL,
...) {
# format data frame and columns
formatted_table <- format(
x,
digits = digits,
log = log,
format = "text",
caption = caption,
... # pass show_names
)
cat(insight::export_table(
formatted_table,
sep = " ",
header = NULL,
format = "text",
align = align,
))
invisible(x)
}
bayestestR/R/check_prior.R 0000644 0001762 0000144 00000015667 14650172354 015241 0 ustar ligges users #' Check if Prior is Informative
#'
#' Performs a simple test to check whether the prior is informative to the
#' posterior. This idea, and the accompanying heuristics, were discussed in
#' _Gelman et al. 2017_.
#'
#' @param method Can be `"gelman"` or `"lakeland"`. For the
#' `"gelman"` method, if the SD of the posterior is more than 0.1 times
#' the SD of the prior, then the prior is considered as informative. For the
#' `"lakeland"` method, the prior is considered as informative if the
#' posterior falls within the `95%` HDI of the prior.
#' @param simulate_priors Should prior distributions be simulated using
#' [simulate_prior()] (default; faster) or sampled via
#' [unupdate()] (slower, more accurate).
#' @inheritParams effective_sample
#' @inheritParams hdi
#'
#' @return A data frame with two columns: The parameter names and the quality
#' of the prior (which might be `"informative"`, `"uninformative"`)
#' or `"not determinable"` if the prior distribution could not be
#' determined).
#'
#' @examplesIf require("rstanarm") && require("see")
#' \donttest{
#' library(bayestestR)
#' model <- rstanarm::stan_glm(mpg ~ wt + am, data = mtcars, chains = 1, refresh = 0)
#' check_prior(model, method = "gelman")
#' check_prior(model, method = "lakeland")
#'
#' # An extreme example where both methods diverge:
#' model <- rstanarm::stan_glm(mpg ~ wt,
#' data = mtcars[1:3, ],
#' prior = normal(-3.3, 1, FALSE),
#' prior_intercept = normal(0, 1000, FALSE),
#' refresh = 0
#' )
#' check_prior(model, method = "gelman")
#' check_prior(model, method = "lakeland")
#' # can provide visual confirmation to the Lakeland method
#' plot(si(model, verbose = FALSE))
#' }
#' @references
#' Gelman, A., Simpson, D., and Betancourt, M. (2017). The Prior Can Often Only
#' Be Understood in the Context of the Likelihood. Entropy, 19(10), 555.
#' \doi{10.3390/e19100555}
#'
#' @export
check_prior <- function(model, method = "gelman", simulate_priors = TRUE, ...) {
UseMethod("check_prior")
}
#' @export
check_prior.brmsfit <- function(model,
method = "gelman",
simulate_priors = TRUE,
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
verbose = TRUE,
...) {
# check arguments
effects <- match.arg(effects)
component <- match.arg(component)
posteriors <- insight::get_parameters(
model,
effects = effects,
component = component,
parameters = parameters
)
if (isTRUE(simulate_priors)) {
priors <- simulate_prior(
model,
effects = effects,
component = component,
parameters = parameters,
verbose = verbose
)
} else {
priors <- unupdate(model, verbose = FALSE)
priors <- insight::get_parameters(
priors,
effects = effects,
component = component,
parameters = parameters
)
}
.check_prior(priors, posteriors, method,
verbose = verbose,
cleaned_parameters = insight::clean_parameters(model)
)
}
#' @export
check_prior.stanreg <- check_prior.brmsfit
#' @export
check_prior.blavaan <- check_prior.brmsfit
#' @keywords internal
.check_prior <- function(priors,
posteriors,
method = "gelman",
verbose = TRUE,
cleaned_parameters = NULL) {
# validation check for matching parameters. Some weird priors like
# rstanarm's R2 prior might cause problems
if (!is.null(cleaned_parameters) && ncol(priors) != ncol(posteriors)) {
## TODO for now only fixed effects
if ("Effects" %in% colnames(cleaned_parameters)) {
cleaned_parameters <- cleaned_parameters[cleaned_parameters$Effects == "fixed", ]
}
# rename cleaned parameters, so they match name of prior parameter column
cp <- cleaned_parameters$Cleaned_Parameter
cp <- gsub("(.*)(\\.|\\[)\\d+(\\.|\\])", "\\1", cp)
cp[cp == "Intercept"] <- "(Intercept)"
cleaned_parameters$Cleaned_Parameter <- cp
colnames(priors)[colnames(priors) == "Intercept"] <- "(Intercept)"
# at this point, the colnames of "posteriors" should match "cp$Parameter",
# while colnames of "priors" should match "cp$Cleaned_Parameter". To ensure
# that ncol of priors is the same as ncol of posteriors, we now duplicate
# prior columns and match them with the posteriors
if (ncol(posteriors) > ncol(priors)) {
matched_columns <- stats::na.omit(match(cleaned_parameters$Cleaned_Parameter, colnames(priors)))
matched_column_names <- stats::na.omit(match(colnames(priors), cleaned_parameters$Cleaned_Parameter))
priors <- priors[matched_columns]
} else {
matched_columns <- stats::na.omit(match(colnames(priors), cleaned_parameters$Cleaned_Parameter))
matched_column_names <- stats::na.omit(match(cleaned_parameters$Cleaned_Parameter, colnames(priors)))
priors <- priors[matched_columns]
}
colnames(priors) <- cleaned_parameters$Parameter[matched_column_names]
}
# still different ncols?
if (ncol(priors) != ncol(posteriors)) {
common_columns <- intersect(colnames(priors), colnames(posteriors))
priors <- priors[common_columns]
posteriors <- posteriors[common_columns]
if (verbose) {
insight::format_warning(
"Parameters and priors could not be fully matched. Only returning results for parameters with matching priors."
)
}
}
# for priors whose distribution cannot be simulated, prior values are
# all NA. Catch those, and warn user
all_missing <- vapply(priors, function(i) all(is.na(i)), TRUE)
if (any(all_missing) && verbose) {
insight::format_warning("Some priors could not be simulated.")
}
.gelman <- function(prior, posterior) {
if (all(is.na(prior))) {
"not determinable"
} else if (stats::sd(posterior, na.rm = TRUE) > 0.1 * stats::sd(prior, na.rm = TRUE)) {
"informative"
} else {
"uninformative"
}
}
.lakeland <- function(prior, posterior) {
if (all(is.na(prior))) {
"not determinable"
} else {
hdi <- hdi(prior, ci = 0.95)
r <- rope(posterior, ci = 1, range = c(hdi$CI_low, hdi$CI_high))
if (as.numeric(r) > 0.99) {
"informative"
} else {
"misinformative"
}
}
}
if (method == "gelman") {
result <- mapply(.gelman, priors, posteriors)
} else if (method == "lakeland") {
result <- mapply(.lakeland, priors, posteriors)
} else {
insight::format_error("method should be 'gelman' or 'lakeland'.")
}
data.frame(
Parameter = names(posteriors),
Prior_Quality = unname(result),
stringsAsFactors = FALSE
)
}
bayestestR/R/simulate_simpson.R 0000644 0001762 0000144 00000003120 14650172354 016321 0 ustar ligges users #' Simpson's paradox dataset simulation
#'
#' Simpson's paradox, or the Yule-Simpson effect, is a phenomenon in probability
#' and statistics, in which a trend appears in several different groups of data
#' but disappears or reverses when these groups are combined.
#'
#' @param n The number of observations for each group to be generated (minimum 4).
#' @param groups Number of groups (groups can be participants, clusters, anything).
#' @param difference Difference between groups.
#' @param group_prefix The prefix of the group name (e.g., "G_1", "G_2", "G_3", ...).
#' @inheritParams simulate_correlation
#'
#' @return A dataset.
#'
#' @examples
#' data <- simulate_simpson(n = 10, groups = 5, r = 0.5)
#'
#' if (require("ggplot2")) {
#' ggplot(data, aes(x = V1, y = V2)) +
#' geom_point(aes(color = Group)) +
#' geom_smooth(aes(color = Group), method = "lm") +
#' geom_smooth(method = "lm")
#' }
#' @export
simulate_simpson <- function(n = 100,
r = 0.5,
groups = 3,
difference = 1,
group_prefix = "G_") {
if (n <= 3) {
insight::format_error("The number of observations `n` should be larger than 3.")
}
out <- data.frame()
for (i in 1:groups) {
dat <- simulate_correlation(n = n, r = r)
dat$V1 <- dat$V1 + difference * i # (i * -sign(r))
dat$V2 <- dat$V2 + difference * (i * -sign(r))
dat$Group <- sprintf(paste0(group_prefix, "%0", nchar(trunc(abs(groups))), "d"), i)
out <- rbind(out, dat)
}
out
}
bayestestR/R/weighted_posteriors.R 0000644 0001762 0000144 00000024024 14650172354 017025 0 ustar ligges users #' Generate posterior distributions weighted across models
#'
#' Extract posterior samples of parameters, weighted across models. Weighting is
#' done by comparing posterior model probabilities, via [bayesfactor_models()].
#'
#' @param ... Fitted models (see details), all fit on the same data, or a single
#' `BFBayesFactor` object.
#' @param missing An optional numeric value to use if a model does not contain a
#' parameter that appears in other models. Defaults to 0.
#' @param prior_odds Optional vector of prior odds for the models compared to
#' the first model (or the denominator, for `BFBayesFactor` objects). For
#' `data.frame`s, this will be used as the basis of weighting.
#' @param iterations For `BayesFactor` models, how many posterior samples to draw.
#' @inheritParams bayesfactor_models
#' @inheritParams bayesfactor_parameters
#'
#' @details
#' Note that across models some parameters might play different roles. For
#' example, the parameter `A` plays a different role in the model `Y ~ A + B`
#' (where it is a main effect) than it does in the model `Y ~ A + B + A:B`
#' (where it is a simple effect). In many cases centering of predictors (mean
#' subtracting for continuous variables, and effects coding via `contr.sum` or
#' orthonormal coding via [`contr.equalprior_pairs`] for factors) can reduce this
#' issue. In any case you should be mindful of this issue.
#'
#' See [bayesfactor_models()] details for more info on passed models.
#'
#' Note that for `BayesFactor` models, posterior samples cannot be generated
#' from intercept only models.
#'
#' This function is similar in function to `brms::posterior_average`.
#'
#' @note For `BayesFactor < 0.9.12-4.3`, in some instances there might be
#' some problems of duplicate columns of random effects in the resulting data
#' frame.
#'
#' @return A data frame with posterior distributions (weighted across models) .
#'
#' @seealso [`bayesfactor_inclusion()`] for Bayesian model averaging.
#'
#' @examples
#' \donttest{
#' if (require("rstanarm") && require("see") && interactive()) {
#' stan_m0 <- suppressWarnings(stan_glm(extra ~ 1,
#' data = sleep,
#' family = gaussian(),
#' refresh = 0,
#' diagnostic_file = file.path(tempdir(), "df0.csv")
#' ))
#'
#' stan_m1 <- suppressWarnings(stan_glm(extra ~ group,
#' data = sleep,
#' family = gaussian(),
#' refresh = 0,
#' diagnostic_file = file.path(tempdir(), "df1.csv")
#' ))
#'
#' res <- weighted_posteriors(stan_m0, stan_m1, verbose = FALSE)
#'
#' plot(eti(res))
#' }
#'
#' ## With BayesFactor
#' if (require("BayesFactor")) {
#' extra_sleep <- ttestBF(formula = extra ~ group, data = sleep)
#'
#' wp <- weighted_posteriors(extra_sleep, verbose = FALSE)
#'
#' describe_posterior(extra_sleep, test = NULL, verbose = FALSE)
#' # also considers the null
#' describe_posterior(wp$delta, test = NULL, verbose = FALSE)
#' }
#'
#'
#' ## weighted prediction distributions via data.frames
#' if (require("rstanarm") && interactive()) {
#' m0 <- suppressWarnings(stan_glm(
#' mpg ~ 1,
#' data = mtcars,
#' family = gaussian(),
#' diagnostic_file = file.path(tempdir(), "df0.csv"),
#' refresh = 0
#' ))
#'
#' m1 <- suppressWarnings(stan_glm(
#' mpg ~ carb,
#' data = mtcars,
#' family = gaussian(),
#' diagnostic_file = file.path(tempdir(), "df1.csv"),
#' refresh = 0
#' ))
#'
#' # Predictions:
#' pred_m0 <- data.frame(posterior_predict(m0))
#' pred_m1 <- data.frame(posterior_predict(m1))
#'
#' BFmods <- bayesfactor_models(m0, m1, verbose = FALSE)
#'
#' wp <- weighted_posteriors(
#' pred_m0, pred_m1,
#' prior_odds = as.numeric(BFmods)[2],
#' verbose = FALSE
#' )
#'
#' # look at first 5 prediction intervals
#' hdi(pred_m0[1:5])
#' hdi(pred_m1[1:5])
#' hdi(wp[1:5]) # between, but closer to pred_m1
#' }
#' }
#'
#' @references
#'
#' - Clyde, M., Desimone, H., & Parmigiani, G. (1996). Prediction via
#' orthogonalized model mixing. Journal of the American Statistical
#' Association, 91(435), 1197-1208.
#'
#' - Hinne, M., Gronau, Q. F., van den Bergh, D., and Wagenmakers, E.
#' (2019, March 25). A conceptual introduction to Bayesian Model Averaging.
#' \doi{10.31234/osf.io/wgb64}
#'
#' - Rouder, J. N., Haaf, J. M., & Vandekerckhove, J. (2018). Bayesian
#' inference for psychology, part IV: Parameter estimation and Bayes factors.
#' Psychonomic bulletin & review, 25(1), 102-113.
#'
#' - van den Bergh, D., Haaf, J. M., Ly, A., Rouder, J. N., & Wagenmakers,
#' E. J. (2019). A cautionary note on estimating effect size.
#'
#' @export
weighted_posteriors <- function(..., prior_odds = NULL, missing = 0, verbose = TRUE) {
UseMethod("weighted_posteriors")
}
#' @export
#' @rdname weighted_posteriors
weighted_posteriors.data.frame <- function(..., prior_odds = NULL, missing = 0, verbose = TRUE) {
Mods <- list(...)
mnames <- sapply(match.call(expand.dots = FALSE)$`...`, insight::safe_deparse)
# find min nrow
iterations <- min(vapply(Mods, nrow, numeric(1)))
# make weights from prior_odds
if (!is.null(prior_odds)) {
prior_odds <- c(1, prior_odds)
} else {
if (verbose) {
insight::format_warning(
"'prior_odds = NULL'; Using uniform priors odds.\n",
"For weighted data frame, 'prior_odds' should be specified as a numeric vector."
)
}
prior_odds <- rep(1, length(Mods))
}
Probs <- prior_odds / sum(prior_odds)
weighted_samps <- round(iterations * Probs)
# pass to .weighted_posteriors
res <- .weighted_posteriors(Mods, weighted_samps, missing)
# make weights table
attr(res, "weights") <- data.frame(Model = mnames, weights = weighted_samps)
return(res)
}
#' @export
#' @rdname weighted_posteriors
weighted_posteriors.stanreg <- function(...,
prior_odds = NULL,
missing = 0,
verbose = TRUE,
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL) {
Mods <- list(...)
effects <- match.arg(effects)
component <- match.arg(component)
# Get Bayes factors
BFMods <- bayesfactor_models(..., denominator = 1, verbose = verbose)
# Compute posterior model probabilities
model_tab <- .get_model_table(BFMods, priorOdds = prior_odds)
postProbs <- model_tab$postProbs
# Compute weighted number of samples
iterations <- min(sapply(Mods, .total_samps))
weighted_samps <- round(iterations * postProbs)
# extract parameters
params <- lapply(Mods, insight::get_parameters,
effects = effects,
component = component,
parameters = parameters
)
res <- .weighted_posteriors(params, weighted_samps, missing)
attr(res, "weights") <- data.frame(Model = BFMods$Model, weights = weighted_samps)
return(res)
}
#' @export
#' @rdname weighted_posteriors
weighted_posteriors.brmsfit <- weighted_posteriors.stanreg
#' @export
#' @rdname weighted_posteriors
weighted_posteriors.blavaan <- weighted_posteriors.stanreg
#' @export
#' @rdname weighted_posteriors
weighted_posteriors.BFBayesFactor <- function(...,
prior_odds = NULL,
missing = 0,
verbose = TRUE,
iterations = 4000) {
Mods <- c(...)
# Get Bayes factors
BFMods <- bayesfactor_models(Mods, verbose = verbose)
# Compute posterior model probabilities
model_tab <- .get_model_table(BFMods, priorOdds = prior_odds, add_effects_table = FALSE)
postProbs <- model_tab$postProbs
# Compute weighted number of samples
weighted_samps <- round(iterations * postProbs)
# extract parameters
intercept_only <- which(BFMods$Model == "1")
params <- vector(mode = "list", length = nrow(BFMods))
for (m in seq_along(params)) {
if (length(intercept_only) && m == intercept_only) {
# warning(
# "Cannot sample from BFBayesFactor model with intercept only (model prob = ",
# round(postProbs[m], 3) * 100, "%).\n",
# "Omitting the intercept model.",
# call. = FALSE
# )
params[[m]] <- data.frame(
mu = rep(NA, iterations),
sig2 = rep(NA, iterations),
g = rep(NA, iterations)
)
} else if (m == 1) {
# If the model is the "den" model
params[[m]] <- BayesFactor::posterior(1 / Mods[1], iterations = iterations, progress = FALSE)
} else {
params[[m]] <- BayesFactor::posterior(
Mods[m - 1],
iterations = iterations, progress = FALSE
)
}
}
params <- lapply(params, data.frame)
res <- .weighted_posteriors(params, weighted_samps, missing)
attr(res, "weights") <- data.frame(Model = BFMods$Model, weights = weighted_samps)
return(res)
}
.weighted_posteriors <- function(params, weighted_samps, missing) {
par_names <- unique(unlist(sapply(params, colnames), recursive = TRUE))
# remove empty (0 sample) models
params <- params[weighted_samps != 0]
weighted_samps <- weighted_samps[weighted_samps != 0]
for (m in seq_along(weighted_samps)) {
temp_params <- params[[m]]
i <- sample(nrow(temp_params), size = weighted_samps[m])
temp_params <- temp_params[i, , drop = FALSE]
# If any parameters not estimated in the model, they are assumed to be 0 (the default value of `missing`)
missing_pars <- setdiff(par_names, colnames(temp_params))
temp_params[, missing_pars] <- missing
params[[m]] <- temp_params
}
# combine all
do.call("rbind", params)
}
#' @keywords internal
.total_samps <- function(mod) {
x <- insight::find_algorithm(mod)
if (is.null(x$iterations)) x$iterations <- x$sample
x$chains * (x$iterations - x$warmup)
}
bayestestR/R/unupdate.R 0000644 0001762 0000144 00000007612 14461433341 014561 0 ustar ligges users #' Un-update Bayesian models to their prior-to-data state
#'
#' As posteriors are priors that have been updated after observing some data,
#' the goal of this function is to un-update the posteriors to obtain models
#' representing the priors. These models can then be used to examine the prior
#' predictive distribution, or to compare priors with posteriors.
#'
#' This function in used internally to compute Bayes factors.
#'
#' @param model A fitted Bayesian model.
#' @param verbose Toggle warnings.
#' @param newdata List of `data.frames` to update the model with new data.
#' Required even if the original data should be used.
#' @param ... Not used
#'
#' @return A model un-fitted to the data, representing the prior model.
#'
#' @keywords internal
#' @export
unupdate <- function(model, verbose = TRUE, ...) {
UseMethod("unupdate")
}
#' @export
#' @rdname unupdate
unupdate.stanreg <- function(model, verbose = TRUE, ...) {
insight::check_if_installed("rstanarm")
prior_PD <- stats::getCall(model)$prior_PD
if (!is.null(prior_PD) && isTRUE(eval(parse(text = prior_PD)))) {
return(model)
}
if (verbose) {
insight::format_alert("Sampling priors, please wait...")
}
prior_dists <- sapply(rstanarm::prior_summary(model), `[[`, "dist")
if (anyNA(prior_dists)) {
insight::format_error(
"Cannot sample from flat priors (such as when priors are set to 'NULL' in a 'stanreg' model)."
)
}
model_prior <- suppressWarnings(
stats::update(model, prior_PD = TRUE, refresh = 0)
)
model_prior
}
#' @export
#' @rdname unupdate
unupdate.brmsfit <- function(model, verbose = TRUE, ...) {
insight::check_if_installed("brms")
if (isTRUE(attr(model$prior, "sample_prior") == "only")) {
return(model)
}
if (verbose) {
insight::format_alert("Sampling priors, please wait...")
}
utils::capture.output({
model_prior <- try(suppressMessages(suppressWarnings(
stats::update(model, sample_prior = "only", refresh = 0)
)), silent = TRUE)
})
if (methods::is(model_prior, "try-error")) {
if (grepl("proper priors", model_prior, fixed = TRUE)) {
insight::format_error(
"Cannot sample from flat priors (such as the default priors for fixed-effects in a 'brmsfit' model)."
)
} else {
insight::format_error(model_prior)
}
}
model_prior
}
#' @export
#' @rdname unupdate
unupdate.brmsfit_multiple <- function(model,
verbose = TRUE,
newdata = NULL,
...) {
insight::check_if_installed("brms")
if (isTRUE(attr(model$prior, "sample_prior") == "only")) {
return(model)
}
if (verbose) {
insight::format_alert("Sampling priors, please wait...")
}
utils::capture.output({
model_prior <-
try(suppressMessages(suppressWarnings(
stats::update(
model,
sample_prior = "only",
newdata = newdata,
refresh = 0
)
)), silent = TRUE)
})
if (methods::is(model_prior, "try-error")) {
if (grepl("proper priors", model_prior, fixed = TRUE)) {
insight::format_error(
"Cannot sample from flat priors (such as the default priors for fixed-effects in a 'brmsfit' model)."
)
} else {
insight::format_error(model_prior)
}
}
model_prior
}
#' @export
#' @rdname unupdate
unupdate.blavaan <- function(model, verbose = TRUE, ...) {
insight::check_if_installed("blavaan")
cl <- model@call
if (isTRUE(eval(cl$prisamp))) {
return(model)
}
if (verbose) {
insight::format_alert("Sampling priors, please wait...")
}
cl$prisamp <- TRUE
suppressMessages(suppressWarnings(
utils::capture.output({
model_prior <- eval(cl)
})
))
model_prior
}
bayestestR/R/diagnostic_posterior.R 0000644 0001762 0000144 00000027046 14650172354 017175 0 ustar ligges users #' Posteriors Sampling Diagnostic
#'
#' Extract diagnostic metrics (Effective Sample Size (`ESS`), `Rhat` and Monte
#' Carlo Standard Error `MCSE`).
#'
#' @param posterior A `stanreg`, `stanfit`, `brmsfit`, or `blavaan` object.
#' @param diagnostic Diagnostic metrics to compute. Character (vector) or list
#' with one or more of these options: `"ESS"`, `"Rhat"`, `"MCSE"` or `"all"`.
#'
#' @details
#' **Effective Sample (ESS)** should be as large as possible, although for
#' most applications, an effective sample size greater than 1000 is sufficient
#' for stable estimates (_Bürkner, 2017_). The ESS corresponds to the number of
#' independent samples with the same estimation power as the N autocorrelated
#' samples. It is is a measure of "how much independent information there is
#' in autocorrelated chains" (_Kruschke 2015, p182-3_).
#'
#' **Rhat** should be the closest to 1. It should not be larger than 1.1
#' (_Gelman and Rubin, 1992_) or 1.01 (_Vehtari et al., 2019_). The split
#' Rhat statistic quantifies the consistency of an ensemble of Markov chains.
#'
#' **Monte Carlo Standard Error (MCSE)** is another measure of accuracy of the
#' chains. It is defined as standard deviation of the chains divided by their
#' effective sample size (the formula for `mcse()` is from Kruschke 2015, p.
#' 187). The MCSE "provides a quantitative suggestion of how big the estimation
#' noise is".
#'
#'
#' @examplesIf require("rstanarm") && require("brms")
#' \donttest{
#' # rstanarm models
#' # -----------------------------------------------
#' model <- suppressWarnings(
#' rstanarm::stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0)
#' )
#' diagnostic_posterior(model)
#'
#' # brms models
#' # -----------------------------------------------
#' model <- brms::brm(mpg ~ wt + cyl, data = mtcars)
#' diagnostic_posterior(model)
#' }
#' @references
#' - Gelman, A., & Rubin, D. B. (1992). Inference from iterative simulation
#' using multiple sequences. Statistical science, 7(4), 457-472.
#' - Vehtari, A., Gelman, A., Simpson, D., Carpenter, B., and Bürkner, P. C.
#' (2019). Rank-normalization, folding, and localization: An improved Rhat
#' for assessing convergence of MCMC. arXiv preprint arXiv:1903.08008.
#' - Kruschke, J. (2014). Doing Bayesian data analysis: A tutorial with R,
#' JAGS, and Stan. Academic Press.
#' @export
diagnostic_posterior <- function(posterior, ...) {
UseMethod("diagnostic_posterior")
}
#' @rdname diagnostic_posterior
#' @export
diagnostic_posterior.default <- function(posterior, diagnostic = c("ESS", "Rhat"), ...) {
insight::format_error("'diagnostic_posterior()' only works with rstanarm, brms or blavaan models.")
}
#' @inheritParams insight::get_parameters.BFBayesFactor
#' @inheritParams insight::get_parameters
#' @rdname diagnostic_posterior
#' @export
diagnostic_posterior.stanreg <- function(posterior, diagnostic = "all", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, ...) {
# Find parameters
effects <- match.arg(effects)
component <- match.arg(component)
params <- insight::find_parameters(
posterior,
effects = effects,
component = component,
parameters = parameters,
flatten = TRUE
)
# If no diagnostic
if (is.null(diagnostic)) {
return(data.frame(Parameter = params))
}
diagnostic <- match.arg(diagnostic, c("ESS", "Rhat", "MCSE", "all"), several.ok = TRUE)
if ("all" %in% diagnostic) {
diagnostic <- c("ESS", "Rhat", "MCSE", "khat")
} else {
diagnostic <- diagnostic
if ("Rhat" %in% diagnostic) diagnostic <- c(diagnostic, "khat")
}
# Get indices and rename
diagnostic_df <- as.data.frame(posterior$stan_summary)
diagnostic_df$Parameter <- row.names(diagnostic_df)
if ("n_eff" %in% names(diagnostic_df)) {
diagnostic_df$ESS <- diagnostic_df$n_eff
}
# special handling for MCSE, due to some parameters (like lp__) missing in rows
MCSE <- mcse(posterior, effects = "all")
diagnostic_df <- merge(diagnostic_df, MCSE, by = "Parameter", all = FALSE)
# Select columns
available_columns <- intersect(colnames(diagnostic_df), c("Parameter", diagnostic))
diagnostic_df <- diagnostic_df[available_columns]
names(diagnostic_df)[available_columns == "khat"] <- "Khat"
row.names(diagnostic_df) <- NULL
# Remove columns with all Nans
diagnostic_df <- diagnostic_df[!sapply(diagnostic_df, function(x) all(is.na(x)))]
# Select rows
diagnostic_df[diagnostic_df$Parameter %in% params, ]
}
#' @inheritParams insight::get_parameters
#' @export
diagnostic_posterior.stanmvreg <- function(posterior,
diagnostic = "all",
effects = c("fixed", "random", "all"),
parameters = NULL,
...) {
# Find parameters
effects <- match.arg(effects)
all_params <- insight::find_parameters(
posterior,
effects = effects,
parameters = parameters,
flatten = FALSE
)
params <- unlist(lapply(names(all_params), function(i) {
all_params[[i]]$sigma <- NULL
unlist(all_params[[i]], use.names = FALSE)
}), use.names = FALSE)
# If no diagnostic
if (is.null(diagnostic)) {
return(data.frame(Parameter = params))
}
diagnostic <- match.arg(diagnostic, c("ESS", "Rhat", "MCSE", "all"), several.ok = TRUE)
if ("all" %in% diagnostic) {
diagnostic <- c("ESS", "Rhat", "MCSE", "khat")
} else {
diagnostic <- diagnostic
if ("Rhat" %in% diagnostic) diagnostic <- c(diagnostic, "khat")
}
# Get indices and rename
diagnostic_df <- as.data.frame(posterior$stan_summary)
diagnostic_df$Parameter <- row.names(diagnostic_df)
if ("n_eff" %in% names(diagnostic_df)) {
diagnostic_df$ESS <- diagnostic_df$n_eff
}
# special handling for MCSE, due to some parameters (like lp__) missing in rows
MCSE <- mcse(posterior, effects = effects)
diagnostic_df <- merge(diagnostic_df, MCSE, by = "Parameter", all = FALSE)
# Select columns
available_columns <- intersect(colnames(diagnostic_df), c("Parameter", diagnostic))
diagnostic_df <- diagnostic_df[available_columns]
names(diagnostic_df)[available_columns == "khat"] <- "Khat"
row.names(diagnostic_df) <- NULL
# Remove columns with all Nans
diagnostic_df <- diagnostic_df[!sapply(diagnostic_df, function(x) all(is.na(x)))]
diagnostic_df$Response <- gsub("(b\\[)*(.*)\\|(.*)", "\\2", diagnostic_df$Parameter)
for (i in unique(diagnostic_df$Response)) {
diagnostic_df$Parameter <- gsub(sprintf("%s|", i), "", diagnostic_df$Parameter, fixed = TRUE)
}
# Select rows
diagnostic_df[diagnostic_df$Parameter %in% params, ]
}
#' @inheritParams insight::get_parameters
#' @rdname diagnostic_posterior
#' @export
diagnostic_posterior.brmsfit <- function(posterior,
diagnostic = "all",
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
...) {
# Find parameters
effects <- match.arg(effects)
component <- match.arg(component)
params <- insight::find_parameters(posterior,
effects = effects,
component = component,
parameters = parameters,
flatten = TRUE
)
# If no diagnostic
if (is.null(diagnostic)) {
return(data.frame(Parameter = params))
}
# Get diagnostic
diagnostic <- match.arg(diagnostic, c("ESS", "Rhat", "MCSE", "all"), several.ok = TRUE)
if ("all" %in% diagnostic) {
diagnostic <- c("ESS", "Rhat", "MCSE", "khat") # Add MCSE
} else if ("Rhat" %in% diagnostic) {
diagnostic <- c(diagnostic, "khat")
}
insight::check_if_installed("rstan")
# Get indices and rename
diagnostic_df <- as.data.frame(rstan::summary(posterior$fit)$summary)
diagnostic_df$Parameter <- row.names(diagnostic_df)
diagnostic_df$ESS <- diagnostic_df$n_eff
# special handling for MCSE, due to some parameters (like lp__) missing in rows
MCSE <- mcse(posterior, effects = "all", component = "all")
diagnostic_df <- merge(diagnostic_df, MCSE, by = "Parameter", all = FALSE)
# Select columns
available_columns <- intersect(colnames(diagnostic_df), c("Parameter", diagnostic))
diagnostic_df <- diagnostic_df[available_columns]
names(diagnostic_df)[available_columns == "khat"] <- "Khat"
row.names(diagnostic_df) <- NULL
# Remove columns with all Nans
diagnostic_df <- diagnostic_df[!sapply(diagnostic_df, function(x) all(is.na(x)))]
# Select rows
diagnostic_df[diagnostic_df$Parameter %in% params, ]
}
#' @inheritParams insight::get_parameters
#' @export
diagnostic_posterior.stanfit <- function(posterior, diagnostic = "all", effects = c("fixed", "random", "all"), parameters = NULL, ...) {
# Find parameters
effects <- match.arg(effects)
params <- insight::find_parameters(posterior, effects = effects, parameters = parameters, flatten = TRUE)
# If no diagnostic
if (is.null(diagnostic)) {
return(data.frame(Parameter = params))
}
# Get diagnostic
diagnostic <- match.arg(diagnostic, c("ESS", "Rhat", "MCSE", "all"), several.ok = TRUE)
if ("all" %in% diagnostic) {
diagnostic <- c("ESS", "Rhat", "MCSE")
}
insight::check_if_installed("rstan")
all_params <- insight::find_parameters(posterior,
effects = effects,
flatten = TRUE
)
diagnostic_df <- data.frame(
Parameter = all_params,
stringsAsFactors = FALSE
)
if ("ESS" %in% diagnostic) {
diagnostic_df$ESS <- effective_sample(posterior, effects = effects)$ESS
}
if ("MCSE" %in% diagnostic) {
diagnostic_df$MCSE <- mcse(posterior, effects = effects)$MCSE
}
if ("Rhat" %in% diagnostic) {
s <- as.data.frame(rstan::summary(posterior)$summary)
diagnostic_df$Rhat <- s[rownames(s) %in% all_params, ]$Rhat
}
# Remove columns with all Nans
diagnostic_df <- diagnostic_df[!sapply(diagnostic_df, function(x) all(is.na(x)))]
# Select rows
diagnostic_df[diagnostic_df$Parameter %in% params, ]
}
#' @export
diagnostic_posterior.blavaan <- function(posterior, diagnostic = "all", ...) {
# Find parameters
params <- suppressWarnings(insight::find_parameters(posterior, flatten = TRUE))
out <- data.frame(Parameter = params)
# If no diagnostic
if (is.null(diagnostic)) {
return(out)
}
diagnostic <- match.arg(diagnostic, c("ESS", "Rhat", "MCSE", "all"), several.ok = TRUE)
if ("all" %in% diagnostic) {
diagnostic <- c("ESS", "Rhat", "MCSE")
} else {
diagnostic <- diagnostic
if ("Rhat" %in% diagnostic) diagnostic <- c(diagnostic, "khat")
}
# Get indices
if ("Rhat" %in% diagnostic) {
insight::check_if_installed("blavaan")
Rhat <- blavaan::blavInspect(posterior, what = "psrf")
Rhat <- data.frame(
Parameter = colnames(insight::get_parameters(posterior)),
Rhat = Rhat
)
out <- merge(out, Rhat, by = "Parameter", all = TRUE)
}
if ("ESS" %in% diagnostic) {
ESS <- effective_sample(posterior)
out <- merge(out, ESS, by = "Parameter", all = TRUE)
}
if ("MCSE" %in% diagnostic) {
MCSE <- mcse(posterior)
out <- merge(out, MCSE, by = "Parameter", all = TRUE)
}
unique(out)
}
bayestestR/R/p_map.R 0000644 0001762 0000144 00000026120 14560763455 014037 0 ustar ligges users #' Bayesian p-value based on the density at the Maximum A Posteriori (MAP)
#'
#' Compute a Bayesian equivalent of the *p*-value, related to the odds that a
#' parameter (described by its posterior distribution) has against the null
#' hypothesis (*h0*) using Mills' (2014, 2017) *Objective Bayesian Hypothesis
#' Testing* framework. It corresponds to the density value at the null (e.g., 0)
#' divided by the density at the Maximum A Posteriori (MAP).
#'
#' @details Note that this method is sensitive to the density estimation `method`
#' (see the section in the examples below).
#'
#' ## Strengths and Limitations
#'
#' **Strengths:** Straightforward computation. Objective property of the posterior
#' distribution.
#'
#' **Limitations:** Limited information favoring the null hypothesis. Relates
#' on density approximation. Indirect relationship between mathematical
#' definition and interpretation. Only suitable for weak / very diffused priors.
#'
#' @inheritParams hdi
#' @inheritParams density_at
#' @inheritParams pd
#'
#' @examplesIf require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")
#' library(bayestestR)
#'
#' p_map(rnorm(1000, 0, 1))
#' p_map(rnorm(1000, 10, 1))
#' \donttest{
#' model <- suppressWarnings(
#' rstanarm::stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0)
#' )
#' p_map(model)
#'
#' p_map(suppressWarnings(
#' emmeans::emtrends(model, ~1, "wt", data = mtcars)
#' ))
#'
#' model <- brms::brm(mpg ~ wt + cyl, data = mtcars)
#' p_map(model)
#'
#' bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1))
#' p_map(bf)
#'
#' # ---------------------------------------
#' # Robustness to density estimation method
#' set.seed(333)
#' data <- data.frame()
#' for (iteration in 1:250) {
#' x <- rnorm(1000, 1, 1)
#' result <- data.frame(
#' Kernel = as.numeric(p_map(x, method = "kernel")),
#' KernSmooth = as.numeric(p_map(x, method = "KernSmooth")),
#' logspline = as.numeric(p_map(x, method = "logspline"))
#' )
#' data <- rbind(data, result)
#' }
#' data$KernSmooth <- data$Kernel - data$KernSmooth
#' data$logspline <- data$Kernel - data$logspline
#'
#' summary(data$KernSmooth)
#' summary(data$logspline)
#' boxplot(data[c("KernSmooth", "logspline")])
#' }
#' @seealso [Jeff Mill's talk](https://www.youtube.com/watch?v=Ip8Ci5KUVRc)
#'
#' @references
#' - Makowski D, Ben-Shachar MS, Chen SHA, Lüdecke D (2019) Indices of Effect Existence and Significance in the Bayesian Framework. Frontiers in Psychology 2019;10:2767. \doi{10.3389/fpsyg.2019.02767}
#' - Mills, J. A. (2018). Objective Bayesian Precise Hypothesis Testing. University of Cincinnati.
#'
#' @export
p_map <- function(x, ...) {
UseMethod("p_map")
}
#' @rdname p_map
#' @export
p_pointnull <- p_map
#' @rdname p_map
#' @export
p_map.numeric <- function(x, null = 0, precision = 2^10, method = "kernel", ...) {
p_map(data.frame(Posterior = x), null = null, precision = precision, method = method, ...)
}
#' @rdname p_map
#' @export
p_map.get_predicted <- function(x,
null = 0,
precision = 2^10,
method = "kernel",
use_iterations = FALSE,
verbose = TRUE,
...) {
if (isTRUE(use_iterations)) {
if ("iterations" %in% names(attributes(x))) {
out <- p_map(
as.data.frame(t(attributes(x)$iterations)),
null = null,
precision = precision,
method = method,
verbose = verbose,
...
)
} else {
insight::format_error("No iterations present in the output.")
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
} else {
out <- p_map(as.numeric(x),
null = null,
precision = precision,
method = method,
verbose = verbose,
...
)
}
out
}
#' @export
p_map.data.frame <- function(x, null = 0, precision = 2^10, method = "kernel", ...) {
x <- .select_nums(x)
if (ncol(x) == 1) {
p_MAP <- .p_map(x[, 1], null = null, precision = precision, method = method, ...)
} else {
p_MAP <- sapply(x, .p_map, null = null, precision = precision, method = method, simplify = TRUE, ...)
}
out <- data.frame(
Parameter = names(x),
p_MAP = p_MAP,
row.names = NULL,
stringsAsFactors = FALSE
)
class(out) <- c("p_map", class(out))
out
}
#' @export
p_map.draws <- function(x, null = 0, precision = 2^10, method = "kernel", ...) {
p_map(.posterior_draws_to_df(x), null = null, precision = precision, method = method, ...)
}
#' @export
p_map.rvar <- p_map.draws
#' @export
p_map.emmGrid <- function(x, null = 0, precision = 2^10, method = "kernel", ...) {
xdf <- insight::get_parameters(x)
out <- p_map(xdf, null = null, precision = precision, method = method, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_map.emm_list <- p_map.emmGrid
#' @keywords internal
.p_map_models <- function(x, null, precision, method, effects, component, parameters, ...) {
p_map(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
null = null,
precision = precision,
method = method,
...
)
}
#' @export
p_map.mcmc <- function(x, null = 0, precision = 2^10, method = "kernel", parameters = NULL, ...) {
out <- .p_map_models(
x = x,
null = null,
precision = precision,
method = method,
effects = "fixed",
component = "conditional",
parameters = parameters,
...
)
attr(out, "data") <- insight::get_parameters(x, parameters = parameters)
out
}
#' @export
p_map.bcplm <- p_map.mcmc
#' @export
p_map.blrm <- p_map.mcmc
#' @export
p_map.mcmc.list <- p_map.mcmc
#' @export
p_map.BGGM <- p_map.mcmc
#' @export
p_map.bamlss <- function(x, null = 0, precision = 2^10, method = "kernel",
component = c("all", "conditional", "location"), parameters = NULL, ...) {
component <- match.arg(component)
out <- .p_map_models(
x = x,
null = null,
precision = precision,
method = method,
effects = "all",
component = component,
parameters = parameters,
...
)
out <- .add_clean_parameters_attribute(out, x)
attr(out, "data") <- insight::get_parameters(x, parameters = parameters)
out
}
#' @export
p_map.sim.merMod <- function(x, null = 0, precision = 2^10, method = "kernel",
effects = c("fixed", "random", "all"), parameters = NULL, ...) {
effects <- match.arg(effects)
out <- .p_map_models(
x = x,
null = null,
precision = precision,
method = method,
effects = effects,
component = "conditional",
parameters = parameters,
...
)
attr(out, "data") <- insight::get_parameters(x, effects = effects, parameters = parameters)
out
}
#' @export
p_map.sim <- function(x, null = 0, precision = 2^10, method = "kernel",
parameters = NULL, ...) {
out <- .p_map_models(
x = x,
null = null,
precision = precision,
method = method,
effects = "fixed",
component = "conditional",
parameters = parameters,
...
)
attr(out, "data") <- insight::get_parameters(x, parameters = parameters)
out
}
#' @rdname p_map
#' @export
p_map.stanreg <- function(x, null = 0, precision = 2^10, method = "kernel",
effects = c("fixed", "random", "all"),
component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"),
parameters = NULL, ...) {
effects <- match.arg(effects)
component <- match.arg(component)
cleaned_parameters <- insight::clean_parameters(x)
out <- .prepare_output(
p_map(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
null = null,
precision = precision,
method = method
),
cleaned_parameters,
inherits(x, "stanmvreg")
)
attr(out, "clean_parameters") <- cleaned_parameters
class(out) <- unique(c("p_map", class(out)))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_map.stanfit <- p_map.stanreg
#' @export
p_map.blavaan <- p_map.stanreg
#' @rdname p_map
#' @export
p_map.brmsfit <- function(x, null = 0, precision = 2^10, method = "kernel",
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL, ...) {
effects <- match.arg(effects)
component <- match.arg(component)
cleaned_parameters <- insight::clean_parameters(x)
out <- .prepare_output(
p_map(
insight::get_parameters(
x,
effects = effects,
component = component,
parameters = parameters
),
null = null,
precision = precision,
method = method,
...
),
cleaned_parameters
)
attr(out, "clean_parameters") <- cleaned_parameters
class(out) <- unique(c("p_map", class(out)))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_map.BFBayesFactor <- function(x, null = 0, precision = 2^10, method = "kernel", ...) {
out <- p_map(insight::get_parameters(x), null = null, precision = precision, method = method, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_map.MCMCglmm <- function(x, null = 0, precision = 2^10, method = "kernel", ...) {
nF <- x$Fixed$nfl
out <- p_map(as.data.frame(x$Sol[, 1:nF, drop = FALSE]), null = null, precision = precision, method = method, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_map.bayesQR <- function(x, null = 0, precision = 2^10, method = "kernel", ...) {
out <- p_map(insight::get_parameters(x), null = null, precision = precision, method = method, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @keywords internal
.p_map <- function(x, null = 0, precision = 2^10, method = "kernel", ...) {
# Density at MAP
map <- attributes(map_estimate(x, precision = precision, method = method, ...))$MAP_density
# Density at 0
d_0 <- density_at(x, null, precision = precision, method = method, ...)
if (is.na(d_0)) d_0 <- 0
# Odds
p <- d_0 / map
p
}
#' @rdname as.numeric.p_direction
#' @method as.numeric p_map
#' @export
as.numeric.p_map <- function(x, ...) {
if (inherits(x, "data.frame")) {
return(as.numeric(as.vector(x$p_MAP)))
} else {
return(as.vector(x))
}
}
#' @method as.double p_map
#' @export
as.double.p_map <- as.numeric.p_map
bayestestR/R/p_significance.R 0000644 0001762 0000144 00000024675 14560763455 015721 0 ustar ligges users #' Practical Significance (ps)
#'
#' Compute the probability of **Practical Significance** (***ps***), which can be conceptualized as a unidirectional equivalence test. It returns the probability that effect is above a given threshold corresponding to a negligible effect in the median's direction. Mathematically, it is defined as the proportion of the posterior distribution of the median sign above the threshold.
#'
#' @param threshold The threshold value that separates significant from negligible effect. If `"default"`, the range is set to `0.1` if input is a vector, and based on [`rope_range()`][rope_range] if a Bayesian model is provided.
#' @inheritParams rope
#' @inheritParams hdi
#'
#' @return Values between 0 and 1 corresponding to the probability of practical significance (ps).
#'
#' @details `p_significance()` returns the proportion of a probability
#' distribution (`x`) that is outside a certain range (the negligible
#' effect, or ROPE, see argument `threshold`). If there are values of the
#' distribution both below and above the ROPE, `p_significance()` returns
#' the higher probability of a value being outside the ROPE. Typically, this
#' value should be larger than 0.5 to indicate practical significance. However,
#' if the range of the negligible effect is rather large compared to the
#' range of the probability distribution `x`, `p_significance()`
#' will be less than 0.5, which indicates no clear practical significance.
#'
#' @note There is also a [`plot()`-method](https://easystats.github.io/see/articles/bayestestR.html) implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}.
#'
#' @examplesIf require("rstanarm")
#' library(bayestestR)
#'
#' # Simulate a posterior distribution of mean 1 and SD 1
#' # ----------------------------------------------------
#' posterior <- rnorm(1000, mean = 1, sd = 1)
#' p_significance(posterior)
#'
#' # Simulate a dataframe of posterior distributions
#' # -----------------------------------------------
#' df <- data.frame(replicate(4, rnorm(100)))
#' p_significance(df)
#' \donttest{
#' # rstanarm models
#' # -----------------------------------------------
#' model <- rstanarm::stan_glm(mpg ~ wt + cyl,
#' data = mtcars,
#' chains = 2, refresh = 0
#' )
#' p_significance(model)
#' }
#' @export
p_significance <- function(x, ...) {
UseMethod("p_significance")
}
#' @export
p_significance.default <- function(x, ...) {
insight::format_error(
paste0("'p_significance()' is not yet implemented for objects of class '", class(x)[1], "'.")
)
}
#' @rdname p_significance
#' @export
p_significance.numeric <- function(x, threshold = "default", ...) {
threshold <- .select_threshold_ps(threshold = threshold)
out <- p_significance(data.frame(Posterior = x), threshold = threshold)
attr(out, "data") <- x
out
}
#' @rdname p_significance
#' @export
p_significance.get_predicted <- function(x, threshold = "default", use_iterations = FALSE, verbose = TRUE, ...) {
if (isTRUE(use_iterations)) {
if ("iterations" %in% names(attributes(x))) {
out <- p_significance(
as.data.frame(t(attributes(x)$iterations)),
threshold = threshold,
verbose = verbose,
...
)
} else {
insight::format_error("No iterations present in the output.")
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
} else {
out <- p_significance(as.numeric(x),
threshold = threshold,
verbose = verbose,
...
)
}
out
}
#' @export
p_significance.data.frame <- function(x, threshold = "default", ...) {
obj_name <- insight::safe_deparse_symbol(substitute(x))
threshold <- .select_threshold_ps(threshold = threshold)
x <- .select_nums(x)
if (ncol(x) == 1) {
ps <- .p_significance(x[, 1], threshold = threshold, ...)
} else {
ps <- sapply(x, .p_significance, threshold = threshold, simplify = TRUE, ...)
}
out <- data.frame(
Parameter = names(x),
ps = as.numeric(ps),
row.names = NULL,
stringsAsFactors = FALSE
)
attr(out, "threshold") <- threshold
attr(out, "object_name") <- obj_name
class(out) <- unique(c("p_significance", "see_p_significance", class(out)))
out
}
#' @export
p_significance.draws <- function(x, threshold = "default", ...) {
p_significance(.posterior_draws_to_df(x), threshold = threshold, ...)
}
#' @export
p_significance.rvar <- p_significance.draws
#' @export
p_significance.parameters_simulate_model <- function(x, threshold = "default", ...) {
obj_name <- attr(x, "object_name")
if (!is.null(obj_name)) {
# first try, parent frame
model <- .safe(get(obj_name, envir = parent.frame()))
if (is.null(model)) {
# second try, global env
model <- .safe(get(obj_name, envir = globalenv()))
}
}
threshold <- .select_threshold_ps(model = model, threshold = threshold)
out <- p_significance.data.frame(x, threshold = threshold)
attr(out, "object_name") <- obj_name
out
}
#' @export
p_significance.MCMCglmm <- function(x, threshold = "default", ...) {
nF <- x$Fixed$nfl
out <- p_significance(as.data.frame(x$Sol[, 1:nF, drop = FALSE]), threshold = threshold, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_significance.BFBayesFactor <- function(x, threshold = "default", ...) {
out <- p_significance(insight::get_parameters(x), threshold = threshold, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_significance.mcmc <- function(x, threshold = "default", ...) {
p_significance(as.data.frame(x), threshold = threshold, ...)
}
#' @export
p_significance.bamlss <- function(x, threshold = "default", component = c("all", "conditional", "location"), ...) {
out <- p_significance(insight::get_parameters(x, component = component), threshold = threshold, ...)
out <- .add_clean_parameters_attribute(out, x)
out
}
#' @export
p_significance.bcplm <- function(x, threshold = "default", ...) {
p_significance(insight::get_parameters(x), threshold = threshold, ...)
}
#' @export
p_significance.mcmc.list <- p_significance.bcplm
#' @export
p_significance.bayesQR <- p_significance.bcplm
#' @export
p_significance.blrm <- p_significance.bcplm
#' @export
p_significance.BGGM <- p_significance.bcplm
#' @export
p_significance.emmGrid <- function(x, threshold = "default", ...) {
xdf <- insight::get_parameters(x)
out <- p_significance(xdf, threshold = threshold, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
p_significance.emm_list <- p_significance.emmGrid
#' @rdname p_significance
#' @export
p_significance.stanreg <- function(x,
threshold = "default",
effects = c("fixed", "random", "all"),
component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
threshold <- .select_threshold_ps(model = x, threshold = threshold, verbose = verbose)
data <- p_significance(
insight::get_parameters(x, effects = effects, component = component, parameters = parameters),
threshold = threshold
)
cleaned_parameters <- insight::clean_parameters(x)
out <- .prepare_output(data, cleaned_parameters, inherits(x, "stanmvreg"))
attr(out, "clean_parameters") <- cleaned_parameters
attr(out, "threshold") <- threshold
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(out) <- class(data)
out
}
#' @export
p_significance.stanfit <- p_significance.stanreg
#' @export
p_significance.blavaan <- p_significance.stanreg
#' @rdname p_significance
#' @export
p_significance.brmsfit <- function(x,
threshold = "default",
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
threshold <- .select_threshold_ps(model = x, threshold = threshold, verbose = verbose)
data <- p_significance(
insight::get_parameters(x, effects = effects, component = component, parameters = parameters),
threshold = threshold
)
cleaned_parameters <- insight::clean_parameters(x)
out <- .prepare_output(data, cleaned_parameters)
attr(out, "clean_parameters") <- cleaned_parameters
attr(out, "threshold") <- threshold
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(out) <- class(data)
out
}
.p_significance <- function(x, threshold, ...) {
psig <- max(
c(
length(x[x > abs(threshold)]) / length(x), # ps positive
length(x[x < -abs(threshold)]) / length(x) # ps negative
)
)
psig
}
# methods ---------------------------
#' @rdname as.numeric.p_direction
#' @export
as.numeric.p_significance <- function(x, ...) {
if (inherits(x, "data.frame")) {
return(as.numeric(as.vector(x$ps)))
} else {
return(as.vector(x))
}
}
#' @method as.double p_significance
#' @export
as.double.p_significance <- as.numeric.p_significance
# helpers --------------------------
#' @keywords internal
.select_threshold_ps <- function(model = NULL, threshold = "default", verbose = TRUE) {
# If a range is passed
if (length(threshold) > 1) {
if (length(unique(abs(threshold))) == 1) {
# If symmetric range
threshold <- abs(threshold[2])
} else {
insight::format_error("`threshold` should be 'default' or a numeric value (e.g., 0.1).")
}
}
# If default
if (all(threshold == "default")) {
if (is.null(model)) {
threshold <- 0.1
} else {
threshold <- rope_range(model, verbose = verbose)[2]
}
} else if (!all(is.numeric(threshold))) {
insight::format_error("`threshold` should be 'default' or a numeric value (e.g., 0.1).")
}
threshold
}
bayestestR/R/print_html.R 0000644 0001762 0000144 00000012443 14505754740 015122 0 ustar ligges users #' @export
print_html.describe_posterior <- function(x, digits = 2, caption = "Summary of Posterior Distribution", ...) {
.print_html_default(x = x, digits = digits, caption = caption, ...)
}
#' @export
print_html.point_estimate <- function(x, digits = 2, caption = "Point Estimate", ...) {
.print_html_default(x = x, digits = digits, caption = caption, ...)
}
#' @export
print_html.map_estimate <- function(x, digits = 2, caption = "MAP Estimate", ...) {
.print_html_default(x = x, digits = digits, caption = caption, ...)
}
#' @export
print_html.p_direction <- function(x, digits = 2, caption = "Probability of Direction (pd)", ...) {
.print_html_default(x = x, digits = digits, caption = caption, ...)
}
#' @export
print_html.p_map <- function(x, digits = 2, caption = "MAP-based p-value", ...) {
.print_html_default(x = x, digits = digits, caption = caption, ...)
}
#' @export
print_html.p_rope <- function(x, digits = 2, ...) {
caption <- sprintf(
"Proportion of samples inside the ROPE [%.*f, %.*f]",
digits, x$ROPE_low[1], digits, x$ROPE_high[1]
)
x$ROPE_low <- x$ROPE_high <- NULL
.print_html_default(x = x, digits = digits, caption = caption, ci_string = "ROPE", ...)
}
#' @export
print_html.p_significance <- function(x, digits = 2, ...) {
caption <- sprintf(
"Practical Significance (threshold: %s)",
insight::format_value(attributes(x)$threshold, digits = digits)
)
.print_html_default(x = x, digits = digits, caption = caption, ...)
}
#' @export
print_html.bayestestR_hdi <- function(x, digits = 2, caption = "Highest Density Interval", ...) {
.print_html_default(x = x, digits = digits, caption = caption, ci_string = "HDI", ...)
}
#' @export
print_html.bayestestR_eti <- function(x, digits = 2, caption = "Equal-Tailed Interval", ...) {
.print_html_default(x = x, digits = digits, caption = caption, ci_string = "ETI", ...)
}
#' @export
print_html.bayestestR_si <- function(x, digits = 2, caption = "Support Interval", ...) {
.print_html_default(x = x, digits = digits, caption = caption, ci_string = "SI", ...)
}
# special handling for bayes factors ------------------
#' @export
print_html.bayesfactor_models <- function(x,
digits = 3,
log = FALSE,
show_names = TRUE,
caption = "Bayes Factors for Model Comparison",
...) {
.print_bf_html_default(
x = x,
digits = digits,
log = log,
show_names = show_names,
caption = caption,
align = c("llr"),
...
)
}
#' @export
print_html.bayesfactor_inclusion <- function(x,
digits = 3,
log = FALSE,
caption = "Inclusion Bayes Factors (Model Averaged)",
...) {
.print_bf_html_default(
x = x,
digits = digits,
log = log,
caption = caption,
align = c("lrrr"),
...
)
}
#' @export
print_html.bayesfactor_restricted <- function(x,
digits = 3,
log = FALSE,
caption = "Bayes Factor (Order-Restriction)",
...) {
.print_bf_html_default(x = x, digits = digits, log = log, caption = caption, ...)
}
#' @export
print_html.bayesfactor_parameters <- function(x, digits = 3, log = FALSE, ...) {
# retrieve information with cleaned parameter names
cp <- attr(x, "clean_parameters")
# format data frame and columns
formatted_table <- format(
x,
cp = cp,
digits = digits,
log = log,
format = "html",
...
)
insight::export_table(formatted_table, format = "html")
}
# util ---------------
.print_html_default <- function(x, digits = 2, caption = NULL, subtitles = NULL, ci_string = "CI", ...) {
# retrieve information with cleaned parameter names
cp <- attr(x, "clean_parameters")
# format data frame and columns
formatted_table <- format(
x,
cp = cp,
digits = digits,
format = "html",
ci_string = ci_string,
caption = caption,
subtitles = subtitles,
...
)
# print for data frame - I don't think we need a special handling for
# numeric values to have a markdown-table output
insight::export_table(
formatted_table,
caption = caption,
format = "html"
)
}
.print_bf_html_default <- function(x,
digits = 3,
log = FALSE,
show_names = NULL,
caption = NULL,
align = NULL,
...) {
formatted_table <- format(
x,
digits = digits,
log = log,
show_names = show_names,
caption = caption,
format = "html",
...
)
insight::export_table(
formatted_table,
align = align,
caption = caption,
format = "html"
)
}
bayestestR/R/utils_check_collinearity.R 0000644 0001762 0000144 00000005201 14461433341 017777 0 ustar ligges users #' @keywords internal
.check_multicollinearity <- function(model,
method = "equivalence_test",
threshold = 0.7, ...) {
valid_parameters <- insight::find_parameters(
model,
parameters = "^(?!(r_|sd_|prior_|cor_|lp__|b\\[))",
flatten = TRUE
)
if (inherits(model, "stanfit")) {
dat <- insight::get_parameters(model)[, valid_parameters, drop = FALSE]
} else {
dat <- as.data.frame(model, optional = FALSE)[, valid_parameters, drop = FALSE]
}
# need at least three columns, one is removed anyway...
if (ncol(dat) > 2) {
dat <- dat[, -1, drop = FALSE]
if (ncol(dat) > 1) {
parameter_correlation <- stats::cor(dat)
parameter <- expand.grid(colnames(dat), colnames(dat), stringsAsFactors = FALSE)
results <- cbind(
parameter,
corr = abs(as.vector(expand.grid(parameter_correlation)[[1]])),
pvalue = apply(parameter, 1, function(r) stats::cor.test(dat[[r[1]]], dat[[r[2]]])$p.value)
)
# Filter
results <- results[results$pvalue < 0.05 & results$Var1 != results$Var2, ]
if (nrow(results) > 0) {
# Remove duplicates
results$where <- paste0(results$Var1, " and ", results$Var2)
results$where2 <- paste0(results$Var2, " and ", results$Var1)
to_remove <- NULL
for (i in seq_len(nrow(results))) {
if (results$where2[i] %in% results$where[1:i]) {
to_remove <- c(to_remove, i)
}
}
results <- results[-to_remove, ]
# Filter by first threshold
threshold <- pmin(threshold, 0.9)
results <- results[results$corr > threshold & results$corr <= 0.9, ]
if (nrow(results) > 0) {
where <- paste0("between ", toString(paste0(results$where, " (r = ", round(results$corr, 2), ")")), "")
insight::format_alert(paste0(
"Possible multicollinearity ",
where,
". This might lead to inappropriate results. See 'Details' in '?",
method,
"'."
))
}
# Filter by second threshold
results <- results[results$corr > 0.9, ]
if (nrow(results) > 0) {
where <- paste0("between ", toString(paste0(results$where, " (r = ", round(results$corr, 2), ")")), "")
insight::format_alert(paste0(
"Probable multicollinearity ",
where,
". This might lead to inappropriate results. See 'Details' in '?",
method,
"'."
))
}
}
}
}
}
bayestestR/R/map_estimate.R 0000644 0001762 0000144 00000014717 14560763455 015424 0 ustar ligges users #' Maximum A Posteriori probability estimate (MAP)
#'
#' Find the **Highest Maximum A Posteriori probability estimate (MAP)** of a
#' posterior, i.e., the value associated with the highest probability density
#' (the "peak" of the posterior distribution). In other words, it is an estimation
#' of the *mode* for continuous parameters. Note that this function relies on
#' [`estimate_density()`], which by default uses a different smoothing bandwidth
#' (`"SJ"`) compared to the legacy default implemented the base R [`density()`]
#' function (`"nrd0"`).
#'
#' @inheritParams hdi
#' @inheritParams estimate_density
#'
#' @return A numeric value if `x` is a vector. If `x` is a model-object,
#' returns a data frame with following columns:
#'
#' - `Parameter`: The model parameter(s), if `x` is a model-object. If `x` is a
#' vector, this column is missing.
#' - `MAP_Estimate`: The MAP estimate for the posterior or each model parameter.
#'
#' @examplesIf require("rstanarm") && require("brms")
#' \donttest{
#' library(bayestestR)
#'
#' posterior <- rnorm(10000)
#' map_estimate(posterior)
#'
#' plot(density(posterior))
#' abline(v = as.numeric(map_estimate(posterior)), col = "red")
#'
#' model <- rstanarm::stan_glm(mpg ~ wt + cyl, data = mtcars)
#' map_estimate(model)
#'
#' model <- brms::brm(mpg ~ wt + cyl, data = mtcars)
#' map_estimate(model)
#' }
#'
#' @export
map_estimate <- function(x, ...) {
UseMethod("map_estimate")
}
# numeric -----------------------
#' @rdname map_estimate
#' @export
map_estimate.numeric <- function(x, precision = 2^10, method = "kernel", ...) {
out <- map_estimate(data.frame(x = x),
precision,
method = method, ...
)
attr(out, "data") <- x
out
}
.map_estimate <- function(x, precision = 2^10, method = "kernel", ...) {
d <- estimate_density(x, precision = precision, method = method, ...)
out <- d$x[which.max(d$y)]
attr(out, "MAP_density") <- max(d$y)
out
}
# other models -----------------------
#' @export
map_estimate.bayesQR <- function(x, precision = 2^10, method = "kernel", ...) {
x <- insight::get_parameters(x)
map_estimate(x, precision = precision, method = method)
}
#' @export
map_estimate.BGGM <- map_estimate.bayesQR
#' @export
map_estimate.mcmc <- map_estimate.bayesQR
#' @export
map_estimate.bamlss <- map_estimate.bayesQR
#' @export
map_estimate.bcplm <- map_estimate.bayesQR
#' @export
map_estimate.blrm <- map_estimate.bayesQR
#' @export
map_estimate.mcmc.list <- map_estimate.bayesQR
# stan / posterior models -----------------------
#' @keywords internal
.map_estimate_models <- function(x, precision, method, ...) {
l <- sapply(x, .map_estimate, precision = precision, method = method, simplify = FALSE, ...)
out <- data.frame(
Parameter = colnames(x),
MAP_Estimate = unlist(l, use.names = FALSE),
stringsAsFactors = FALSE,
row.names = NULL
)
out <- .add_clean_parameters_attribute(out, x)
attr(out, "MAP_density") <- sapply(l, attr, "MAP_density")
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
attr(out, "centrality") <- "map"
class(out) <- unique(c("map_estimate", "see_point_estimate", class(out)))
out
}
#' @rdname map_estimate
#' @export
map_estimate.stanreg <- function(x, precision = 2^10, method = "kernel", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, ...) {
effects <- match.arg(effects)
component <- match.arg(component)
.map_estimate_models(
x = insight::get_parameters(x, effects = effects, component = component, parameters = parameters),
precision = precision,
method = method
)
}
#' @export
map_estimate.stanfit <- map_estimate.stanreg
#' @export
map_estimate.blavaan <- map_estimate.stanreg
#' @rdname map_estimate
#' @export
map_estimate.brmsfit <- function(x, precision = 2^10, method = "kernel", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, ...) {
effects <- match.arg(effects)
component <- match.arg(component)
.map_estimate_models(
x = insight::get_parameters(x, effects = effects, component = component, parameters = parameters),
precision = precision, method = method
)
}
#' @rdname map_estimate
#' @export
map_estimate.data.frame <- function(x, precision = 2^10, method = "kernel", ...) {
.map_estimate_models(x, precision = precision, method = method)
}
#' @export
map_estimate.draws <- function(x, precision = 2^10, method = "kernel", ...) {
.map_estimate_models(.posterior_draws_to_df(x), precision = precision, method = method)
}
#' @export
map_estimate.rvar <- map_estimate.draws
#' @export
map_estimate.emmGrid <- function(x, precision = 2^10, method = "kernel", ...) {
x <- insight::get_parameters(x)
.map_estimate_models(x, precision = precision, method = method)
}
#' @export
map_estimate.emm_list <- map_estimate.emmGrid
#' @rdname map_estimate
#' @export
map_estimate.get_predicted <- function(x,
precision = 2^10,
method = "kernel",
use_iterations = FALSE,
verbose = TRUE,
...) {
if (isTRUE(use_iterations)) {
if ("iterations" %in% names(attributes(x))) {
out <- map_estimate(
as.data.frame(t(attributes(x)$iterations)),
precision = precision,
method = method,
verbose = verbose,
...
)
} else {
insight::format_error("No iterations present in the output.")
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
} else {
out <- map_estimate(as.numeric(x),
precision = precision,
method = method,
verbose = verbose,
...
)
}
out
}
# Methods -----------------------------------------------------------------
#' @rdname as.numeric.p_direction
#' @method as.numeric map_estimate
#' @export
as.numeric.map_estimate <- function(x, ...) {
if (inherits(x, "data.frame")) {
me <- as.numeric(as.vector(x$MAP_Estimate))
names(me) <- x$Parameter
me
} else {
as.vector(x)
}
}
#' @method as.double map_estimate
#' @export
as.double.map_estimate <- as.numeric.map_estimate
bayestestR/R/si.R 0000644 0001762 0000144 00000024240 14650172354 013347 0 ustar ligges users #' Compute Support Intervals
#'
#' A support interval contains only the values of the parameter that predict the observed data better
#' than average, by some degree *k*; these are values of the parameter that are associated with an
#' updating factor greater or equal than *k*. From the perspective of the Savage-Dickey Bayes factor, testing
#' against a point null hypothesis for any value within the support interval will yield a Bayes factor smaller
#' than *1/k*.
#'
#' **For more info, in particular on specifying correct priors for factors with more than 2 levels,
#' see [the Bayes factors vignette](https://easystats.github.io/bayestestR/articles/bayes_factors.html).**
#'
#' @param BF The amount of support required to be included in the support interval.
#' @inheritParams bayesfactor_parameters
#' @inheritParams hdi
#' @inherit hdi seealso
#' @family ci
#'
#' @details This method is used to compute support intervals based on prior and posterior distributions.
#' For the computation of support intervals, the model priors must be proper priors (at the very least
#' they should be *not flat*, and it is preferable that they be *informative* - note
#' that by default, `brms::brm()` uses flat priors for fixed-effects; see example below).
#'
#' @section Choosing a value of `BF`:
#' The choice of `BF` (the level of support) depends on what we want our interval
#' to represent:
#'
#' - A `BF` = 1 contains values whose credibility is not decreased by observing the data.
#' - A `BF` > 1 contains values who received more impressive support from the data.
#' - A `BF` < 1 contains values whose credibility has *not* been impressively
#' decreased by observing the data. Testing against values outside this interval
#' will produce a Bayes factor larger than 1/`BF` in support of the alternative.
#' E.g., if an SI (BF = 1/3) excludes 0, the Bayes factor against the point-null
#' will be larger than 3.
#'
#' @inheritSection bayesfactor_parameters Setting the correct `prior`
#'
#' @note There is also a [`plot()`-method](https://easystats.github.io/see/articles/bayestestR.html) implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}.
#'
#' @return
#' A data frame containing the lower and upper bounds of the SI.
#'
#' Note that if the level of requested support is higher than observed in the data, the
#' interval will be `[NA,NA]`.
#'
#' @examplesIf require("logspline") && require("rstanarm") && require("brms") && require("emmeans")
#' library(bayestestR)
#'
#' prior <- distribution_normal(1000, mean = 0, sd = 1)
#' posterior <- distribution_normal(1000, mean = 0.5, sd = 0.3)
#'
#' si(posterior, prior, verbose = FALSE)
#' \donttest{
#' # rstanarm models
#' # ---------------
#' library(rstanarm)
#' contrasts(sleep$group) <- contr.equalprior_pairs # see vignette
#' stan_model <- stan_lmer(extra ~ group + (1 | ID), data = sleep)
#' si(stan_model, verbose = FALSE)
#' si(stan_model, BF = 3, verbose = FALSE)
#'
#' # emmGrid objects
#' # ---------------
#' library(emmeans)
#' group_diff <- pairs(emmeans(stan_model, ~group))
#' si(group_diff, prior = stan_model, verbose = FALSE)
#'
#' # brms models
#' # -----------
#' library(brms)
#' contrasts(sleep$group) <- contr.equalprior_pairs # see vingette
#' my_custom_priors <-
#' set_prior("student_t(3, 0, 1)", class = "b") +
#' set_prior("student_t(3, 0, 1)", class = "sd", group = "ID")
#'
#' brms_model <- suppressWarnings(brm(extra ~ group + (1 | ID),
#' data = sleep,
#' prior = my_custom_priors,
#' refresh = 0
#' ))
#' si(brms_model, verbose = FALSE)
#' }
#' @references
#' Wagenmakers, E., Gronau, Q. F., Dablander, F., & Etz, A. (2018, November 22).
#' The Support Interval. \doi{10.31234/osf.io/zwnxb}
#'
#' @export
si <- function(posterior, ...) {
UseMethod("si")
}
#' @rdname si
#' @export
si.numeric <- function(posterior, prior = NULL, BF = 1, verbose = TRUE, ...) {
if (is.null(prior)) {
prior <- posterior
if (verbose) {
insight::format_warning(
"Prior not specified!",
"Support intervals ('si') can only be computed for Bayesian models with proper priors.",
"Please specify priors (with column order matching 'posterior')."
)
}
}
prior <- data.frame(X = prior)
posterior <- data.frame(X = posterior)
# Get SIs
out <- si.data.frame(
posterior = posterior, prior = prior,
BF = BF, verbose = verbose, ...
)
out$Parameter <- NULL
out
}
#' @rdname si
#' @export
si.stanreg <- function(posterior, prior = NULL,
BF = 1, verbose = TRUE,
effects = c("fixed", "random", "all"),
component = c("location", "conditional", "all", "smooth_terms", "sigma", "auxiliary", "distributional"),
parameters = NULL,
...) {
cleaned_parameters <- insight::clean_parameters(posterior)
effects <- match.arg(effects)
component <- match.arg(component)
samps <- .clean_priors_and_posteriors(posterior, prior,
effects = effects, component = component,
parameters = parameters, verbose = verbose
)
# Get SIs
temp <- si.data.frame(
posterior = samps$posterior, prior = samps$prior,
BF = BF, verbose = verbose, ...
)
out <- .prepare_output(temp, cleaned_parameters, inherits(posterior, "stanmvreg"))
attr(out, "ci_method") <- "SI"
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior))
class(out) <- class(temp)
attr(out, "plot_data") <- attr(temp, "plot_data")
out
}
#' @rdname si
#' @export
si.brmsfit <- si.stanreg
#' @rdname si
#' @export
si.blavaan <- si.stanreg
#' @rdname si
#' @export
si.emmGrid <- function(posterior, prior = NULL,
BF = 1, verbose = TRUE, ...) {
samps <- .clean_priors_and_posteriors(posterior, prior, verbose = verbose)
# Get SIs
out <- si.data.frame(
posterior = samps$posterior, prior = samps$prior,
BF = BF, verbose = verbose, ...
)
attr(out, "ci_method") <- "SI"
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior))
out
}
#' @export
si.emm_list <- si.emmGrid
#' @export
si.stanfit <- function(posterior, prior = NULL, BF = 1, verbose = TRUE, effects = c("fixed", "random", "all"), ...) {
out <- si(insight::get_parameters(posterior, effects = effects),
prior = prior, BF = BF, verbose = verbose
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior))
out
}
#' @rdname si
#' @export
si.get_predicted <- function(posterior, prior = NULL, BF = 1, use_iterations = FALSE, verbose = TRUE, ...) {
if (isTRUE(use_iterations)) {
if ("iterations" %in% names(attributes(posterior))) {
out <- si(
as.data.frame(t(attributes(posterior)$iterations)),
prior = prior,
BF = BF,
verbose = verbose,
...
)
} else {
insight::format_error("No iterations present in the output.")
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior))
} else {
out <- si(insight::get_parameters(posterior), prior = prior, BF = BF, verbose = verbose, ...)
}
out
}
#' @rdname si
#' @export
si.data.frame <- function(posterior, prior = NULL, BF = 1, verbose = TRUE, ...) {
if (is.null(prior)) {
prior <- posterior
insight::format_warning(
"Prior not specified!",
"Support intervals ('si') can only be computed for Bayesian models with proper priors.",
"Please specify priors (with column order matching 'posterior')."
)
}
if (verbose && (nrow(posterior) < 4e4 || nrow(prior) < 4e4)) {
insight::format_warning(
"Support intervals might not be precise.",
"For precise support intervals, sampling at least 40,000 posterior samples is recommended."
)
}
out <- lapply(BF, function(BFi) {
.si.data.frame(posterior, prior, BFi, verbose = verbose)
})
out <- do.call(rbind, out)
attr(out, "ci_method") <- "SI"
attr(out, "ci") <- BF
attr(out, "plot_data") <- .make_BF_plot_data(posterior, prior, 0, 0, ...)$plot_data
class(out) <- unique(c("bayestestR_si", "see_si", "bayestestR_ci", "see_ci", class(out)))
out
}
#' @export
si.draws <- function(posterior, prior = NULL, BF = 1, verbose = TRUE, ...) {
si(.posterior_draws_to_df(posterior), prior = prior, BF = BF, verbose = verbose, ...)
}
#' @export
si.rvar <- si.draws
# Helper ------------------------------------------------------------------
.si.data.frame <- function(posterior, prior, BF, verbose = TRUE, ...) {
sis <- matrix(NA, nrow = ncol(posterior), ncol = 2)
for (par in seq_along(posterior)) {
sis[par, ] <- .si(posterior[[par]],
prior[[par]],
BF = BF,
verbose = verbose,
...
)
}
out <- data.frame(
Parameter = colnames(posterior),
CI = BF,
CI_low = sis[, 1],
CI_high = sis[, 2],
stringsAsFactors = FALSE
)
}
#' @keywords internal
.si <- function(posterior, prior, BF = 1, extend_scale = 0.05, precision = 2^8, verbose = TRUE, ...) {
insight::check_if_installed("logspline")
if (isTRUE(all.equal(prior, posterior))) {
return(c(NA, NA))
}
x <- c(prior, posterior)
x_range <- range(x)
x_rangex <- stats::median(x) + 7 * stats::mad(x) * c(-1, 1)
x_range <- c(
max(c(x_range[1], x_rangex[1])),
min(c(x_range[2], x_rangex[2]))
)
extension_scale <- diff(x_range) * extend_scale
x_range <- x_range + c(-1, 1) * extension_scale
x_axis <- seq(x_range[1], x_range[2], length.out = precision)
f_prior <- .logspline(prior, ...)
f_posterior <- .logspline(posterior, ...)
d_prior <- logspline::dlogspline(x_axis, f_prior)
d_posterior <- logspline::dlogspline(x_axis, f_posterior)
relative_d <- d_posterior / d_prior
crit <- relative_d >= BF
cp <- rle(stats::na.omit(crit))
if (length(cp$lengths) > 3 && verbose) {
insight::format_warning("More than 1 SI detected. Plot the result to investigate.")
}
x_supported <- stats::na.omit(x_axis[crit])
if (length(x_supported) < 2) {
return(c(NA, NA))
}
range(x_supported)
}
bayestestR/R/rope.R 0000644 0001762 0000144 00000050566 14560763455 013723 0 ustar ligges users #' Region of Practical Equivalence (ROPE)
#'
#' Compute the proportion of the HDI (default to the `89%` HDI) of a posterior
#' distribution that lies within a region of practical equivalence.
#'
#' @param x Vector representing a posterior distribution. Can also be a
#' `stanreg` or `brmsfit` model.
#' @param range ROPE's lower and higher bounds. Should be `"default"` or
#' depending on the number of outcome variables a vector or a list. In
#' models with one response, `range` should be a vector of length two (e.g.,
#' `c(-0.1, 0.1)`). In multivariate models, `range` should be a list with a
#' numeric vectors for each response variable. Vector names should correspond
#' to the name of the response variables. If `"default"` and input is a vector,
#' the range is set to `c(-0.1, 0.1)`. If `"default"` and input is a Bayesian
#' model, [`rope_range()`][rope_range] is used.
#' @param ci The Credible Interval (CI) probability, corresponding to the
#' proportion of HDI, to use for the percentage in ROPE.
#' @param ci_method The type of interval to use to quantify the percentage in
#' ROPE. Can be 'HDI' (default) or 'ETI'. See [ci()].
#'
#' @inheritParams hdi
#'
#' @section ROPE:
#' Statistically, the probability of a posterior distribution of being
#' different from 0 does not make much sense (the probability of a single value
#' null hypothesis in a continuous distribution is 0). Therefore, the idea
#' underlining ROPE is to let the user define an area around the null value
#' enclosing values that are *equivalent to the null* value for practical
#' purposes (_Kruschke 2010, 2011, 2014_).
#'
#' Kruschke (2018) suggests that such null value could be set, by default,
#' to the -0.1 to 0.1 range of a standardized parameter (negligible effect
#' size according to Cohen, 1988). This could be generalized: For instance,
#' for linear models, the ROPE could be set as `0 +/- .1 * sd(y)`.
#' This ROPE range can be automatically computed for models using the
#' [rope_range] function.
#'
#' Kruschke (2010, 2011, 2014) suggests using the proportion of the `95%`
#' (or `89%`, considered more stable) [HDI][hdi] that falls within the
#' ROPE as an index for "null-hypothesis" testing (as understood under the
#' Bayesian framework, see [`equivalence_test()`][equivalence_test]).
#'
#' @section Sensitivity to parameter's scale:
#' It is important to consider the unit (i.e., the scale) of the predictors
#' when using an index based on the ROPE, as the correct interpretation of the
#' ROPE as representing a region of practical equivalence to zero is dependent
#' on the scale of the predictors. Indeed, the percentage in ROPE depend on
#' the unit of its parameter. In other words, as the ROPE represents a fixed
#' portion of the response's scale, its proximity with a coefficient depends
#' on the scale of the coefficient itself.
#'
#' @section Multicollinearity - Non-independent covariates:
#' When parameters show strong correlations, i.e. when covariates are not
#' independent, the joint parameter distributions may shift towards or
#' away from the ROPE. Collinearity invalidates ROPE and hypothesis
#' testing based on univariate marginals, as the probabilities are conditional
#' on independence. Most problematic are parameters that only have partial
#' overlap with the ROPE region. In case of collinearity, the (joint) distributions
#' of these parameters may either get an increased or decreased ROPE, which
#' means that inferences based on `rope()` are inappropriate
#' (_Kruschke 2014, 340f_).
#'
#' `rope()` performs a simple check for pairwise correlations between
#' parameters, but as there can be collinearity between more than two variables,
#' a first step to check the assumptions of this hypothesis testing is to look
#' at different pair plots. An even more sophisticated check is the projection
#' predictive variable selection (_Piironen and Vehtari 2017_).
#'
#' @section Strengths and Limitations:
#' **Strengths:** Provides information related to the practical relevance of
#' the effects.
#'
#' **Limitations:** A ROPE range needs to be arbitrarily defined. Sensitive to
#' the scale (the unit) of the predictors. Not sensitive to highly significant
#' effects.
#'
#' @note There is also a [`plot()`-method](https://easystats.github.io/see/articles/bayestestR.html) implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}.
#'
#' @references
#' - Cohen, J. (1988). Statistical power analysis for the behavioural sciences.
#' - Kruschke, J. K. (2010). What to believe: Bayesian methods for data analysis.
#' Trends in cognitive sciences, 14(7), 293-300. \doi{10.1016/j.tics.2010.05.001}.
#' - Kruschke, J. K. (2011). Bayesian assessment of null values via parameter
#' estimation and model comparison. Perspectives on Psychological Science,
#' 6(3), 299-312. \doi{10.1177/1745691611406925}.
#' - Kruschke, J. K. (2014). Doing Bayesian data analysis: A tutorial with R,
#' JAGS, and Stan. Academic Press. \doi{10.1177/2515245918771304}.
#' - Kruschke, J. K. (2018). Rejecting or accepting parameter values in Bayesian
#' estimation. Advances in Methods and Practices in Psychological Science,
#' 1(2), 270-280. \doi{10.1177/2515245918771304}.
#' - Makowski D, Ben-Shachar MS, Chen SHA, Lüdecke D (2019) Indices of Effect
#' Existence and Significance in the Bayesian Framework. Frontiers in
#' Psychology 2019;10:2767. \doi{10.3389/fpsyg.2019.02767}
#' - Piironen, J., & Vehtari, A. (2017). Comparison of Bayesian predictive
#' methods for model selection. Statistics and Computing, 27(3), 711–735.
#' \doi{10.1007/s11222-016-9649-y}
#'
#' @examplesIf require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")
#' library(bayestestR)
#'
#' rope(x = rnorm(1000, 0, 0.01), range = c(-0.1, 0.1))
#' rope(x = rnorm(1000, 0, 1), range = c(-0.1, 0.1))
#' rope(x = rnorm(1000, 1, 0.01), range = c(-0.1, 0.1))
#' rope(x = rnorm(1000, 1, 1), ci = c(0.90, 0.95))
#' \donttest{
#' library(rstanarm)
#' model <- suppressWarnings(
#' stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0)
#' )
#' rope(model)
#' rope(model, ci = c(0.90, 0.95))
#'
#' library(emmeans)
#' rope(emtrends(model, ~1, "wt"), ci = c(0.90, 0.95))
#'
#' library(brms)
#' model <- brm(mpg ~ wt + cyl, data = mtcars)
#' rope(model)
#' rope(model, ci = c(0.90, 0.95))
#'
#' library(brms)
#' model <- brm(
#' bf(mvbind(mpg, disp) ~ wt + cyl) + set_rescor(rescor = TRUE),
#' data = mtcars
#' )
#' rope(model)
#' rope(model, ci = c(0.90, 0.95))
#'
#' library(BayesFactor)
#' bf <- ttestBF(x = rnorm(100, 1, 1))
#' rope(bf)
#' rope(bf, ci = c(0.90, 0.95))
#' }
#' @export
rope <- function(x, ...) {
UseMethod("rope")
}
#' @method as.double rope
#' @export
as.double.rope <- function(x, ...) {
x$ROPE_Percentage
}
#' @export
rope.default <- function(x, ...) {
NULL
}
#' @rdname rope
#' @export
rope.numeric <- function(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) {
if (all(range == "default")) {
range <- c(-0.1, 0.1)
} else if (!all(is.numeric(range)) || length(range) != 2) {
insight::format_error("`range` should be 'default' or a vector of 2 numeric values (e.g., c(-0.1, 0.1)).")
}
rope_values <- lapply(ci, function(i) {
.rope(x, range = range, ci = i, ci_method = ci_method, verbose = verbose)
})
# "do.call(rbind)" does not bind attribute values together
# so we need to capture the information about HDI separately
out <- do.call(rbind, rope_values)
if (nrow(out) > 1) {
out$ROPE_Percentage <- as.numeric(out$ROPE_Percentage)
}
# Attributes
hdi_area <- cbind(CI = ci, data.frame(do.call(rbind, lapply(rope_values, attr, "HDI_area"))))
names(hdi_area) <- c("CI", "CI_low", "CI_high")
attr(out, "HDI_area") <- hdi_area
attr(out, "data") <- x
class(out) <- unique(c("rope", "see_rope", class(out)))
out
}
#' @export
rope.get_predicted <- function(x,
range = "default",
ci = 0.95,
ci_method = "ETI",
use_iterations = FALSE,
verbose = TRUE,
...) {
if (isTRUE(use_iterations)) {
if ("iterations" %in% names(attributes(x))) {
out <- rope(
as.data.frame(t(attributes(x)$iterations)),
range = range,
ci = ci,
ci_method = ci_method,
verbose = verbose,
...
)
} else {
insight::format_error("No iterations present in the output.")
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
} else {
out <- rope(as.numeric(x), range = range, ci = ci, ci_method = ci_method, verbose = verbose, ...)
}
out
}
#' @export
rope.data.frame <- function(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) {
out <- .prepare_rope_df(x, range, ci, ci_method, verbose)
HDI_area_attributes <- insight::compact_list(out$HDI_area)
dat <- data.frame(
Parameter = rep(names(HDI_area_attributes), each = length(ci)),
out$tmp,
stringsAsFactors = FALSE
)
row.names(dat) <- NULL
attr(dat, "HDI_area") <- HDI_area_attributes
attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(dat) <- c("rope", "see_rope", "data.frame")
dat
}
#' @export
rope.draws <- function(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) {
rope(.posterior_draws_to_df(x), range = range, ci = ci, ci_method = ci_method, verbose = verbose, ...)
}
#' @export
rope.rvar <- rope.draws
#' @export
rope.emmGrid <- function(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) {
xdf <- insight::get_parameters(x)
dat <- rope(xdf, range = range, ci = ci, ci_method = ci_method, verbose = verbose, ...)
attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
rope.emm_list <- rope.emmGrid
#' @export
rope.BFBayesFactor <- function(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) {
if (all(range == "default")) {
range <- rope_range(x, verbose = verbose)
}
out <- rope(insight::get_parameters(x), range = range, ci = ci, ci_method = ci_method, verbose = verbose, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
rope.bamlss <- rope.BFBayesFactor
#' @export
rope.MCMCglmm <- function(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) {
nF <- x$Fixed$nfl
out <- rope(
as.data.frame(x$Sol[, 1:nF, drop = FALSE]),
range = range,
ci = ci,
ci_method = ci_method,
verbose = verbose,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
rope.mcmc <- function(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) {
out <- rope(as.data.frame(x), range = range, ci = ci, ci_method = ci_method, verbose = verbose, ...)
attr(out, "object_name") <- NULL
attr(out, "data") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
rope.bcplm <- function(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) {
out <- rope(insight::get_parameters(x), range = range, ci = ci, ci_method = ci_method, verbose = verbose, ...)
attr(out, "object_name") <- NULL
attr(out, "data") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
rope.bayesQR <- rope.bcplm
#' @export
rope.blrm <- rope.bcplm
#' @export
rope.BGGM <- rope.bcplm
#' @export
rope.mcmc.list <- rope.bcplm
#' @keywords internal
.rope <- function(x, range = c(-0.1, 0.1), ci = 0.95, ci_method = "ETI", verbose = TRUE) {
ci_bounds <- ci(x, ci = ci, method = ci_method, verbose = verbose)
if (anyNA(ci_bounds)) {
rope_percentage <- NA
} else {
HDI_area <- x[x >= ci_bounds$CI_low & x <= ci_bounds$CI_high]
area_within <- HDI_area[HDI_area >= min(range) & HDI_area <= max(range)]
rope_percentage <- length(area_within) / length(HDI_area)
}
rope <- data.frame(
CI = ci,
ROPE_low = range[1],
ROPE_high = range[2],
ROPE_Percentage = rope_percentage
)
attr(rope, "HDI_area") <- c(ci_bounds$CI_low, ci_bounds$CI_high)
attr(rope, "CI_bounds") <- c(ci_bounds$CI_low, ci_bounds$CI_high)
class(rope) <- unique(c("rope", "see_rope", class(rope)))
rope
}
#' @rdname rope
#' @export
rope.stanreg <- function(x, range = "default", ci = 0.95, ci_method = "ETI", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = TRUE, ...) {
effects <- match.arg(effects)
component <- match.arg(component)
if (all(range == "default")) {
range <- rope_range(x, verbose = verbose)
} else if (!all(is.numeric(range)) || length(range) != 2) {
insight::format_error("`range` should be 'default' or a vector of 2 numeric values (e.g., c(-0.1, 0.1)).")
}
# check for possible collinearity that might bias ROPE
if (verbose && !inherits(x, "blavaan")) .check_multicollinearity(x, "rope")
rope_data <- rope(
insight::get_parameters(x, effects = effects, component = component, parameters = parameters),
range = range,
ci = ci,
ci_method = ci_method,
verbose = verbose,
...
)
out <- .prepare_output(rope_data, insight::clean_parameters(x), inherits(x, "stanmvreg"))
attr(out, "HDI_area") <- attr(rope_data, "HDI_area")
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(out) <- class(rope_data)
out
}
#' @export
rope.stanfit <- rope.stanreg
#' @export
rope.blavaan <- rope.stanreg
#' @rdname rope
#' @export
rope.brmsfit <- function(x,
range = "default",
ci = 0.95,
ci_method = "ETI",
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
# check range argument
if (all(range == "default")) {
range <- rope_range(x, verbose = verbose)
# we expect a list with named vectors (length two) in the multivariate case.
# Names state the response variable.
} else if (insight::is_multivariate(x)) {
if (
!is.list(range) ||
length(range) < length(insight::find_response(x)) ||
!all(names(range) %in% insight::find_response(x))
) {
insight::format_error(
"With a multivariate model, `range` should be 'default' or a list of named numeric vectors with length 2."
)
}
} else if (!all(is.numeric(range)) || length(range) != 2) {
insight::format_error(
"`range` should be 'default' or a vector of 2 numeric values (e.g., c(-0.1, 0.1))."
)
}
# check for possible collinearity that might bias ROPE and print a warning
if (verbose) .check_multicollinearity(x, "rope")
# calc rope
if (insight::is_multivariate(x)) {
dv <- insight::find_response(x)
# ROPE range / width differs between response varialbe. Thus ROPE is
# calculated for every variable on its own.
rope_data <- lapply(
dv,
function(dv_item) {
ret <- rope(
insight::get_parameters(x, effects = effects, component = component, parameters = parameters),
range = range[[dv_item]],
ci = ci,
ci_method = ci_method,
verbose = verbose,
...
)
# It's a waste of performance to calculate ROPE for all parameters
# with the ROPE width of a specific response variable and to throw
# away the unwanted results. However, performance impact should not be
# too high and this way it is much easier to handle the `parameters`
# argument.
ret[grepl(paste0("(.*)", dv_item), ret$Parameter), ]
}
)
rope_data <- do.call(rbind, rope_data)
out <- .prepare_output(rope_data, insight::clean_parameters(x), is_brms_mv = TRUE)
} else {
rope_data <- rope(
insight::get_parameters(x, effects = effects, component = component, parameters = parameters),
range = range,
ci = ci,
ci_method = ci_method,
verbose = verbose,
...
)
out <- .prepare_output(rope_data, insight::clean_parameters(x))
}
attr(out, "HDI_area") <- attr(rope_data, "HDI_area")
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(out) <- class(rope_data)
out
}
#' @export
rope.sim.merMod <- function(x,
range = "default",
ci = 0.95,
ci_method = "ETI",
effects = c("fixed", "random", "all"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
if (all(range == "default")) {
range <- rope_range(x, verbose = verbose)
} else if (!all(is.numeric(range)) || length(range) != 2) {
insight::format_error("`range` should be 'default' or a vector of 2 numeric values (e.g., c(-0.1, 0.1)).")
}
list <- lapply(c("fixed", "random"), function(.x) {
parms <- insight::get_parameters(x, effects = .x, parameters = parameters)
getropedata <- .prepare_rope_df(parms, range, ci, ci_method, verbose)
tmp <- getropedata$tmp
HDI_area <- getropedata$HDI_area
if (insight::is_empty_object(tmp)) {
tmp <- NULL
} else {
tmp <- .clean_up_tmp_stanreg(
tmp,
group = .x,
cols = c("CI", "ROPE_low", "ROPE_high", "ROPE_Percentage", "Group"),
parms = names(parms)
)
if (!insight::is_empty_object(HDI_area)) {
attr(tmp, "HDI_area") <- HDI_area
}
}
tmp
})
dat <- do.call(rbind, args = c(insight::compact_list(list), make.row.names = FALSE))
dat <- switch(effects,
fixed = .select_rows(dat, "Group", "fixed"),
random = .select_rows(dat, "Group", "random"),
dat
)
if (all(dat$Group == dat$Group[1])) {
dat <- datawizard::data_remove(dat, "Group", verbose = FALSE)
}
HDI_area_attributes <- lapply(insight::compact_list(list), attr, "HDI_area")
if (effects != "all") {
HDI_area_attributes <- HDI_area_attributes[[1]]
} else {
names(HDI_area_attributes) <- c("fixed", "random")
}
attr(dat, "HDI_area") <- HDI_area_attributes
attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @export
rope.sim <- function(x, range = "default", ci = 0.95, ci_method = "ETI", parameters = NULL, verbose = TRUE, ...) {
if (all(range == "default")) {
range <- rope_range(x, verbose = verbose)
} else if (!all(is.numeric(range)) || length(range) != 2) {
insight::format_error("`range` should be 'default' or a vector of 2 numeric values (e.g., c(-0.1, 0.1)).")
}
parms <- insight::get_parameters(x, parameters = parameters)
getropedata <- .prepare_rope_df(parms, range, ci, ci_method, verbose)
dat <- getropedata$tmp
HDI_area <- getropedata$HDI_area
if (insight::is_empty_object(dat)) {
dat <- NULL
} else {
dat <- .clean_up_tmp_stanreg(
dat,
group = "fixed",
cols = c("CI", "ROPE_low", "ROPE_high", "ROPE_Percentage"),
parms = names(parms)
)
if (!insight::is_empty_object(HDI_area)) {
attr(dat, "HDI_area") <- HDI_area
}
}
attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
dat
}
#' @keywords internal
.prepare_rope_df <- function(parms, range, ci, ci_method, verbose) {
tmp <- sapply(
parms,
rope,
range = range,
ci = ci,
ci_method = ci_method,
verbose = verbose,
simplify = FALSE
)
HDI_area <- lapply(tmp, attr, which = "HDI_area")
# HDI_area <- lapply(HDI_area, function(.x) {
# dat <- cbind(CI = ci, data.frame(do.call(rbind, .x)))
# colnames(dat) <- c("CI", "HDI_low", "HDI_high")
# dat
# })
list(
tmp = do.call(rbind, tmp),
HDI_area = HDI_area
)
}
bayestestR/R/bayesfactor_restricted.R 0000644 0001762 0000144 00000021716 14561127323 017470 0 ustar ligges users #' Bayes Factors (BF) for Order Restricted Models
#'
#' This method computes Bayes factors for comparing a model with an order restrictions on its parameters
#' with the fully unrestricted model. *Note that this method should only be used for confirmatory analyses*.
#' \cr \cr
#' The `bf_*` function is an alias of the main function.
#' \cr \cr
#' \strong{For more info, in particular on specifying correct priors for factors with more than 2 levels,
#' see [the Bayes factors vignette](https://easystats.github.io/bayestestR/articles/bayes_factors.html).}
#'
#' @param posterior A `stanreg` / `brmsfit` object, `emmGrid` or a data frame - representing
#' a posterior distribution(s) from (see Details).
#' @param hypothesis A character vector specifying the restrictions as logical conditions (see examples below).
#' @param prior An object representing a prior distribution (see Details).
#' @inheritParams hdi
#'
#' @details This method is used to compute Bayes factors for order-restricted models vs un-restricted
#' models by setting an order restriction on the prior and posterior distributions
#' (\cite{Morey & Wagenmakers, 2013}).
#' \cr\cr
#' (Though it is possible to use `bayesfactor_restricted()` to test interval restrictions,
#' it is more suitable for testing order restrictions; see examples).
#'
#' @inheritSection bayesfactor_parameters Setting the correct `prior`
#'
#' @inheritSection bayesfactor_parameters Interpreting Bayes Factors
#'
#' @return A data frame containing the (log) Bayes factor representing evidence
#' *against* the un-restricted model (Use `as.numeric()` to extract the
#' non-log Bayes factors; see examples). (A `bool_results` attribute contains
#' the results for each sample, indicating if they are included or not in the
#' hypothesized restriction.)
#'
#' @examples
#' set.seed(444)
#' library(bayestestR)
#' prior <- data.frame(
#' A = rnorm(500),
#' B = rnorm(500),
#' C = rnorm(500)
#' )
#'
#' posterior <- data.frame(
#' A = rnorm(500, .4, 0.7),
#' B = rnorm(500, -.2, 0.4),
#' C = rnorm(500, 0, 0.5)
#' )
#'
#' hyps <- c(
#' "A > B & B > C",
#' "A > B & A > C",
#' "C > A"
#' )
#'
#'
#' (b <- bayesfactor_restricted(posterior, hypothesis = hyps, prior = prior))
#'
#' bool <- as.logical(b, which = "posterior")
#' head(bool)
#'
#' @examplesIf require("see") && require("patchwork")
#'
#' see::plots(
#' plot(estimate_density(posterior)),
#' # distribution **conditional** on the restrictions
#' plot(estimate_density(posterior[bool[, hyps[1]], ])) + ggplot2::ggtitle(hyps[1]),
#' plot(estimate_density(posterior[bool[, hyps[2]], ])) + ggplot2::ggtitle(hyps[2]),
#' plot(estimate_density(posterior[bool[, hyps[3]], ])) + ggplot2::ggtitle(hyps[3]),
#' guides = "collect"
#' )
#'
#' @examplesIf require("rstanarm")
#' \donttest{
#' # rstanarm models
#' # ---------------
#' data("mtcars")
#'
#' fit_stan <- rstanarm::stan_glm(mpg ~ wt + cyl + am,
#' data = mtcars, refresh = 0
#' )
#' hyps <- c(
#' "am > 0 & cyl < 0",
#' "cyl < 0",
#' "wt - cyl > 0"
#' )
#'
#' bayesfactor_restricted(fit_stan, hypothesis = hyps)
#' }
#'
#' @examplesIf require("rstanarm") && require("emmeans")
#' \donttest{
#' # emmGrid objects
#' # ---------------
#' # replicating http://bayesfactor.blogspot.com/2015/01/multiple-comparisons-with-bayesfactor-2.html
#' data("disgust")
#' contrasts(disgust$condition) <- contr.equalprior_pairs # see vignette
#' fit_model <- rstanarm::stan_glm(score ~ condition, data = disgust, family = gaussian())
#'
#' em_condition <- emmeans::emmeans(fit_model, ~condition, data = disgust)
#' hyps <- c("lemon < control & control < sulfur")
#'
#' bayesfactor_restricted(em_condition, prior = fit_model, hypothesis = hyps)
#' # > # Bayes Factor (Order-Restriction)
#' # >
#' # > Hypothesis P(Prior) P(Posterior) BF
#' # > lemon < control & control < sulfur 0.17 0.75 4.49
#' # > ---
#' # > Bayes factors for the restricted model vs. the un-restricted model.
#' }
#'
#' @references
#' - Morey, R. D., & Wagenmakers, E. J. (2014). Simple relation between Bayesian order-restricted and
#' point-null hypothesis tests. Statistics & Probability Letters, 92, 121-124.
#' - Morey, R. D., & Rouder, J. N. (2011). Bayes factor approaches for testing interval null hypotheses.
#' Psychological methods, 16(4), 406.
#' - Morey, R. D. (Jan, 2015). Multiple Comparisons with BayesFactor, Part 2 – order restrictions.
#' Retrieved from https://richarddmorey.org/category/order-restrictions/.
#'
#' @export
bayesfactor_restricted <- function(posterior, hypothesis, prior = NULL, verbose = TRUE, ...) {
UseMethod("bayesfactor_restricted")
}
#' @rdname bayesfactor_restricted
#' @export
bf_restricted <- bayesfactor_restricted
#' @rdname bayesfactor_restricted
#' @export
bayesfactor_restricted.stanreg <- function(posterior, hypothesis, prior = NULL,
verbose = TRUE,
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
...) {
effects <- match.arg(effects)
component <- match.arg(component)
samps <- .clean_priors_and_posteriors(posterior, prior,
effects = effects, component = component,
verbose = verbose
)
# Get savage-dickey BFs
bayesfactor_restricted.data.frame(
posterior = samps$posterior, prior = samps$prior,
hypothesis = hypothesis
)
}
#' @rdname bayesfactor_restricted
#' @export
bayesfactor_restricted.brmsfit <- bayesfactor_restricted.stanreg
#' @rdname bayesfactor_restricted
#' @export
bayesfactor_restricted.blavaan <- function(posterior, hypothesis, prior = NULL,
verbose = TRUE, ...) {
samps <- .clean_priors_and_posteriors(posterior, prior,
verbose = verbose
)
# Get savage-dickey BFs
bayesfactor_restricted.data.frame(
posterior = samps$posterior, prior = samps$prior,
hypothesis = hypothesis
)
}
#' @rdname bayesfactor_restricted
#' @export
bayesfactor_restricted.emmGrid <- function(posterior, hypothesis, prior = NULL,
verbose = TRUE,
...) {
samps <- .clean_priors_and_posteriors(posterior, prior,
verbose = verbose
)
bayesfactor_restricted.data.frame(
posterior = samps$posterior, prior = samps$prior,
hypothesis = hypothesis
)
}
#' @export
bayesfactor_restricted.emm_list <- bayesfactor_restricted.emmGrid
#' @export
bayesfactor_restricted.data.frame <- function(posterior, hypothesis, prior = NULL, ...) {
p_hypothesis <- parse(text = hypothesis)
if (is.null(prior)) {
prior <- posterior
insight::format_warning(
"Prior not specified! ",
"Please specify priors (with column names matching 'posterior')",
" to get meaningful results."
)
}
.test_hypothesis <- function(x, data) {
x_logical <- try(eval(x, envir = data), silent = TRUE)
if (inherits(x_logical, "try-error")) {
cnames <- colnames(data)
is_name <- make.names(cnames) == cnames
cnames[!is_name] <- paste0("`", cnames[!is_name], "`")
insight::format_error(
x_logical,
paste("Available parameters are:", toString(cnames))
)
} else if (!all(is.logical(x_logical))) {
insight::format_error("Hypotheses must be logical.")
}
x_logical
}
posterior_l <- as.data.frame(lapply(p_hypothesis, .test_hypothesis, data = posterior))
prior_l <- as.data.frame(lapply(p_hypothesis, .test_hypothesis, data = prior))
colnames(posterior_l) <- colnames(prior_l) <- if (is.null(names(hypothesis))) hypothesis else names(hypothesis)
posterior_p <- sapply(posterior_l, mean)
prior_p <- sapply(prior_l, mean)
log_BF <- log(posterior_p) - log(prior_p)
res <- data.frame(
Hypothesis = hypothesis,
p_prior = prior_p,
p_posterior = posterior_p,
log_BF = log_BF
)
attr(res, "bool_results") <- list(posterior = posterior_l, prior = prior_l)
class(res) <- unique(c(
"bayesfactor_restricted",
class(res)
))
res
}
#' @export
bayesfactor_restricted.draws <- function(posterior, hypothesis, prior = NULL, ...) {
bayesfactor_restricted(.posterior_draws_to_df(posterior), hypothesis = hypothesis, prior = prior, ...)
}
#' @export
bayesfactor_restricted.rvar <- bayesfactor_restricted.draws
# Methods -----------------------------------------------------------------
#' @export
#' @rdname bayesfactor_restricted
#' @param x An object of class `bayesfactor_restricted`
#' @param which Should the logical matrix be of the posterior or prior distribution(s)?
as.logical.bayesfactor_restricted <- function(x, which = c("posterior", "prior"), ...) {
which <- match.arg(which)
as.matrix(attr(x, "bool_results")[[which]])
}
bayestestR/R/mediation.R 0000644 0001762 0000144 00000032417 14650172354 014712 0 ustar ligges users #' @title Summary of Bayesian multivariate-response mediation-models
#' @name mediation
#'
#' @description `mediation()` is a short summary for multivariate-response
#' mediation-models, i.e. this function computes average direct and average
#' causal mediation effects of multivariate response models.
#'
#' @param model A `brmsfit` or `stanmvreg` object.
#' @param treatment Character, name of the treatment variable (or direct effect)
#' in a (multivariate response) mediator-model. If missing, `mediation()`
#' tries to find the treatment variable automatically, however, this may fail.
#' @param mediator Character, name of the mediator variable in a (multivariate
#' response) mediator-model. If missing, `mediation()` tries to find the
#' treatment variable automatically, however, this may fail.
#' @param response A named character vector, indicating the names of the response
#' variables to be used for the mediation analysis. Usually can be `NULL`,
#' in which case these variables are retrieved automatically. If not `NULL`,
#' names should match the names of the model formulas,
#' `names(insight::find_response(model, combine = TRUE))`. This can be
#' useful if, for instance, the mediator variable used as predictor has a different
#' name from the mediator variable used as response. This might occur when the
#' mediator is transformed in one model, but used "as is" as response variable
#' in the other model. Example: The mediator `m` is used as response variable,
#' but the centered version `m_center` is used as mediator variable. The
#' second response variable (for the treatment model, with the mediator as
#' additional predictor), `y`, is not transformed. Then we could use
#' `response` like this: `mediation(model, response = c(m = "m_center", y = "y"))`.
#' @param ... Not used.
#' @inheritParams ci
#' @inheritParams describe_posterior
#'
#' @return A data frame with direct, indirect, mediator and
#' total effect of a multivariate-response mediation-model, as well as the
#' proportion mediated. The effect sizes are median values of the posterior
#' samples (use `centrality` for other centrality indices).
#'
#' @details `mediation()` returns a data frame with information on the
#' *direct effect* (mean value of posterior samples from `treatment`
#' of the outcome model), *mediator effect* (mean value of posterior
#' samples from `mediator` of the outcome model), *indirect effect*
#' (mean value of the multiplication of the posterior samples from
#' `mediator` of the outcome model and the posterior samples from
#' `treatment` of the mediation model) and the total effect (mean
#' value of sums of posterior samples used for the direct and indirect
#' effect). The *proportion mediated* is the indirect effect divided
#' by the total effect.
#'
#' For all values, the `89%` credible intervals are calculated by default.
#' Use `ci` to calculate a different interval.
#'
#' The arguments `treatment` and `mediator` do not necessarily
#' need to be specified. If missing, `mediation()` tries to find the
#' treatment and mediator variable automatically. If this does not work,
#' specify these variables.
#'
#' The direct effect is also called *average direct effect* (ADE),
#' the indirect effect is also called *average causal mediation effects*
#' (ACME). See also _Tingley et al. 2014_ and _Imai et al. 2010_.
#'
#' @note There is an `as.data.frame()` method that returns the posterior
#' samples of the effects, which can be used for further processing in the
#' different \pkg{bayestestR} package.
#'
#' @references
#'
#' - Imai, K., Keele, L. and Tingley, D. (2010) A General Approach to Causal
#' Mediation Analysis, Psychological Methods, Vol. 15, No. 4 (December), pp.
#' 309-334.
#'
#' - Tingley, D., Yamamoto, T., Hirose, K., Imai, K. and Keele, L. (2014).
#' mediation: R package for Causal Mediation Analysis, Journal of Statistical
#' Software, Vol. 59, No. 5, pp. 1-38.
#'
#' @seealso The \pkg{mediation} package for a causal mediation analysis in
#' the frequentist framework.
#'
#' @examplesIf require("mediation") && require("brms") && require("rstanarm")
#' \donttest{
#' library(mediation)
#' library(brms)
#' library(rstanarm)
#'
#' # load sample data
#' data(jobs)
#' set.seed(123)
#'
#' # linear models, for mediation analysis
#' b1 <- lm(job_seek ~ treat + econ_hard + sex + age, data = jobs)
#' b2 <- lm(depress2 ~ treat + job_seek + econ_hard + sex + age, data = jobs)
#' # mediation analysis, for comparison with Stan models
#' m1 <- mediate(b1, b2, sims = 1000, treat = "treat", mediator = "job_seek")
#'
#' # Fit Bayesian mediation model in brms
#' f1 <- bf(job_seek ~ treat + econ_hard + sex + age)
#' f2 <- bf(depress2 ~ treat + job_seek + econ_hard + sex + age)
#' m2 <- brm(f1 + f2 + set_rescor(FALSE), data = jobs, refresh = 0)
#'
#' # Fit Bayesian mediation model in rstanarm
#' m3 <- suppressWarnings(stan_mvmer(
#' list(
#' job_seek ~ treat + econ_hard + sex + age + (1 | occp),
#' depress2 ~ treat + job_seek + econ_hard + sex + age + (1 | occp)
#' ),
#' data = jobs,
#' refresh = 0
#' ))
#'
#' summary(m1)
#' mediation(m2, centrality = "mean", ci = 0.95)
#' mediation(m3, centrality = "mean", ci = 0.95)
#' }
#' @export
mediation <- function(model, ...) {
UseMethod("mediation")
}
#' @rdname mediation
#' @export
mediation.brmsfit <- function(model,
treatment,
mediator,
response = NULL,
centrality = "median",
ci = 0.95,
method = "ETI",
...) {
.mediation(
model = model,
treatment = treatment,
mediator = mediator,
response = response,
centrality = centrality,
ci = ci,
method = method,
pattern = "b_%s_%s",
...
)
}
#' @rdname mediation
#' @export
mediation.stanmvreg <- function(model, treatment, mediator, response = NULL, centrality = "median", ci = 0.95, method = "ETI", ...) {
.mediation(
model = model,
treatment = treatment,
mediator = mediator,
response = response,
centrality = centrality,
ci = ci,
method = method,
pattern = "%s|%s",
...
)
}
# workhorse ---------------------------------
.mediation <- function(model,
treatment,
mediator,
response = NULL,
centrality = "median",
ci = 0.95,
method = "ETI",
pattern = "b_%s_%s",
...) {
# only one HDI interval
if (length(ci) > 1) ci <- ci[1]
# check for binary response. In this case, user should rescale variables
modelinfo <- insight::model_info(model)
if (any(sapply(modelinfo, function(i) i$is_binomial, simplify = TRUE))) {
insight::format_alert("One of moderator or outcome is binary, so direct and indirect effects may be on different scales. Consider rescaling model predictors, e.g. with `effectsize::standardize()`.")
}
# model responses
if (is.null(response)) {
response <- insight::find_response(model, combine = TRUE)
}
fix_mediator <- FALSE
# find mediator, if not specified
if (missing(mediator)) {
predictors <- insight::find_predictors(model, flatten = TRUE)
mediator <- predictors[predictors %in% response]
fix_mediator <- TRUE
}
# find treatment, if not specified
if (missing(treatment)) {
predictors <- lapply(
insight::find_predictors(model),
function(.f) .f$conditional
)
treatment <- predictors[[1]][predictors[[1]] %in% predictors[[2]]][1]
treatment <- .fix_factor_name(model, treatment)
}
mediator.model <- which(response == mediator)
treatment.model <- which(response != mediator)
if (fix_mediator) mediator <- .fix_factor_name(model, mediator)
if (inherits(model, "brmsfit")) {
response_name <- names(response)
} else {
response_name <- unname(response)
}
# brms removes underscores from variable names when naming estimates
# so we need to fix variable names here
response <- names(response)
# Direct effect: coef(treatment) from model_y_treatment
coef_treatment <- sprintf(pattern, response[treatment.model], treatment)
effect_direct <- insight::get_parameters(model)[[coef_treatment]]
# Mediator effect: coef(mediator) from model_y_treatment
coef_mediator <- sprintf(pattern, response[treatment.model], mediator)
effect_mediator <- insight::get_parameters(model)[[coef_mediator]]
# Indirect effect: coef(treament) from model_m_mediator * coef(mediator) from model_y_treatment
coef_indirect <- sprintf(pattern, response[mediator.model], treatment)
tmp.indirect <- insight::get_parameters(model)[c(coef_indirect, coef_mediator)]
effect_indirect <- tmp.indirect[[coef_indirect]] * tmp.indirect[[coef_mediator]]
# Total effect
effect_total <- effect_indirect + effect_direct
# proportion mediated: indirect effect / total effect
proportion_mediated <- as.numeric(point_estimate(effect_indirect, centrality = centrality)) / as.numeric(point_estimate(effect_total, centrality = centrality))
hdi_eff <- ci(effect_indirect / effect_total, ci = ci, method = method)
prop_mediated_se <- (hdi_eff$CI_high - hdi_eff$CI_low) / 2
prop_mediated_ci <- proportion_mediated + c(-1, 1) * prop_mediated_se
res <- cbind(
data.frame(
Effect = c("Direct Effect (ADE)", "Indirect Effect (ACME)", "Mediator Effect", "Total Effect", "Proportion Mediated"),
Estimate = c(
as.numeric(point_estimate(effect_direct, centrality = centrality)),
as.numeric(point_estimate(effect_indirect, centrality = centrality)),
as.numeric(point_estimate(effect_mediator, centrality = centrality)),
as.numeric(point_estimate(effect_total, centrality = centrality)),
proportion_mediated
),
stringsAsFactors = FALSE
),
as.data.frame(rbind(
ci(effect_direct, ci = ci, method = method)[, -1],
ci(effect_indirect, ci = ci, method = method)[, -1],
ci(effect_mediator, ci = ci, method = method)[, -1],
ci(effect_total, ci = ci, method = method)[, -1],
prop_mediated_ci
))
)
colnames(res) <- c("Effect", "Estimate", "CI_low", "CI_high")
samples <- data.frame(
effect_direct,
effect_indirect,
effect_mediator,
effect_total,
proportion_mediated = effect_indirect / effect_total
)
attr(res, "ci") <- ci
attr(res, "ci_method") <- method
attr(res, "treatment") <- treatment
attr(res, "mediator") <- mediator
attr(res, "response") <- response_name[treatment.model]
attr(res, "data") <- samples
class(res) <- c("bayestestR_mediation", "see_bayestestR_mediation", class(res))
res
}
# methods ---------------------
#' @export
as.data.frame.bayestestR_mediation <- function(x, ...) {
attributes(x)$data
}
# helper ---------------------------------
.fix_factor_name <- function(model, variable) {
# check for categorical. if user has not specified a treatment variable
# and this variable is categorical, the posterior samples contain the
# samples from each category of the treatment variable - so we need to
# fix the variable name
mf <- insight::get_data(model)
if (variable %in% colnames(mf)) {
check_fac <- mf[[variable]]
if (is.factor(check_fac)) {
variable <- sprintf("%s%s", variable, levels(check_fac)[nlevels(check_fac)])
} else if (is.logical(check_fac)) {
variable <- sprintf("%sTRUE", variable)
}
}
variable
}
# S3 ---------------------------------
#' @export
print.bayestestR_mediation <- function(x, digits = 3, ...) {
attr(x, "data") <- NULL
insight::print_color("# Causal Mediation Analysis for Stan Model\n\n", "blue")
cat(sprintf(
" Treatment: %s\n Mediator : %s\n Response : %s\n\n",
attr(x, "treatment", exact = TRUE),
attr(x, "mediator", exact = TRUE),
attr(x, "response", exact = TRUE)
))
prop_mediated <- prop_mediated_ori <- x[nrow(x), ]
x <- x[-nrow(x), ]
x$CI <- insight::format_ci(x$CI_low, x$CI_high, ci = NULL, digits = digits, width = "auto", missing = "NA")
x <- datawizard::data_remove(x, c("CI_low", "CI_high"), verbose = FALSE)
colnames(x)[ncol(x)] <- sprintf("%.5g%% %s", 100 * attributes(x)$ci, attributes(x)$ci_method)
# remove class, to avoid conflicts with "as.data.frame.bayestestR_mediation()"
class(x) <- "data.frame"
cat(insight::export_table(x, digits = digits))
cat("\n")
prop_mediated[] <- lapply(prop_mediated, insight::format_value, as_percent = TRUE)
insight::print_color(
sprintf(
"Proportion mediated: %s [%s, %s]\n",
prop_mediated$Estimate, prop_mediated$CI_low, prop_mediated$CI_high
),
"red"
)
if (any(prop_mediated_ori$Estimate < 0)) {
insight::format_alert("\nDirect and indirect effects have opposite directions. The proportion mediated is not meaningful.")
}
}
#' @export
plot.bayestestR_mediation <- function(x, ...) {
insight::check_if_installed("see", "to plot results from mediation analysis")
NextMethod()
}
bayestestR/R/rope_range.R 0000644 0001762 0000144 00000014111 14650172354 015051 0 ustar ligges users #' @title Find Default Equivalence (ROPE) Region Bounds
#'
#' @description This function attempts at automatically finding suitable "default"
#' values for the Region Of Practical Equivalence (ROPE).
#'
#' @details _Kruschke (2018)_ suggests that the region of practical equivalence
#' could be set, by default, to a range from `-0.1` to `0.1` of a standardized
#' parameter (negligible effect size according to _Cohen, 1988_).
#'
#' - For **linear models (lm)**, this can be generalised to
#' \ifelse{html}{\out{-0.1 * SDy, 0.1 * SDy}}{\eqn{[-0.1*SD_{y}, 0.1*SD_{y}]}}.
#'
#' - For **logistic models**, the parameters expressed in log odds ratio can be
#' converted to standardized difference through the formula
#' \ifelse{html}{\out{π/√(3)}}{\eqn{\pi/\sqrt{3}}}, resulting in a
#' range of `-0.18` to `0.18`.
#'
#' - For other models with **binary outcome**, it is strongly recommended to
#' manually specify the rope argument. Currently, the same default is applied
#' that for logistic models.
#'
#' - For models from **count data**, the residual variance is used. This is a
#' rather experimental threshold and is probably often similar to `-0.1, 0.1`,
#' but should be used with care!
#'
#' - For **t-tests**, the standard deviation of the response is used, similarly
#' to linear models (see above).
#'
#' - For **correlations**, `-0.05, 0.05` is used, i.e., half the value of a
#' negligible correlation as suggested by Cohen's (1988) rules of thumb.
#'
#' - For all other models, `-0.1, 0.1` is used to determine the ROPE limits,
#' but it is strongly advised to specify it manually.
#'
#' @param x A `stanreg`, `brmsfit` or `BFBayesFactor` object.
#' @param verbose Toggle warnings.
#' @inheritParams rope
#'
#' @examplesIf require("rstanarm") && require("brms") && require("BayesFactor")
#' \donttest{
#' model <- suppressWarnings(rstanarm::stan_glm(
#' mpg ~ wt + gear,
#' data = mtcars,
#' chains = 2,
#' iter = 200,
#' refresh = 0
#' ))
#' rope_range(model)
#'
#' model <- suppressWarnings(
#' rstanarm::stan_glm(vs ~ mpg, data = mtcars, family = "binomial", refresh = 0)
#' )
#' rope_range(model)
#'
#' model <- brms::brm(mpg ~ wt + cyl, data = mtcars)
#' rope_range(model)
#'
#' model <- BayesFactor::ttestBF(mtcars[mtcars$vs == 1, "mpg"], mtcars[mtcars$vs == 0, "mpg"])
#' rope_range(model)
#'
#' model <- lmBF(mpg ~ vs, data = mtcars)
#' rope_range(model)
#' }
#'
#' @references Kruschke, J. K. (2018). Rejecting or accepting parameter values
#' in Bayesian estimation. Advances in Methods and Practices in Psychological
#' Science, 1(2), 270-280. \doi{10.1177/2515245918771304}.
#'
#' @export
rope_range <- function(x, ...) {
UseMethod("rope_range")
}
#' @rdname rope_range
#' @export
rope_range.default <- function(x, verbose = TRUE, ...) {
response <- insight::get_response(x, source = "mf")
response_transform <- insight::find_transformation(x)
information <- insight::model_info(x, verbose = FALSE)
if (insight::is_multivariate(x)) {
ret <- Map(
function(i, j, ...) .rope_range(x, i, j), information, response, response_transform, verbose
)
} else {
ret <- .rope_range(x, information, response, response_transform, verbose)
}
ret
}
#' @export
rope_range.data.frame <- function(x, verbose = TRUE, ...) {
# to avoid errors with "get_response()" in the default method
c(-0.1, 0.1)
}
# Exceptions --------------------------------------------------------------
#' @export
rope_range.mlm <- function(x, verbose = TRUE, ...) {
response <- insight::get_response(x, source = "mf")
information <- insight::model_info(x, verbose = FALSE)
lapply(response, function(i) .rope_range(x, information, i, response_transform = NULL, verbose))
}
# helper ------------------
.rope_range <- function(x, information = NULL, response = NULL, response_transform = NULL, verbose = TRUE) {
negligible_value <- tryCatch(
if (!is.null(response_transform) && all(grepl("log", response_transform, fixed = TRUE))) {
# for log-transform, we assume that a 1% change represents the ROPE adequately
# see https://github.com/easystats/bayestestR/issues/487
0.01
} else if (information$is_linear && information$link_function == "log") {
# for log-transform, we assume that a 1% change represents the ROPE adequately
# see https://github.com/easystats/bayestestR/issues/487
0.01
} else if (information$family == "lognormal") {
# for log-transform, we assume that a 1% change represents the ROPE adequately
# see https://github.com/easystats/bayestestR/issues/487
0.01
} else if (!is.null(response) && information$link_function == "identity") {
# Linear Models
0.1 * stats::sd(response, na.rm = TRUE)
# 0.1 * stats::sigma(x) # https://github.com/easystats/bayestestR/issues/364
} else if (information$is_logit) {
# Logistic Models (any)
# Sigma==pi / sqrt(3)
0.1 * pi / sqrt(3)
} else if (information$is_probit) {
# Probit models
# Sigma==1
0.1 * 1
} else if (information$is_exponential) {
# Gamma models
sig <- insight::get_sigma(x)
if (is.null(sig) || length(sig) == 0 || is.na(sig)) stop(call. = FALSE)
switch(information$link_function,
inverse = ,
identity = stats::family(x)$variance(sig),
log = 0.1 * log1p(1 / sig^-2)
)
} else if (information$is_correlation) {
# Correlations
# https://github.com/easystats/bayestestR/issues/121
0.05
} else if (information$is_count) {
# Not sure about this
sig <- insight::get_sigma(x)
if (is.null(sig) || length(sig) == 0 || is.na(sig)) stop(call. = FALSE)
0.1 * sig
} else {
# Default
stop(call. = FALSE)
},
error = function(e) {
if (isTRUE(verbose)) {
insight::format_warning("Could not estimate a good default ROPE range. Using 'c(-0.1, 0.1)'.")
}
0.1
}
)
c(-1, 1) * negligible_value
}
bayestestR/R/equivalence_test.R 0000644 0001762 0000144 00000034710 14650172354 016277 0 ustar ligges users #' Test for Practical Equivalence
#'
#' Perform a **Test for Practical Equivalence** for Bayesian and frequentist models.
#'
#' Documentation is accessible for:
#'
#' - [Bayesian models](https://easystats.github.io/bayestestR/reference/equivalence_test.html)
#' - [Frequentist models](https://easystats.github.io/parameters/reference/equivalence_test.lm.html)
#'
#' For Bayesian models, the **Test for Practical Equivalence** is based on the
#' *"HDI+ROPE decision rule"* (\cite{Kruschke, 2014, 2018}) to check whether
#' parameter values should be accepted or rejected against an explicitly
#' formulated "null hypothesis" (i.e., a ROPE). In other words, it checks the
#' percentage of the `89%` [HDI][hdi] that is the null region (the ROPE). If
#' this percentage is sufficiently low, the null hypothesis is rejected. If this
#' percentage is sufficiently high, the null hypothesis is accepted.
#'
#' @inheritParams rope
#'
#' @details Using the [ROPE][rope] and the [HDI][hdi], \cite{Kruschke (2018)}
#' suggests using the percentage of the `95%` (or `89%`, considered more stable)
#' HDI that falls within the ROPE as a decision rule. If the HDI
#' is completely outside the ROPE, the "null hypothesis" for this parameter is
#' "rejected". If the ROPE completely covers the HDI, i.e., all most credible
#' values of a parameter are inside the region of practical equivalence, the
#' null hypothesis is accepted. Else, it’s undecided whether to accept or
#' reject the null hypothesis. If the full ROPE is used (i.e., `100%` of the
#' HDI), then the null hypothesis is rejected or accepted if the percentage
#' of the posterior within the ROPE is smaller than to `2.5%` or greater than
#' `97.5%`. Desirable results are low proportions inside the ROPE (the closer
#' to zero the better).
#' \cr \cr
#' Some attention is required for finding suitable values for the ROPE limits
#' (argument `range`). See 'Details' in [`rope_range()`][rope_range]
#' for further information.
#' \cr \cr
#' **Multicollinearity: Non-independent covariates**
#' \cr \cr
#' When parameters show strong correlations, i.e. when covariates are not
#' independent, the joint parameter distributions may shift towards or
#' away from the ROPE. In such cases, the test for practical equivalence may
#' have inappropriate results. Collinearity invalidates ROPE and hypothesis
#' testing based on univariate marginals, as the probabilities are conditional
#' on independence. Most problematic are the results of the "undecided"
#' parameters, which may either move further towards "rejection" or away
#' from it (\cite{Kruschke 2014, 340f}).
#' \cr \cr
#' `equivalence_test()` performs a simple check for pairwise correlations
#' between parameters, but as there can be collinearity between more than two variables,
#' a first step to check the assumptions of this hypothesis testing is to look
#' at different pair plots. An even more sophisticated check is the projection
#' predictive variable selection (\cite{Piironen and Vehtari 2017}).
#'
#'
#' @references
#' - Kruschke, J. K. (2018). Rejecting or accepting parameter values in Bayesian estimation. Advances in Methods and Practices in Psychological Science, 1(2), 270-280. \doi{10.1177/2515245918771304}
#' - Kruschke, J. K. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press
#' - Piironen, J., & Vehtari, A. (2017). Comparison of Bayesian predictive methods for model selection. Statistics and Computing, 27(3), 711–735. \doi{10.1007/s11222-016-9649-y}
#'
#' @return A data frame with following columns:
#'
#' - `Parameter` The model parameter(s), if `x` is a model-object. If `x` is a vector, this column is missing.
#' - `CI` The probability of the HDI.
#' - `ROPE_low`, `ROPE_high` The limits of the ROPE. These values are identical for all parameters.
#' - `ROPE_Percentage` The proportion of the HDI that lies inside the ROPE.
#' - `ROPE_Equivalence` The "test result", as character. Either "rejected", "accepted" or "undecided".
#' - `HDI_low` , `HDI_high` The lower and upper HDI limits for the parameters.
#'
#' @note There is a `print()`-method with a `digits`-argument to control
#' the amount of digits in the output, and there is a
#' [`plot()`-method](https://easystats.github.io/see/articles/bayestestR.html)
#' to visualize the results from the equivalence-test (for models only).
#'
#' @examplesIf require("rstanarm") && require("brms") && require("emmeans") && require("BayesFactor")
#' library(bayestestR)
#'
#' equivalence_test(x = rnorm(1000, 0, 0.01), range = c(-0.1, 0.1))
#' equivalence_test(x = rnorm(1000, 0, 1), range = c(-0.1, 0.1))
#' equivalence_test(x = rnorm(1000, 1, 0.01), range = c(-0.1, 0.1))
#' equivalence_test(x = rnorm(1000, 1, 1), ci = c(.50, .99))
#'
#' # print more digits
#' test <- equivalence_test(x = rnorm(1000, 1, 1), ci = c(.50, .99))
#' print(test, digits = 4)
#' \donttest{
#' model <- rstanarm::stan_glm(mpg ~ wt + cyl, data = mtcars)
#' equivalence_test(model)
#'
#' # plot result
#' test <- equivalence_test(model)
#' plot(test)
#'
#' equivalence_test(emmeans::emtrends(model, ~1, "wt", data = mtcars))
#'
#' model <- brms::brm(mpg ~ wt + cyl, data = mtcars)
#' equivalence_test(model)
#'
#' bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1))
#' # equivalence_test(bf)
#' }
#' @export
equivalence_test <- function(x, ...) {
UseMethod("equivalence_test")
}
#' @rdname equivalence_test
#' @export
equivalence_test.default <- function(x, ...) {
NULL
}
#' @export
equivalence_test.numeric <- function(x, range = "default", ci = 0.95, verbose = TRUE, ...) {
rope_data <- rope(x, range = range, ci = ci, verbose = verbose)
out <- as.data.frame(rope_data)
if (all(ci < 1)) {
out$ROPE_Equivalence <- datawizard::recode_into(
out$ROPE_Percentage == 0 ~ "Rejected",
out$ROPE_Percentage == 1 ~ "Accepted",
default = "Undecided"
)
} else {
# Related to guidelines for full rope (https://easystats.github.io/bayestestR/articles/4_Guidelines.html)
out$ROPE_Equivalence <- datawizard::recode_into(
out$ROPE_Percentage < 0.025 ~ "Rejected",
out$ROPE_Percentage > 0.975 ~ "Accepted",
default = "Undecided"
)
}
out$HDI_low <- attr(rope_data, "HDI_area", exact = TRUE)$CI_low
out$HDI_high <- attr(rope_data, "HDI_area", exact = TRUE)$CI_high
# remove attribute
attr(out, "HDI_area") <- NULL
attr(out, "data") <- x
class(out) <- unique(c("equivalence_test", "see_equivalence_test", class(out)))
out
}
#' @rdname equivalence_test
#' @export
equivalence_test.data.frame <- function(x, range = "default", ci = 0.95, verbose = TRUE, ...) {
l <- insight::compact_list(lapply(
x,
equivalence_test,
range = range,
ci = ci,
verbose = verbose
))
dat <- do.call(rbind, l)
out <- data.frame(
Parameter = rep(names(l), each = nrow(dat) / length(l)),
dat,
stringsAsFactors = FALSE
)
row.names(out) <- NULL
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
class(out) <- unique(c("equivalence_test", "see_equivalence_test_df", class(out)))
out
}
#' @export
equivalence_test.draws <- function(x, range = "default", ci = 0.95, verbose = TRUE, ...) {
equivalence_test(.posterior_draws_to_df(x), range = range, ci = ci, verbose = verbose, ...)
}
#' @export
equivalence_test.rvar <- equivalence_test.draws
#' @export
equivalence_test.emmGrid <- function(x, range = "default", ci = 0.95, verbose = TRUE, ...) {
xdf <- insight::get_parameters(x)
out <- equivalence_test(xdf, range = range, ci = ci, verbose = verbose, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
equivalence_test.emm_list <- equivalence_test.emmGrid
#' @export
equivalence_test.BFBayesFactor <- function(x, range = "default", ci = 0.95, verbose = TRUE, ...) {
out <- equivalence_test(insight::get_parameters(x), range = range, ci = ci, verbose = verbose, ...)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @keywords internal
.equivalence_test_models <- function(x,
range = "default",
ci = 0.95,
effects = "fixed",
component = "conditional",
parameters = NULL,
verbose = TRUE) {
if (all(range == "default")) {
range <- rope_range(x, verbose = verbose)
} else if (!all(is.numeric(range)) || length(range) != 2L) {
insight::format_error("`range` should be 'default' or a vector of 2 numeric values (e.g., c(-0.1, 0.1)).")
}
if (verbose && !inherits(x, "blavaan")) .check_multicollinearity(x)
params <- insight::get_parameters(
x,
component = component,
effects = effects,
parameters = parameters,
verbose = verbose
)
l <- sapply(
params,
equivalence_test,
range = range,
ci = ci,
verbose = verbose,
simplify = FALSE
)
dat <- do.call(rbind, l)
out <- data.frame(
Parameter = rep(names(l), each = nrow(dat) / length(l)),
dat,
stringsAsFactors = FALSE
)
class(out) <- unique(c("equivalence_test", "see_equivalence_test", class(out)))
out
}
#' @rdname equivalence_test
#' @export
equivalence_test.stanreg <- function(x,
range = "default",
ci = 0.95,
effects = c("fixed", "random", "all"),
component = c(
"location",
"all",
"conditional",
"smooth_terms",
"sigma",
"distributional",
"auxiliary"
),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
out <- .equivalence_test_models(x, range, ci, effects, component, parameters, verbose)
out <- .prepare_output(
out,
insight::clean_parameters(x),
inherits(x, "stanmvreg")
)
class(out) <- unique(c("equivalence_test", "see_equivalence_test", class(out)))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
equivalence_test.stanfit <- equivalence_test.stanreg
#' @export
equivalence_test.blavaan <- equivalence_test.stanreg
#' @rdname equivalence_test
#' @export
equivalence_test.brmsfit <- function(x,
range = "default",
ci = 0.95,
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects)
component <- match.arg(component)
out <- .equivalence_test_models(x, range, ci, effects, component, parameters, verbose)
out <- .prepare_output(
out,
insight::clean_parameters(x),
inherits(x, "stanmvreg")
)
class(out) <- unique(c("equivalence_test", "see_equivalence_test", class(out)))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
equivalence_test.sim.merMod <- function(x,
range = "default",
ci = 0.95,
parameters = NULL,
verbose = TRUE,
...) {
out <- .equivalence_test_models(
x,
range,
ci,
effects = "fixed",
component = "conditional",
parameters,
verbose = verbose
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
equivalence_test.sim <- equivalence_test.sim.merMod
#' @export
equivalence_test.mcmc <- function(x,
range = "default",
ci = 0.95,
parameters = NULL,
verbose = TRUE,
...) {
out <- .equivalence_test_models(
as.data.frame(x),
range,
ci,
effects = "fixed",
component = "conditional",
parameters,
verbose = verbose
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
equivalence_test.bcplm <- function(x,
range = "default",
ci = 0.95,
parameters = NULL,
verbose = TRUE,
...) {
out <- .equivalence_test_models(
insight::get_parameters(x),
range,
ci,
effects = "fixed",
component = "conditional",
parameters,
verbose = verbose
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
#' @export
equivalence_test.blrm <- equivalence_test.bcplm
#' @export
equivalence_test.mcmc.list <- equivalence_test.bcplm
#' @export
equivalence_test.bayesQR <- equivalence_test.bcplm
#' @export
equivalence_test.bamlss <- function(x,
range = "default",
ci = 0.95,
component = c("all", "conditional", "location"),
parameters = NULL,
verbose = TRUE,
...) {
component <- match.arg(component)
out <- .equivalence_test_models(
insight::get_parameters(x, component = component),
range,
ci,
effects = "fixed",
component = "conditional",
parameters,
verbose = verbose
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
bayestestR/R/print.bayesfactor_models.R 0000644 0001762 0000144 00000002146 14461433341 017731 0 ustar ligges users #' @export
print.bayesfactor_models_matrix <- function(x, digits = 2, log = FALSE, exact = TRUE, ...) {
orig_x <- x
# Format values
x <- unclass(x)
if (!log) x <- exp(x)
sgn <- sign(x) < 0
x <- insight::format_bf(abs(x), name = NULL, exact = exact, ...)
diag(x) <- if (log) "0" else "1"
if (any(sgn)) x[sgn] <- paste0("-", x[sgn])
df <- as.data.frame(x)
# Model names
models <- colnames(df)
models[models == "1"] <- "(Intercept only)"
models <- paste0("[", seq_along(models), "] ", models)
k <- max(vapply(c(models, "Denominator"), nchar, numeric(1))) + 2
rownames(df) <- colnames(df) <- NULL
df <- cbind(Model = models, df)
colnames(df) <- c("placeholder", paste0(" [", seq_along(models), "] "))
out <- insight::export_table(
df,
caption = c("# Bayes Factors for Model Comparison", "blue"),
subtitle = c(sprintf("\n\n%sNumerator\nDenominator", strrep(" ", k)), "cyan"),
footer = if (log) c("\nBayes Factors are on the log-scale.\n", "red")
)
out <- sub("placeholder", "\b\b", out, fixed = TRUE)
cat(out)
invisible(orig_x)
}
bayestestR/R/sensitivity_to_prior.R 0000644 0001762 0000144 00000007106 14560763455 017255 0 ustar ligges users #' Sensitivity to Prior
#'
#' Computes the sensitivity to priors specification. This represents the
#' proportion of change in some indices when the model is fitted with an
#' antagonistic prior (a prior of same shape located on the opposite of the
#' effect).
#'
#' @param model A Bayesian model (`stanreg` or `brmsfit`).
#' @param index The indices from which to compute the sensitivity. Can be one or
#' multiple names of the columns returned by `describe_posterior`. The case is
#' important here (e.g., write 'Median' instead of 'median').
#' @param magnitude This represent the magnitude by which to shift the
#' antagonistic prior (to test the sensitivity). For instance, a magnitude of
#' 10 (default) means that the mode wil be updated with a prior located at 10
#' standard deviations from its original location.
#' @param ... Arguments passed to or from other methods.
#'
#' @examplesIf require("rstanarm")
#' \donttest{
#' library(bayestestR)
#'
#' # rstanarm models
#' # -----------------------------------------------
#' model <- rstanarm::stan_glm(mpg ~ wt, data = mtcars)
#' sensitivity_to_prior(model)
#'
#' model <- rstanarm::stan_glm(mpg ~ wt + cyl, data = mtcars)
#' sensitivity_to_prior(model, index = c("Median", "MAP"))
#' }
#' @seealso DescTools
#' @export
sensitivity_to_prior <- function(model, ...) {
UseMethod("sensitivity_to_prior")
}
#' @rdname sensitivity_to_prior
#' @export
sensitivity_to_prior.stanreg <- function(model, index = "Median", magnitude = 10, ...) {
# Original
params <- .extract_parameters(model, index = index, ...)
# Priors
priors <- .extract_priors_rstanarm(model)
new_priors <- .prior_new_location(prior = priors$prior, sign = sign(params$Median), magnitude = magnitude)
model_updated <- stats::update(model, data = insight::get_data(model), prior = new_priors, refresh = 0)
# New model
params_updated <- .extract_parameters(model_updated, index = index, ...)
# Compute index
sensitivity <- abs(as.matrix(params_updated[-1]) - as.matrix(params[-1])) / abs(as.matrix(params[-1]))
# Clean up
sensitivity <- as.data.frame(sensitivity)
names(sensitivity) <- paste0("Sensitivity_", names(params_updated)[-1])
sensitivity <- cbind(params_updated[1], sensitivity)
row.names(sensitivity) <- NULL
sensitivity
}
#' @export
sensitivity_to_prior.default <- function(model, ...) {
insight::format_error(sprintf("Models of class '%s' are not yet supported.", class(model)[1]))
}
#' @keywords internal
.extract_parameters <- function(model, index = "Median", ...) {
# Handle BF
test <- c("pd", "rope", "p_map")
if (any(c("bf", "bayesfactor", "bayes_factor") %in% index)) {
test <- c(test, "bf")
}
params <- suppressMessages(describe_posterior(
model,
centrality = "all",
dispersion = TRUE,
test = test,
...
))
params <- params[params$Parameter != "(Intercept)", ]
params[unique(c("Parameter", "Median", index))]
}
#' Set a new location for a prior
#' @keywords internal
.prior_new_location <- function(prior, sign, magnitude = 10) {
prior$location <- -1 * sign * magnitude * prior$scale
prior
}
#' Extract and Returns the priors formatted for rstanarm
#' @keywords internal
.extract_priors_rstanarm <- function(model, ...) {
priors <- rstanarm::prior_summary(model)
# Deal with adjusted scale
if (!is.null(priors$prior$adjusted_scale)) {
priors$prior$scale <- priors$prior$adjusted_scale
priors$prior$adjusted_scale <- NULL
}
priors$prior$autoscale <- FALSE
priors
}
bayestestR/R/bayesfactor_models.R 0000644 0001762 0000144 00000047267 14650172354 016617 0 ustar ligges users #' Bayes Factors (BF) for model comparison
#'
#' @description This function computes or extracts Bayes factors from fitted models.
#' \cr \cr
#' The `bf_*` function is an alias of the main function.
#'
#' @author Mattan S. Ben-Shachar
#'
#' @param ... Fitted models (see details), all fit on the same data, or a single
#' `BFBayesFactor` object (see 'Details'). Ignored in `as.matrix()`,
#' `update()`. If the following named arguments are present, they are passed
#' to [`insight::get_loglikelihood()`] (see details):
#' - `estimator` (defaults to `"ML"`)
#' - `check_response` (defaults to `FALSE`)
#' @param denominator Either an integer indicating which of the models to use as
#' the denominator, or a model to be used as a denominator. Ignored for
#' `BFBayesFactor`.
#' @param object,x A [`bayesfactor_models()`] object.
#' @param subset Vector of model indices to keep or remove.
#' @param reference Index of model to reference to, or `"top"` to
#' reference to the best model, or `"bottom"` to reference to the worst
#' model.
#' @inheritParams hdi
#'
#' @note There is also a [`plot()`-method](https://easystats.github.io/see/articles/bayestestR.html)
#' implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}.
#'
#' @details
#' If the passed models are supported by **insight** the DV of all models will
#' be tested for equality (else this is assumed to be true), and the models'
#' terms will be extracted (allowing for follow-up analysis with `bayesfactor_inclusion`).
#'
#' - For `brmsfit` or `stanreg` models, Bayes factors are computed using the \CRANpkg{bridgesampling} package.
#' - `brmsfit` models must have been fitted with `save_pars = save_pars(all = TRUE)`.
#' - `stanreg` models must have been fitted with a defined `diagnostic_file`.
#' - For `BFBayesFactor`, `bayesfactor_models()` is mostly a wraparound `BayesFactor::extractBF()`.
#' - For all other model types, Bayes factors are computed using the BIC approximation.
#' Note that BICs are extracted from using [insight::get_loglikelihood], see documentation
#' there for options for dealing with transformed responses and REML estimation.
#'
#' In order to correctly and precisely estimate Bayes factors, a rule of thumb
#' are the 4 P's: **P**roper **P**riors and **P**lentiful
#' **P**osteriors. How many? The number of posterior samples needed for
#' testing is substantially larger than for estimation (the default of 4000
#' samples may not be enough in many cases). A conservative rule of thumb is to
#' obtain 10 times more samples than would be required for estimation
#' (_Gronau, Singmann, & Wagenmakers, 2017_). If less than 40,000 samples
#' are detected, `bayesfactor_models()` gives a warning.
#'
#' See also [the Bayes factors vignette](https://easystats.github.io/bayestestR/articles/bayes_factors.html).
#'
#' @inheritSection bayesfactor_parameters Interpreting Bayes Factors
#'
#' @return A data frame containing the models' formulas (reconstructed fixed and
#' random effects) and their `log(BF)`s (Use `as.numeric()` to extract the
#' non-log Bayes factors; see examples), that prints nicely.
#'
#' @examplesIf require("lme4") && require("BayesFactor") && require("rstanarm") && require("brms")
#' # With lm objects:
#' # ----------------
#' lm1 <- lm(mpg ~ 1, data = mtcars)
#' lm2 <- lm(mpg ~ hp, data = mtcars)
#' lm3 <- lm(mpg ~ hp + drat, data = mtcars)
#' lm4 <- lm(mpg ~ hp * drat, data = mtcars)
#' (BFM <- bayesfactor_models(lm1, lm2, lm3, lm4, denominator = 1))
#' # bayesfactor_models(lm2, lm3, lm4, denominator = lm1) # same result
#' # bayesfactor_models(lm1, lm2, lm3, lm4, denominator = lm1) # same result
#'
#' update(BFM, reference = "bottom")
#' as.matrix(BFM)
#' as.numeric(BFM)
#'
#' lm2b <- lm(sqrt(mpg) ~ hp, data = mtcars)
#' # Set check_response = TRUE for transformed responses
#' bayesfactor_models(lm2b, denominator = lm2, check_response = TRUE)
#'
#' \donttest{
#' # With lmerMod objects:
#' # ---------------------
#' lmer1 <- lme4::lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris)
#' lmer2 <- lme4::lmer(Sepal.Length ~ Petal.Length + (Petal.Length | Species), data = iris)
#' lmer3 <- lme4::lmer(
#' Sepal.Length ~ Petal.Length + (Petal.Length | Species) + (1 | Petal.Width),
#' data = iris
#' )
#' bayesfactor_models(lmer1, lmer2, lmer3,
#' denominator = 1,
#' estimator = "REML"
#' )
#'
#' # rstanarm models
#' # ---------------------
#' # (note that a unique diagnostic_file MUST be specified in order to work)
#' stan_m0 <- suppressWarnings(rstanarm::stan_glm(Sepal.Length ~ 1,
#' data = iris,
#' family = gaussian(),
#' diagnostic_file = file.path(tempdir(), "df0.csv")
#' ))
#' stan_m1 <- suppressWarnings(rstanarm::stan_glm(Sepal.Length ~ Species,
#' data = iris,
#' family = gaussian(),
#' diagnostic_file = file.path(tempdir(), "df1.csv")
#' ))
#' stan_m2 <- suppressWarnings(rstanarm::stan_glm(Sepal.Length ~ Species + Petal.Length,
#' data = iris,
#' family = gaussian(),
#' diagnostic_file = file.path(tempdir(), "df2.csv")
#' ))
#' bayesfactor_models(stan_m1, stan_m2, denominator = stan_m0, verbose = FALSE)
#'
#'
#' # brms models
#' # --------------------
#' # (note the save_pars MUST be set to save_pars(all = TRUE) in order to work)
#' brm1 <- brms::brm(Sepal.Length ~ 1, data = iris, save_pars = save_pars(all = TRUE))
#' brm2 <- brms::brm(Sepal.Length ~ Species, data = iris, save_pars = save_pars(all = TRUE))
#' brm3 <- brms::brm(
#' Sepal.Length ~ Species + Petal.Length,
#' data = iris,
#' save_pars = save_pars(all = TRUE)
#' )
#'
#' bayesfactor_models(brm1, brm2, brm3, denominator = 1, verbose = FALSE)
#'
#'
#' # BayesFactor
#' # ---------------------------
#' data(puzzles)
#' BF <- BayesFactor::anovaBF(RT ~ shape * color + ID,
#' data = puzzles,
#' whichRandom = "ID", progress = FALSE
#' )
#' BF
#' bayesfactor_models(BF) # basically the same
#' }
#'
#' @references
#' - Gronau, Q. F., Singmann, H., & Wagenmakers, E. J. (2017). Bridgesampling: An R package for estimating
#' normalizing constants. arXiv preprint arXiv:1710.08162.
#'
#' - Kass, R. E., and Raftery, A. E. (1995). Bayes Factors. Journal of the American Statistical Association,
#' 90(430), 773-795.
#'
#' - Robert, C. P. (2016). The expected demise of the Bayes factor. Journal of Mathematical Psychology,
#' 72, 33–37.
#'
#' - Wagenmakers, E. J. (2007). A practical solution to the pervasive problems of p values.
#' Psychonomic bulletin & review, 14(5), 779-804.
#'
#' - Wetzels, R., Matzke, D., Lee, M. D., Rouder, J. N., Iverson, G. J., and Wagenmakers, E.-J. (2011).
#' Statistical Evidence in Experimental Psychology: An Empirical Comparison Using 855 t Tests.
#' Perspectives on Psychological Science, 6(3), 291–298. \doi{10.1177/1745691611406923}
#'
#' @export
bayesfactor_models <- function(..., denominator = 1, verbose = TRUE) {
UseMethod("bayesfactor_models")
}
#' @rdname bayesfactor_models
#' @export
bf_models <- bayesfactor_models
#' @export
#' @rdname bayesfactor_models
bayesfactor_models.default <- function(..., denominator = 1, verbose = TRUE) {
# Organize the models and their names
mods <- list(...)
denominator <- list(denominator)
cl <- match.call(expand.dots = FALSE)
estimator <- mods[["estimator"]]
check_response <- mods[["check_response"]]
if (is.null(estimator)) estimator <- "ML"
if (is.null(check_response)) check_response <- FALSE
mods[["check_response"]] <- mods[["estimator"]] <- NULL
cl$...$estimator <- cl$...$check_response <- NULL
names(mods) <- sapply(cl$`...`, insight::safe_deparse)
names(denominator) <- insight::safe_deparse(cl$denominator)
mods <- .cleanup_BF_models(mods, denominator, cl)
mforms <- names(mods)
denominator <- attr(mods, "denominator", exact = TRUE)
# Get formula / model names
# supported models
supported_models <- vapply(mods, insight::is_model_supported, TRUE)
if (all(supported_models)) {
temp_forms <- sapply(mods, .find_full_formula)
has_terms <- sapply(temp_forms, nchar) > 0
mforms[has_terms] <- temp_forms[has_terms]
supported_models[!has_terms] <- FALSE
}
model_objects <- .safe(do.call(insight::ellipsis_info, c(mods, verbose = FALSE)))
if (!is.null(model_objects)) {
were_checked <- inherits(model_objects, "ListModels")
# Validate response
if (were_checked && verbose && !isTRUE(attr(model_objects, "same_response"))) {
insight::format_warning(
"When comparing models, please note that probably not all models were fit from same data."
)
}
# Get BIC
if (were_checked && estimator == "REML" &&
any(vapply(mods, insight::is_mixed_model, TRUE)) &&
!isTRUE(attr(model_objects, "same_fixef")) &&
verbose) {
insight::format_warning(paste(
"Information criteria (like BIC) based on REML fits (i.e. `estimator=\"REML\"`)",
"are not recommended for comparison between models with different fixed effects.",
"Concider setting `estimator=\"ML\"`."
))
}
} else if (verbose) {
insight::format_alert("Unable to validate that all models were fit with the same data.")
}
mBIC <- tryCatch(sapply(mods, function(m) {
LL <- insight::get_loglikelihood(
m,
estimator = estimator, check_response = check_response
)
stats::BIC(LL)
}), error = function(...) NULL)
if (is.null(mBIC)) mBIC <- sapply(mods, stats::BIC)
# Get BF
mBFs <- bic_to_bf(mBIC, denominator = mBIC[denominator], log = TRUE)
res <- data.frame(
Model = mforms,
log_BF = mBFs,
stringsAsFactors = FALSE
)
.bf_models_output(res,
denominator = denominator,
bf_method = "BIC approximation",
unsupported_models = !all(supported_models),
model_names = names(mods)
)
}
.bayesfactor_models_stan <- function(mods, denominator = 1, verbose = TRUE) {
# Warn
n_samps <- sapply(mods, function(x) {
alg <- insight::find_algorithm(x)
if (is.null(alg$iterations)) alg$iterations <- alg$sample
(alg$iterations - alg$warmup) * alg$chains
})
if (any(n_samps < 4e4) && verbose) {
insight::format_warning(
"Bayes factors might not be precise.",
"For precise Bayes factors, sampling at least 40,000 posterior samples is recommended."
)
}
if (inherits(mods[[1]], "blavaan")) {
res <- .bayesfactor_models_stan_SEM(mods, denominator, verbose)
bf_method <- "marginal likelihoods (Laplace approximation)"
unsupported_models <- TRUE
} else {
res <- .bayesfactor_models_stan_REG(mods, denominator, verbose)
bf_method <- "marginal likelihoods (bridgesampling)"
unsupported_models <- FALSE
}
.bf_models_output(res,
denominator = denominator,
bf_method = bf_method,
unsupported_models = unsupported_models
)
}
#' @keywords internal
.bayesfactor_models_stan_REG <- function(mods, denominator, verbose = TRUE) {
insight::check_if_installed("bridgesampling")
# Test that all is good:
resps <- lapply(mods, insight::get_response)
from_same_data_as_den <- sapply(resps[-denominator],
identical,
y = resps[[denominator]]
)
if (!all(from_same_data_as_den)) {
insight::format_error("Models were not computed from the same data.")
}
mML <- lapply(mods, .get_marglik, verbose = verbose)
mBFs <- sapply(mML, function(x) {
bf <- bridgesampling::bf(x, mML[[denominator]], log = TRUE)
bf[["bf"]]
})
# Get formula
mforms <- sapply(mods, .find_full_formula)
res <- data.frame(
Model = mforms,
log_BF = mBFs,
stringsAsFactors = FALSE
)
}
.bayesfactor_models_stan_SEM <- function(mods, denominator, verbose = TRUE) {
utils::capture.output(
suppressWarnings({
mBFs <- sapply(mods, function(m) {
blavaan::blavCompare(m, mods[[denominator]])[["bf"]][1]
})
})
)
res <- data.frame(
Model = names(mods),
log_BF = unname(mBFs),
stringsAsFactors = FALSE
)
}
#' @export
bayesfactor_models.stanreg <- function(..., denominator = 1, verbose = TRUE) {
mods <- list(...)
if (inherits(mods[[1]], "stanreg")) {
insight::check_if_installed("rstanarm")
} else if (inherits(mods[[1]], "brmsfit")) {
insight::check_if_installed("brms")
} else if (inherits(mods[[1]], "blavaan")) {
insight::check_if_installed("blavaan")
}
# Organize the models and their names
denominator <- list(denominator)
cl <- match.call(expand.dots = FALSE)
names(mods) <- sapply(cl$`...`, insight::safe_deparse)
names(denominator) <- insight::safe_deparse(cl$denominator)
mods <- .cleanup_BF_models(mods, denominator, cl)
denominator <- attr(mods, "denominator", exact = TRUE)
.bayesfactor_models_stan(mods, denominator = denominator, verbose = verbose)
}
#' @export
bayesfactor_models.brmsfit <- bayesfactor_models.stanreg
#' @export
bayesfactor_models.blavaan <- bayesfactor_models.stanreg
#' @export
bayesfactor_models.BFBayesFactor <- function(..., verbose = TRUE) {
models <- c(...)
insight::check_if_installed("BayesFactor")
mBFs <- c(0, BayesFactor::extractBF(models, TRUE, TRUE))
mforms <- sapply(c(models@denominator, models@numerator), function(x) x@shortName)
if (inherits(models@denominator, "BFlinearModel")) {
mforms[mforms == "Intercept only"] <- "1"
} else {
mforms <- .clean_non_linBF_mods(mforms)
}
res <- data.frame(
Model = unname(mforms),
log_BF = mBFs,
stringsAsFactors = FALSE
)
.bf_models_output(res,
denominator = 1,
bf_method = "JZS (BayesFactor)",
unsupported_models = !inherits(models@denominator, "BFlinearModel")
)
}
# Methods -----------------------------------------------------------------
#' @rdname bayesfactor_models
#' @export
update.bayesfactor_models <- function(object, subset = NULL, reference = NULL, ...) {
if (!is.null(reference)) {
if (reference == "top") {
reference <- which.max(object$log_BF)
} else if (reference == "bottom") {
reference <- which.min(object$log_BF)
}
object$log_BF <- object$log_BF - object$log_BF[reference]
attr(object, "denominator") <- reference
}
denominator <- attr(object, "denominator")
if (!is.null(subset)) {
if (all(subset < 0)) {
subset <- seq_len(nrow(object))[subset]
}
object_subset <- object[subset, ]
if (denominator %in% subset) {
attr(object_subset, "denominator") <- which(denominator == subset)
} else {
object_subset <- rbind(object[denominator, ], object_subset)
attr(object_subset, "denominator") <- 1
}
object <- object_subset
}
object
}
#' @rdname bayesfactor_models
#' @export
as.matrix.bayesfactor_models <- function(x, ...) {
out <- -outer(x$log_BF, x$log_BF, FUN = "-")
rownames(out) <- colnames(out) <- x$Model
# out <- exp(out)
class(out) <- c("bayesfactor_models_matrix", class(out))
out
}
# Helpers -----------------------------------------------------------------
#' @keywords internal
.cleanup_BF_models <- function(mods, denominator, cl) {
if (length(mods) == 1 && inherits(mods[[1]], "list")) {
mods <- mods[[1]]
mod_names <- .safe(sapply(cl$`...`[[1]][-1], insight::safe_deparse))
if (!is.null(mod_names) && length(mod_names) == length(mods)) {
names(mods) <- mod_names
}
}
if (is.numeric(denominator[[1]])) {
denominator <- denominator[[1]]
} else {
denominator_model <- which(names(mods) == names(denominator))
if (length(denominator_model) == 0) {
mods <- c(mods, denominator)
denominator <- length(mods)
} else {
denominator <- denominator_model
}
}
attr(mods, "denominator") <- denominator
mods
}
#' @keywords internal
.bf_models_output <- function(res,
denominator = 1,
bf_method = "method",
unsupported_models = FALSE,
model_names = NULL) {
# sanity check - are all BF NA?
if (!is.null(res$log_BF) && all(is.na(res$log_BF))) {
insight::format_error("Could not calculate Bayes Factor for these models. You may report this problem at {https://github.com/easystats/bayestestR/issues/}.") # nolint
}
attr(res, "denominator") <- denominator
attr(res, "BF_method") <- bf_method
attr(res, "unsupported_models") <- unsupported_models
attr(res, "model_names") <- model_names
class(res) <- c("bayesfactor_models", "see_bayesfactor_models", class(res))
res
}
#' @keywords internal
.find_full_formula <- function(mod) {
formulas <- insight::find_formula(mod)
conditional <- random <- NULL
if (!is.null(formulas$conditional)) {
conditional <- as.character(formulas$conditional)[3]
}
if (!is.null(formulas$random)) {
if (!is.list(formulas$random)) {
formulas$random <- list(formulas$random)
}
random <- sapply(formulas$random, function(x) {
paste0("(", as.character(x)[2], ")")
})
}
paste(c(conditional, random), collapse = " + ")
}
#' @keywords internal
.clean_non_linBF_mods <- function(m_names) {
tryCatch(
{
m_txt <- character(length = length(m_names))
## Detect types ##
is_null <- startsWith(m_names, "Null")
is_rho <- grepl("rho", m_names, fixed = TRUE)
is_mu <- grepl("mu", m_names, fixed = TRUE)
is_d <- grepl("d", m_names, fixed = TRUE)
is_p <- grepl("p", m_names, fixed = TRUE)
is_range <- grepl("<", m_names, fixed = TRUE)
## Range Alts ##
m_txt[!is_null & is_range] <-
sub("^[^\\s]*\\s[^\\s]*\\s", "", m_names[!is_null & is_range])
## Null models + Not nulls ##
if (any(is_d & is_p)) {
is_null <- !startsWith(m_names, "Non")
temp <- m_names[is_null][1]
mi <- gregexpr("\\(.*\\)", temp)
aa <- unlist(regmatches(temp, m = mi), use.names = FALSE)
m_txt[is_null] <- sub("a=", "a = ", aa, fixed = TRUE)
m_txt[!is_null & !is_range] <- sub("a=", "a != ", aa, fixed = TRUE)
} else if (any(is_rho)) {
m_txt[is_null] <- "rho = 0"
m_txt[!is_null & !is_range] <- "rho != 0"
m_txt <- sub("