bayestestR/0000755000176200001440000000000014650205472012404 5ustar liggesusersbayestestR/tests/0000755000176200001440000000000014650200252013535 5ustar liggesusersbayestestR/tests/testthat/0000755000176200001440000000000014650205472015406 5ustar liggesusersbayestestR/tests/testthat/test-p_direction.R0000644000176200001440000000274114505755602021015 0ustar liggesuserstest_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.R0000644000176200001440000000066114410351152020110 0ustar liggesuserstest_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.R0000644000176200001440000000327614560763455021200 0ustar liggesusers# 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.R0000644000176200001440000000063714560763455017662 0ustar liggesuserstest_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.R0000644000176200001440000000343414560763455020014 0ustar liggesuserstest_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.R0000644000176200001440000000504114461433341017250 0ustar liggesusers# 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.R0000644000176200001440000001043714561435021021502 0ustar liggesuserstest_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.R0000644000176200001440000000325714505755602017615 0ustar liggesuserstest_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.R0000644000176200001440000000530014650172354023415 0ustar liggesusersskip_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.R0000644000176200001440000001005114561127323023227 0ustar liggesuserstest_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.R0000644000176200001440000000346514357655465017662 0ustar liggesuserstest_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.R0000644000176200001440000000465414410351152017301 0ustar liggesusers# 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.R0000644000176200001440000000526114561435021022577 0ustar liggesusersskip_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.R0000644000176200001440000001521514413523767020105 0ustar liggesusers# 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.R0000644000176200001440000000407514505757365017123 0ustar liggesuserstest_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.R0000644000176200001440000001073214410351152020526 0ustar liggesuserstest_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.R0000644000176200001440000001502514560763455022370 0ustar liggesusers# 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.R0000644000176200001440000000653714560763455022044 0ustar liggesuserstest_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.R0000644000176200001440000000050414410351152016776 0ustar liggesusersskip_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.R0000644000176200001440000000312114357655465023254 0ustar liggesusers# 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.R0000644000176200001440000000037414461433351020135 0ustar liggesuserstest_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.R0000644000176200001440000000312614357655465021431 0ustar liggesuserstest_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.R0000644000176200001440000000313414505757365020644 0ustar liggesuserstest_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.R0000644000176200001440000000164714410351152022006 0ustar liggesuserstest_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.R0000644000176200001440000000031414276606713020656 0ustar liggesuserstest_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.R0000644000176200001440000000270614650172354022067 0ustar liggesuserstest_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.R0000644000176200001440000000017614276606713022603 0ustar liggesuserstest_that("as.data.frame.density", { expect_s3_class(as.data.frame(density(distribution_normal(1000))), "data.frame") }) bayestestR/tests/testthat/test-brms.R0000644000176200001440000000714714505754740017470 0ustar liggesuserstest_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.R0000644000176200001440000000220514505757365021462 0ustar liggesuserstest_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.R0000644000176200001440000001030214650172354020774 0ustar liggesusersskip_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.R0000644000176200001440000000773114561435021017457 0ustar liggesuserstest_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/0000755000176200001440000000000014560756720016700 5ustar liggesusersbayestestR/tests/testthat/_snaps/windows/0000755000176200001440000000000014560763455020375 5ustar liggesusersbayestestR/tests/testthat/_snaps/windows/print.md0000644000176200001440000000750114560763455022056 0ustar liggesusers# 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.R0000644000176200001440000000632114561435021021116 0ustar liggesusersskip_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.R0000644000176200001440000000157614410351152021532 0ustar liggesuserstest_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.R0000644000176200001440000001067714505754740020356 0ustar liggesuserstest_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.R0000644000176200001440000000145414650172354021330 0ustar liggesusersskip_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.R0000644000176200001440000000543314650172354020121 0ustar liggesuserstest_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.R0000644000176200001440000000356014560763455017137 0ustar liggesuserstest_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.R0000644000176200001440000000045214461433341020155 0ustar liggesuserstest_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.R0000644000176200001440000004311614650172354022403 0ustar liggesuserstest_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.R0000644000176200001440000000010414410351152015513 0ustar liggesuserslibrary(testthat) library(bayestestR) test_check("bayestestR") bayestestR/MD50000644000176200001440000002450314650205472012720 0ustar liggesusers5467592e579e062f05eb04f6705cd86c *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/0000755000176200001440000000000014650200252012574 5ustar liggesusersbayestestR/R/format.R0000644000176200001440000002421214560763455014233 0ustar liggesusers#' @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.R0000644000176200001440000000306614560763455016273 0ustar liggesusers#' 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.R0000644000176200001440000001415014650172354016234 0ustar liggesusers#' 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.R0000644000176200001440000000456514505754740013726 0ustar liggesusers#' @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.R0000644000176200001440000000232614461433341014637 0ustar liggesusers#' 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.R0000644000176200001440000003330514560763455013541 0ustar liggesusers#' 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.R0000644000176200001440000004233014561246646015242 0ustar liggesusers#' 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.R0000644000176200001440000000541214407021360013504 0ustar liggesusers#' 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.R0000644000176200001440000001717514560763455013512 0ustar liggesusers#' 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.R0000644000176200001440000001565714461433341014100 0ustar liggesusers#' @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.R0000644000176200001440000001566714650172354015241 0ustar liggesusers#' 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.R0000644000176200001440000000312014650172354016321 0ustar liggesusers#' 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.R0000644000176200001440000002402414650172354017025 0ustar liggesusers#' 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.R0000644000176200001440000000761214461433341014561 0ustar liggesusers#' 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.R0000644000176200001440000002704614650172354017175 0ustar liggesusers#' 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.R0000644000176200001440000002612014560763455014037 0ustar liggesusers#' 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.R0000644000176200001440000002467514560763455015721 0ustar liggesusers#' 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.R0000644000176200001440000001244314505754740015122 0ustar liggesusers#' @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.R0000644000176200001440000000520114461433341017777 0ustar liggesusers#' @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.R0000644000176200001440000001471714560763455015424 0ustar liggesusers#' 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.R0000644000176200001440000002424014650172354013347 0ustar liggesusers#' 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.R0000644000176200001440000005056614560763455013723 0ustar liggesusers#' 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.R0000644000176200001440000002171614561127323017470 0ustar liggesusers#' 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.R0000644000176200001440000003241714650172354014712 0ustar liggesusers#' @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.R0000644000176200001440000001411114650172354015051 0ustar liggesusers#' @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.R0000644000176200001440000003471014650172354016277 0ustar liggesusers#' 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.R0000644000176200001440000000214614461433341017731 0ustar liggesusers#' @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.R0000644000176200001440000000710614560763455017255 0ustar liggesusers#' 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.R0000644000176200001440000004726714650172354016617 0ustar liggesusers#' 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(" 1) { insight::print_color(header, "blue") cat("\n\n") } cat(insight::export_table(out[[i]], digits = digits)) cat("\n") } } bayestestR/R/as.list.R0000644000176200001440000000140214357655465014321 0ustar liggesusers# as.list ----------------------------------------------------------------- #' @export as.list.bayestestR_hdi <- function(x, ...) { if (nrow(x) == 1) { out <- list(CI = x$CI, CI_low = x$CI_low, CI_high = x$CI_high) out$Parameter <- x$Parameter } else { out <- list() for (param in x$Parameter) { out[[param]] <- list() out[[param]][["CI"]] <- x[x$Parameter == param, "CI"] out[[param]][["CI_low"]] <- x[x$Parameter == param, "CI_low"] out[[param]][["CI_high"]] <- x[x$Parameter == param, "CI_high"] } } out } #' @export as.list.bayestestR_eti <- as.list.bayestestR_hdi #' @export as.list.bayestestR_si <- as.list.bayestestR_hdi #' @export as.list.bayestestR_ci <- as.list.bayestestR_hdi bayestestR/R/bayesfactor_inclusion.R0000644000176200001440000001624414506247453017331 0ustar liggesusers#' Inclusion Bayes Factors for testing predictors across Bayesian models #' #' The `bf_*` function is an alias of the main function. #' \cr \cr #' For more info, see [the Bayes factors vignette](https://easystats.github.io/bayestestR/articles/bayes_factors.html). #' #' @author Mattan S. Ben-Shachar #' @param models An object of class [bayesfactor_models()] or `BFBayesFactor`. #' @param match_models See details. #' @param prior_odds Optional vector of prior odds for the models. See #' `BayesFactor::priorOdds<-`. #' @param ... Arguments passed to or from other methods. #' #' @return a data frame containing the prior and posterior probabilities, and #' log(BF) for each effect (Use `as.numeric()` to extract the non-log Bayes #' factors; see examples). #' #' @details Inclusion Bayes factors answer the question: Are the observed data #' more probable under models with a particular effect, than they are under #' models without that particular effect? In other words, on average - are #' models with effect \eqn{X} more likely to have produced the observed data #' than models without effect \eqn{X}? #' #' \subsection{Match Models}{ #' If `match_models=FALSE` (default), Inclusion BFs are computed by comparing #' all models with a term against all models without that term. If `TRUE`, #' comparison is restricted to models that (1) do not include any interactions #' with the term of interest; (2) for interaction terms, averaging is done only #' across models that containe the main effect terms from which the interaction #' term is comprised. #' } #' #' @inheritSection bayesfactor_parameters Interpreting Bayes Factors #' #' @note Random effects in the `lmer` style are converted to interaction terms: #' i.e., `(X|G)` will become the terms `1:G` and `X:G`. #' #' @seealso [weighted_posteriors()] for Bayesian parameter averaging. #' #' @examplesIf require("BayesFactor") #' library(bayestestR) #' #' # Using bayesfactor_models: #' # ------------------------------ #' mo0 <- lm(Sepal.Length ~ 1, data = iris) #' mo1 <- lm(Sepal.Length ~ Species, data = iris) #' mo2 <- lm(Sepal.Length ~ Species + Petal.Length, data = iris) #' mo3 <- lm(Sepal.Length ~ Species * Petal.Length, data = iris) #' #' BFmodels <- bayesfactor_models(mo1, mo2, mo3, denominator = mo0) #' (bf_inc <- bayesfactor_inclusion(BFmodels)) #' #' as.numeric(bf_inc) #' #' \donttest{ #' # BayesFactor #' # ------------------------------- #' BF <- BayesFactor::generalTestBF(len ~ supp * dose, ToothGrowth, progress = FALSE) #' bayesfactor_inclusion(BF) #' #' # compare only matched models: #' bayesfactor_inclusion(BF, match_models = TRUE) #' } #' #' @references #' - 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} #' #' - Clyde, M. A., Ghosh, J., & Littman, M. L. (2011). Bayesian adaptive sampling #' for variable selection and model averaging. Journal of Computational and Graphical Statistics, #' 20(1), 80-101. #' #' - Mathot, S. (2017). Bayes like a Baws: Interpreting Bayesian Repeated Measures in JASP. #' [Blog post](https://www.cogsci.nl/blog/interpreting-bayesian-repeated-measures-in-jasp). #' #' @export bayesfactor_inclusion <- function(models, match_models = FALSE, prior_odds = NULL, ...) { UseMethod("bayesfactor_inclusion") } #' @rdname bayesfactor_inclusion #' @export bf_inclusion <- bayesfactor_inclusion #' @export bayesfactor_inclusion.bayesfactor_models <- function(models, match_models = FALSE, prior_odds = NULL, ...) { if (isTRUE(attr(models, "unsupported_models"))) { insight::format_error( "Can not compute inclusion Bayes factors - passed models are not (yet) supported." ) } # Build Models Table # df.model <- .get_model_table(models, priorOdds = prior_odds) effnames <- colnames(df.model)[-(1:3)] # Build Interaction Matrix # if (isTRUE(match_models)) { effects.matrix <- as.matrix(df.model[, -(1:3)]) df.interaction <- data.frame(effnames, stringsAsFactors = FALSE) for (eff in effnames) { df.interaction[, eff] <- sapply(effnames, .includes_interaction, effnames = eff) } rownames(df.interaction) <- effnames df.interaction <- as.matrix(df.interaction[, -1]) } # Build Effect Table # df.effect <- data.frame( effnames, Pinc = rep(NA, length(effnames)), PincD = rep(NA, length(effnames)), log_BF = rep(NA, length(effnames)), stringsAsFactors = FALSE ) for (eff in effnames) { if (isTRUE(match_models)) { idx1 <- df.interaction[eff, ] idx2 <- df.interaction[, eff] has_not_high_order_interactions <- !apply(effects.matrix[, idx1, drop = FALSE], 1, any) ind_include <- has_not_high_order_interactions & effects.matrix[, eff] ind_exclude <- apply(effects.matrix[, idx2, drop = FALSE], 1, all) & has_not_high_order_interactions & !effects.matrix[, eff] df.model_temp <- df.model[ind_include | ind_exclude, , drop = FALSE] } else { df.model_temp <- df.model } # models with effect mwith <- which(df.model_temp[[eff]]) mwithprior <- sum(df.model_temp[mwith, "priorProbs"]) mwithpost <- sum(df.model_temp[mwith, "postProbs"]) # models without effect mwithoutprior <- sum(df.model_temp[-mwith, "priorProbs"]) mwithoutpost <- sum(df.model_temp[-mwith, "postProbs"]) # Save results df.effect$Pinc[effnames == eff] <- mwithprior df.effect$PincD[effnames == eff] <- mwithpost df.effect$log_BF[effnames == eff] <- (log(mwithpost) - log(mwithoutpost)) - (log(mwithprior) - log(mwithoutprior)) } df.effect <- df.effect[, -1, drop = FALSE] colnames(df.effect) <- c("p_prior", "p_posterior", "log_BF") rownames(df.effect) <- effnames class(df.effect) <- c("bayesfactor_inclusion", class(df.effect)) attr(df.effect, "matched") <- match_models attr(df.effect, "priorOdds") <- prior_odds return(df.effect) } #' @export bayesfactor_inclusion.BFBayesFactor <- function(models, match_models = FALSE, prior_odds = NULL, ...) { models <- bayesfactor_models.BFBayesFactor(models) bayesfactor_inclusion.bayesfactor_models(models, match_models = match_models, prior_odds = prior_odds ) } #' @keywords internal .includes_interaction <- function(eff, effnames) { eff_b <- strsplit(eff, ":", fixed = TRUE) effnames_b <- strsplit(effnames, ":", fixed = TRUE) is_int <- vapply(effnames_b, function(x) length(x) > 1, TRUE) temp <- logical(length(effnames)) for (rr in seq_along(effnames)) { if (is_int[rr]) { temp[rr] <- all(eff_b[[1]] %in% effnames_b[[rr]]) & !all(effnames_b[[rr]] %in% eff_b[[1]]) } } temp } bayestestR/R/point_estimate.R0000644000176200001440000003025414560763455015772 0ustar liggesusers#' Point-estimates of posterior distributions #' #' Compute various point-estimates, such as the mean, the median or the MAP, to describe posterior distributions. #' #' @param centrality The point-estimates (centrality indices) to compute. Character #' (vector) or list with one or more of these options: `"median"`, `"mean"`, `"MAP"` #' (see [`map_estimate()`]), `"trimmed"` (which is just `mean(x, trim = threshold)`), #' `"mode"` or `"all"`. #' @param dispersion Logical, if `TRUE`, computes indices of dispersion related #' to the estimate(s) (`SD` and `MAD` for `mean` and `median`, respectively). #' Dispersion is not available for `"MAP"` or `"mode"` centrality indices. #' @param threshold For `centrality = "trimmed"` (i.e. trimmed mean), indicates #' the fraction (0 to 0.5) of observations to be trimmed from each end of the #' vector before the mean is computed. #' @param ... Additional arguments to be passed to or from methods. #' @inheritParams hdi #' #' @references Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and 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} #' #' @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") && require("emmeans") && require("brms") && require("BayesFactor") #' library(bayestestR) #' #' point_estimate(rnorm(1000)) #' point_estimate(rnorm(1000), centrality = "all", dispersion = TRUE) #' point_estimate(rnorm(1000), centrality = c("median", "MAP")) #' #' df <- data.frame(replicate(4, rnorm(100))) #' point_estimate(df, centrality = "all", dispersion = TRUE) #' point_estimate(df, centrality = c("median", "MAP")) #' \donttest{ #' # rstanarm models #' # ----------------------------------------------- #' model <- rstanarm::stan_glm(mpg ~ wt + cyl, data = mtcars) #' point_estimate(model, centrality = "all", dispersion = TRUE) #' point_estimate(model, centrality = c("median", "MAP")) #' #' #' # emmeans estimates #' # ----------------------------------------------- #' point_estimate( #' emmeans::emtrends(model, ~1, "wt", data = mtcars), #' centrality = c("median", "MAP") #' ) #' #' # brms models #' # ----------------------------------------------- #' model <- brms::brm(mpg ~ wt + cyl, data = mtcars) #' point_estimate(model, centrality = "all", dispersion = TRUE) #' point_estimate(model, centrality = c("median", "MAP")) #' #' # BayesFactor objects #' # ----------------------------------------------- #' bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) #' point_estimate(bf, centrality = "all", dispersion = TRUE) #' point_estimate(bf, centrality = c("median", "MAP")) #' } #' #' @export point_estimate <- function(x, ...) { UseMethod("point_estimate") } #' @export point_estimate.default <- function(x, ...) { insight::format_error( paste0("'point_estimate()' is not yet implemented for objects of class '", class(x)[1], "'.") ) } #' @rdname point_estimate #' @export point_estimate.numeric <- function(x, centrality = "all", dispersion = FALSE, threshold = 0.1, ...) { centrality <- match.arg(tolower(centrality), c("median", "mean", "map", "trimmed", "mode", "all"), several.ok = TRUE) if ("all" %in% centrality) { estimate_list <- c("median", "mean", "map") } else { estimate_list <- centrality } out <- data.frame(".temp" = 0) # Median if ("median" %in% estimate_list) { out$Median <- stats::median(x) if (dispersion) { out$MAD <- stats::mad(x) } } # Mean if ("mean" %in% estimate_list) { out$Mean <- mean(x) if (dispersion) { out$SD <- stats::sd(x) } } # trimmed mean if ("trimmed" %in% estimate_list) { out$Trimmed_Mean <- mean(x, trim = threshold) if (dispersion) { out$SD <- stats::sd(x) } } # MAP if ("map" %in% estimate_list) { out$MAP <- as.numeric(map_estimate(x)) } # MODE if ("mode" %in% estimate_list) { out$Mode <- .mode_estimate(x) } out <- out[names(out) != ".temp"] attr(out, "data") <- x attr(out, "centrality") <- centrality class(out) <- unique(c("point_estimate", "see_point_estimate", class(out))) out } #' @export point_estimate.data.frame <- function(x, centrality = "all", dispersion = FALSE, threshold = 0.1, ...) { x <- .select_nums(x) if (ncol(x) == 1) { estimates <- point_estimate(x[, 1], centrality = centrality, dispersion = dispersion, threshold = threshold, ...) } else { estimates <- sapply(x, point_estimate, centrality = centrality, dispersion = dispersion, simplify = FALSE, ...) estimates <- do.call(rbind, estimates) } out <- cbind(data.frame("Parameter" = names(x), stringsAsFactors = FALSE), estimates) rownames(out) <- NULL attr(out, "data") <- x attr(out, "centrality") <- centrality class(out) <- unique(c("point_estimate", "see_point_estimate", class(out))) out } #' @export point_estimate.draws <- function(x, centrality = "all", dispersion = FALSE, threshold = 0.1, ...) { point_estimate( .posterior_draws_to_df(x), centrality = centrality, dispersion = dispersion, threshold = threshold, ... ) } #' @export point_estimate.rvar <- point_estimate.draws #' @export point_estimate.mcmc <- function(x, centrality = "all", dispersion = FALSE, ...) { point_estimate(as.data.frame(x), centrality = centrality, dispersion = dispersion, ...) } #' @export point_estimate.bcplm <- function(x, centrality = "all", dispersion = FALSE, ...) { point_estimate(insight::get_parameters(x), centrality = centrality, dispersion = dispersion, ...) } #' @export point_estimate.bayesQR <- point_estimate.bcplm #' @export point_estimate.blrm <- point_estimate.bcplm #' @export point_estimate.mcmc.list <- point_estimate.bcplm #' @export point_estimate.BGGM <- point_estimate.bcplm #' @export point_estimate.bamlss <- function(x, centrality = "all", dispersion = FALSE, component = c("conditional", "location", "all"), ...) { component <- match.arg(component) out <- point_estimate( insight::get_parameters(x, component = component), centrality = centrality, dispersion = dispersion, ... ) .add_clean_parameters_attribute(out, x) } #' @export point_estimate.MCMCglmm <- function(x, centrality = "all", dispersion = FALSE, ...) { nF <- x$Fixed$nfl point_estimate( as.data.frame(x$Sol[, 1:nF, drop = FALSE]), centrality = centrality, dispersion = dispersion, ... ) } #' @export point_estimate.emmGrid <- function(x, centrality = "all", dispersion = FALSE, ...) { xdf <- insight::get_parameters(x) out <- point_estimate(xdf, centrality = centrality, dispersion = dispersion, ...) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export point_estimate.emm_list <- point_estimate.emmGrid #' @rdname point_estimate #' @export point_estimate.stanreg <- function(x, centrality = "all", dispersion = FALSE, 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( point_estimate(insight::get_parameters(x, effects = effects, component = component, parameters = parameters), centrality = centrality, dispersion = dispersion, ...), cleaned_parameters, inherits(x, "stanmvreg") ) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) attr(out, "centrality") <- centrality attr(out, "clean_parameters") <- cleaned_parameters class(out) <- unique(c("point_estimate", "see_point_estimate", class(out))) out } #' @export point_estimate.stanfit <- point_estimate.stanreg #' @export point_estimate.blavaan <- point_estimate.stanreg #' @rdname point_estimate #' @export point_estimate.brmsfit <- function(x, centrality = "all", dispersion = FALSE, 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( point_estimate(insight::get_parameters(x, effects = effects, component = component, parameters = parameters), centrality = centrality, dispersion = dispersion, ...), cleaned_parameters ) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) attr(out, "centrality") <- centrality attr(out, "clean_parameters") <- cleaned_parameters class(out) <- unique(c("point_estimate", "see_point_estimate", class(out))) out } #' @export point_estimate.sim.merMod <- function(x, centrality = "all", dispersion = FALSE, effects = c("fixed", "random", "all"), parameters = NULL, ...) { effects <- match.arg(effects) out <- .point_estimate_models( x = x, effects = effects, component = "conditional", parameters = parameters, centrality = centrality, dispersion = dispersion, ... ) attr(out, "data") <- insight::get_parameters(x, effects = effects, parameters = parameters) attr(out, "centrality") <- centrality out <- .add_clean_parameters_attribute(out, x) class(out) <- unique(c("point_estimate", "see_point_estimate", class(out))) out } #' @export point_estimate.sim <- function(x, centrality = "all", dispersion = FALSE, parameters = NULL, ...) { out <- .point_estimate_models( x = x, effects = "fixed", component = "conditional", parameters = parameters, centrality = centrality, dispersion = dispersion, ... ) attr(out, "data") <- insight::get_parameters(x, parameters = parameters) attr(out, "centrality") <- centrality class(out) <- unique(c("point_estimate", "see_point_estimate", class(out))) out } #' @rdname point_estimate #' @export point_estimate.BFBayesFactor <- function(x, centrality = "all", dispersion = FALSE, ...) { out <- point_estimate(insight::get_parameters(x), centrality = centrality, dispersion = dispersion, ...) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) attr(out, "centrality") <- centrality class(out) <- unique(c("point_estimate", "see_point_estimate", class(out))) out } #' @export point_estimate.matrix <- function(x, ...) { point_estimate(as.data.frame(x), ...) } #' @rdname point_estimate #' @export point_estimate.get_predicted <- function(x, centrality = "all", dispersion = FALSE, use_iterations = FALSE, verbose = TRUE, ...) { if (isTRUE(use_iterations)) { if ("iterations" %in% names(attributes(x))) { out <- point_estimate( as.data.frame(t(attributes(x)$iterations)), centrality = centrality, dispersion = dispersion, verbose = verbose, ... ) } else { insight::format_error("No iterations present in the output.") } attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) } else { out <- point_estimate(as.numeric(x), centrality = centrality, dispersion = dispersion, verbose = verbose, ... ) } out } # Helper ------------------------------------------------------------------ #' @keywords internal .point_estimate_models <- function(x, effects, component, parameters, centrality = "all", dispersion = FALSE, ...) { point_estimate( insight::get_parameters(x, effects = effects, component = component, parameters = parameters), centrality = centrality, dispersion = dispersion, ... ) } #' @keywords internal .mode_estimate <- function(x) { ux <- unique(x) ux[which.max(tabulate(match(x, ux)))] } bayestestR/R/simulate_priors.R0000644000176200001440000000731714505754740016167 0ustar liggesusers#' Returns Priors of a Model as Empirical Distributions #' #' Transforms priors information to actual distributions. #' #' @inheritParams effective_sample #' @param n Size of the simulated prior distributions. #' #' @seealso [`unupdate()`] for directly sampling from the prior #' distribution (useful for complex priors and designs). #' #' @examples #' \donttest{ #' library(bayestestR) #' if (require("rstanarm")) { #' model <- suppressWarnings( #' stan_glm(mpg ~ wt + am, data = mtcars, chains = 1, refresh = 0) #' ) #' simulate_prior(model) #' } #' } #' @export simulate_prior <- function(model, n = 1000, ...) { UseMethod("simulate_prior") } #' @export simulate_prior.stanreg <- function(model, n = 1000, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = TRUE, ...) { # check arguments effects <- match.arg(effects) component <- match.arg(component) priors <- insight::get_priors( model, effects = effects, component = component, parameters = parameters, verbose = verbose ) .simulate_prior(priors, n = n, verbose = verbose) } #' @export simulate_prior.blavaan <- simulate_prior.stanreg #' @export simulate_prior.brmsfit <- function(model, n = 1000, 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) priors <- insight::get_priors( model, effects = effects, component = component, parameters = parameters, verbose = verbose ) .simulate_prior(priors, n = n, verbose = verbose) } #' @export simulate_prior.bcplm <- function(model, n = 1000, verbose = TRUE, ...) { .simulate_prior(insight::get_priors(model, verbose = verbose), n = n, verbose = verbose) } #' @keywords internal .simulate_prior <- function(priors, n = 1000, verbose = TRUE) { simulated <- data.frame(.bamboozled = 1:n) sim_error_msg <- FALSE # iterate over parameters for (param in priors$Parameter) { prior <- priors[priors$Parameter == param, ] # edge cases if (nrow(prior) > 1) { prior <- prior[1, ] } # Get actual scale if ("Adjusted_Scale" %in% names(prior)) { scale <- prior$Adjusted_Scale # is autoscale = FALSE, scale contains NA values - replace # with non-adjusted then. if (anyNA(scale)) scale[is.na(scale)] <- prior$Scale[is.na(scale)] } else { scale <- prior$Scale } # Simulate prior prior <- tryCatch( { if (prior$Distribution %in% c("t", "student_t", "Student's t")) { distribution(prior$Distribution, n, prior$df, prior$Location) } else { distribution(prior$Distribution, n, prior$Location, scale) } }, error = function(e) { sim_error_msg <- TRUE NA } ) simulated[param] <- prior } if (sim_error_msg && verbose) { insight::format_warning(paste0("Can't simulate priors from a ", prior$Distribution, " distribution.")) } simulated$.bamboozled <- NULL simulated } bayestestR/R/describe_prior.R0000644000176200001440000000720314505754740015733 0ustar liggesusers#' Describe Priors #' #' Returns a summary of the priors used in the model. #' #' @param model A Bayesian model. #' @param ... Currently not used. #' @inheritParams describe_posterior #' #' @examples #' \donttest{ #' library(bayestestR) #' #' # rstanarm models #' # ----------------------------------------------- #' if (require("rstanarm")) { #' model <- rstanarm::stan_glm(mpg ~ wt + cyl, data = mtcars) #' describe_prior(model) #' } #' #' # brms models #' # ----------------------------------------------- #' if (require("brms")) { #' model <- brms::brm(mpg ~ wt + cyl, data = mtcars) #' describe_prior(model) #' } #' #' # BayesFactor objects #' # ----------------------------------------------- #' if (require("BayesFactor")) { #' bf <- ttestBF(x = rnorm(100, 1, 1)) #' describe_prior(bf) #' } #' } #' @export describe_prior <- function(model, ...) { UseMethod("describe_prior") } #' @rdname describe_prior #' @export describe_prior.brmsfit <- function(model, effects = c("fixed", "random", "all"), component = c( "conditional", "zi", "zero_inflated", "all", "location", "distributional", "auxiliary" ), parameters = NULL, ...) { .describe_prior(model, parameters = parameters) } # Internal ---------------------------------------------------------------- #' @keywords internal .describe_prior <- function(model, parameters = NULL, ...) { priors <- insight::get_priors(model, ...) # Format names names(priors)[-1] <- paste0("Prior_", names(priors)[-1]) # If the prior scale has been adjusted, it is the actual scale that was used. if ("Prior_Adjusted_Scale" %in% names(priors)) { priors$Prior_Scale[!is.na(priors$Prior_Adjusted_Scale)] <- priors$Prior_Adjusted_Scale[!is.na(priors$Prior_Adjusted_Scale)] priors$Prior_Adjusted_Scale <- NULL } if ("Prior_Response" %in% names(priors)) { names(priors)[names(priors) == "Prior_Response"] <- "Response" } # make sure parameter names match between prior output and model cp <- insight::clean_parameters(model) ## TODO for now, only fixed effects if ("Effects" %in% names(cp)) { cp <- cp[cp$Effects == "fixed", ] } if (!is.null(parameters) && !all(priors$Parameter %in% parameters)) { cp$Cleaned_Parameter <- gsub("(.*)(\\.|\\[)\\d+(\\.|\\])", "\\1", cp$Cleaned_Parameter) cp$Cleaned_Parameter[cp$Cleaned_Parameter == "Intercept"] <- "(Intercept)" colnames(priors)[1] <- "Cleaned_Parameter" out <- merge(cp, priors, by = "Cleaned_Parameter", all = TRUE) out <- out[!duplicated(out$Parameter), ] priors <- out[intersect(colnames(out), c("Parameter", "Prior_Distribution", "Prior_df", "Prior_Location", "Prior_Scale", "Response"))] } priors } #' @export describe_prior.stanreg <- .describe_prior #' @export describe_prior.bcplm <- .describe_prior #' @export describe_prior.blavaan <- .describe_prior #' @export describe_prior.BFBayesFactor <- function(model, ...) { priors <- insight::get_priors(model) # Format names names(priors)[-1] <- paste0("Prior_", names(priors)[-1]) priors } # unsupported ---------------- #' @export describe_prior.BGGM <- function(model, ...) { NULL } #' @export describe_prior.BGGM <- describe_prior.BGGM #' @export describe_prior.bamlss <- describe_prior.BGGM #' @export describe_prior.draws <- describe_prior.BGGM #' @export describe_prior.rvar <- describe_prior.BGGM bayestestR/R/mcse.R0000644000176200001440000000600214560763455013667 0ustar liggesusers#' Monte-Carlo Standard Error (MCSE) #' #' This function returns the Monte Carlo Standard Error (MCSE). #' #' @inheritParams effective_sample #' #' #' @details **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 \dQuote{provides a quantitative #' suggestion of how big the estimation noise is}. #' #' @references Kruschke, J. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press. #' #' @examplesIf require("rstanarm") #' \donttest{ #' library(bayestestR) #' #' model <- suppressWarnings( #' rstanarm::stan_glm(mpg ~ wt + am, data = mtcars, chains = 1, refresh = 0) #' ) #' mcse(model) #' } #' @export mcse <- function(model, ...) { UseMethod("mcse") } #' @export mcse.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) params <- insight::get_parameters( model, effects = effects, component = component, parameters = parameters ) ess <- effective_sample( model, effects = effects, component = component, parameters = parameters ) .mcse(params, stats::setNames(ess$ESS, ess$Parameter)) } #' @rdname mcse #' @export mcse.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) params <- insight::get_parameters( model, effects = effects, component = component, parameters = parameters ) ess <- effective_sample( model, effects = effects, component = component, parameters = parameters ) .mcse(params, stats::setNames(ess$ESS, ess$Parameter)) } #' @export mcse.stanfit <- mcse.stanreg #' @export mcse.blavaan <- mcse.stanreg #' @keywords internal .mcse <- function(params, ess) { # get standard deviations from posterior samples stddev <- sapply(params, stats::sd) # check proper length, and for unequal length, shorten all # objects to common parameters if (length(stddev) != length(ess)) { common <- stats::na.omit(match(names(stddev), names(ess))) stddev <- stddev[common] ess <- ess[common] params <- params[common] } # compute mcse data.frame( Parameter = colnames(params), MCSE = stddev / sqrt(ess), stringsAsFactors = FALSE, row.names = NULL ) } bayestestR/R/contr.equalprior.R0000644000176200001440000001574014650172354016250 0ustar liggesusers#' Contrast Matrices for Equal Marginal Priors in Bayesian Estimation #' #' Build contrasts for factors with equal marginal priors on all levels. The 3 #' functions give the same orthogonal contrasts, but are scaled differently to #' allow different prior specifications (see 'Details'). Implementation from #' Singmann & Gronau's [`bfrms`](https://github.com/bayesstuff/bfrms/), #' following the description in Rouder, Morey, Speckman, & Province (2012, p. #' 363). #' #' @inheritParams stats::contr.treatment #' #' @details #' When using [`stats::contr.treatment`], each dummy variable is the difference #' between each level and the reference level. While this is useful if setting #' different priors for each coefficient, it should not be used if one is trying #' to set a general prior for differences between means, as it (as well as #' [`stats::contr.sum`] and others) results in unequal marginal priors on the #' means the the difference between them. #' #' ``` #' library(brms) #' #' data <- data.frame( #' group = factor(rep(LETTERS[1:4], each = 3)), #' y = rnorm(12) #' ) #' #' contrasts(data$group) # R's default contr.treatment #' #> B C D #' #> A 0 0 0 #' #> B 1 0 0 #' #> C 0 1 0 #' #> D 0 0 1 #' #' model_prior <- brm( #' y ~ group, data = data, #' sample_prior = "only", #' # Set the same priors on the 3 dummy variable #' # (Using an arbitrary scale) #' prior = set_prior("normal(0, 10)", coef = c("groupB", "groupC", "groupD")) #' ) #' #' est <- emmeans::emmeans(model_prior, pairwise ~ group) #' #' point_estimate(est, centr = "mean", disp = TRUE) #' #> Point Estimate #' #> #' #> Parameter | Mean | SD #' #> ------------------------- #' #> A | -0.01 | 6.35 #' #> B | -0.10 | 9.59 #' #> C | 0.11 | 9.55 #' #> D | -0.16 | 9.52 #' #> A - B | 0.10 | 9.94 #' #> A - C | -0.12 | 9.96 #' #> A - D | 0.15 | 9.87 #' #> B - C | -0.22 | 14.38 #' #> B - D | 0.05 | 14.14 #' #> C - D | 0.27 | 14.00 #' ``` #' #' We can see that the priors for means aren't all the same (`A` having a more #' narrow prior), and likewise for the pairwise differences (priors for #' differences from `A` are more narrow). #' #' The solution is to use one of the methods provided here, which *do* result in #' marginally equal priors on means differences between them. Though this will #' obscure the interpretation of parameters, setting equal priors on means and #' differences is important for they are useful for specifying equal priors on #' all means in a factor and their differences correct estimation of Bayes #' factors for contrasts and order restrictions of multi-level factors (where #' `k>2`). See info on specifying correct priors for factors with more than 2 #' levels in [the Bayes factors vignette](https://easystats.github.io/bayestestR/articles/bayes_factors.html). #' #' ***NOTE:*** When setting priors on these dummy variables, always: #' 1. Use priors that are **centered on 0**! Other location/centered priors are meaningless! #' 2. Use **identically-scaled priors** on all the dummy variables of a single factor! #' #' `contr.equalprior` returns the original orthogonal-normal contrasts as #' described in Rouder, Morey, Speckman, & Province (2012, p. 363). Setting #' `contrasts = FALSE` returns the \eqn{I_{n} - \frac{1}{n}} matrix. #' #' ## `contr.equalprior_pairs` #' #' Useful for setting priors in terms of pairwise differences between means - #' the scales of the priors defines the prior distribution of the pair-wise #' differences between all pairwise differences (e.g., `A - B`, `B - C`, etc.). #' #' ``` #' contrasts(data$group) <- contr.equalprior_pairs #' contrasts(data$group) #' #> [,1] [,2] [,3] #' #> A 0.0000000 0.6123724 0.0000000 #' #> B -0.1893048 -0.2041241 0.5454329 #' #> C -0.3777063 -0.2041241 -0.4366592 #' #> D 0.5670111 -0.2041241 -0.1087736 #' #' model_prior <- brm( #' y ~ group, data = data, #' sample_prior = "only", #' # Set the same priors on the 3 dummy variable #' # (Using an arbitrary scale) #' prior = set_prior("normal(0, 10)", coef = c("group1", "group2", "group3")) #' ) #' #' est <- emmeans(model_prior, pairwise ~ group) #' #' point_estimate(est, centr = "mean", disp = TRUE) #' #> Point Estimate #' #> #' #> Parameter | Mean | SD #' #> ------------------------- #' #> A | -0.31 | 7.46 #' #> B | -0.24 | 7.47 #' #> C | -0.34 | 7.50 #' #> D | -0.30 | 7.25 #' #> A - B | -0.08 | 10.00 #' #> A - C | 0.03 | 10.03 #' #> A - D | -0.01 | 9.85 #' #> B - C | 0.10 | 10.28 #' #> B - D | 0.06 | 9.94 #' #> C - D | -0.04 | 10.18 #' ``` #' #' All means have the same prior distribution, and the distribution of the #' differences matches the prior we set of `"normal(0, 10)"`. Success! #' #' ## `contr.equalprior_deviations` #' #' Useful for setting priors in terms of the deviations of each mean from the #' grand mean - the scales of the priors defines the prior distribution of the #' distance (above, below) the mean of one of the levels might have from the #' overall mean. (See examples.) #' #' #' @references #' Rouder, J. N., Morey, R. D., Speckman, P. L., & Province, J. M. (2012). #' Default Bayes factors for ANOVA designs. *Journal of Mathematical #' Psychology*, 56(5), 356-374. https://doi.org/10.1016/j.jmp.2012.08.001 #' #' @return A `matrix` with n rows and k columns, with k=n-1 if contrasts is #' `TRUE` and k=n if contrasts is `FALSE`. #' #' @aliases contr.bayes contr.orthonorm #' #' @examples #' contr.equalprior(2) # Q_2 in Rouder et al. (2012, p. 363) #' #' contr.equalprior(5) # equivalent to Q_5 in Rouder et al. (2012, p. 363) #' #' ## check decomposition #' Q3 <- contr.equalprior(3) #' Q3 %*% t(Q3) ## 2/3 on diagonal and -1/3 on off-diagonal elements #' @export contr.equalprior <- function(n, contrasts = TRUE, sparse = FALSE) { contr <- stats::contr.treatment(n, contrasts = FALSE, base = 1, sparse = sparse & !contrasts ) k <- nrow(contr) contr <- contr - 1 / k if (contrasts) { contr <- eigen(contr)$vectors[, seq_len(k - 1), drop = FALSE] } contr } #' @export #' @rdname contr.equalprior contr.equalprior_pairs <- function(n, contrasts = TRUE, sparse = FALSE) { contr <- contr.equalprior(n, contrasts, sparse) / sqrt(2) contr } #' @export #' @rdname contr.equalprior contr.equalprior_deviations <- function(n, contrasts = TRUE, sparse = FALSE) { contr <- contr.equalprior(n, contrasts, sparse) n <- nrow(contr) contr / sqrt(1 - 1 / n) } # OLD ------------------------------ #' @export contr.orthonorm <- function(n, contrasts = TRUE) { .Deprecated(new = "contr.equalprior", old = "contr.orthonorm") contr.equalprior(n, contrasts = contrasts) } #' @export contr.bayes <- function(n, contrasts = TRUE) { .Deprecated(new = "contr.equalprior", old = "contr.bayes") contr.equalprior(n, contrasts = contrasts) } bayestestR/R/reshape_iterations.R0000644000176200001440000000510714461433341016621 0ustar liggesusers#' Reshape estimations with multiple iterations (draws) to long format #' #' Reshape a wide data.frame of iterations (such as posterior draws or #' bootsrapped samples) as columns to long format. Instead of having all #' iterations as columns (e.g., `iter_1, iter_2, ...`), will return 3 columns #' with the `\*_index` (the previous index of the row), the `\*_group` (the #' iteration number) and the `\*_value` (the value of said iteration). #' #' @param x A data.frame containing posterior draws obtained from #' `estimate_response` or `estimate_link`. #' @param prefix The prefix of the draws (for instance, `"iter_"` for columns #' named as `iter_1, iter_2, iter_3`). If more than one are provided, will #' search for the first one that matches. #' @examples #' \donttest{ #' if (require("rstanarm")) { #' model <- stan_glm(mpg ~ am, data = mtcars, refresh = 0) #' draws <- insight::get_predicted(model) #' long_format <- reshape_iterations(draws) #' head(long_format) #' } #' } #' @return Data frame of reshaped draws in long format. #' @export reshape_iterations <- function(x, prefix = c("draw", "iter", "iteration", "sim")) { # Accomodate output from get_predicted if (inherits(x, "get_predicted") && "iterations" %in% names(attributes(x))) { x <- as.data.frame(x) } # Find columns' name prefix <- prefix[min(which(sapply(tolower(prefix), function(prefix) sum(grepl(prefix, tolower(names(x)), fixed = TRUE)) > 1)))] if (is.na(prefix) || is.null(prefix)) { insight::format_error( "Couldn't find columns corresponding to iterations in your dataframe, please specify the correct prefix." ) } # Get column names iter_cols <- tolower(names(x))[grepl(prefix, tolower(names(x)), fixed = TRUE)] # Drop "_" if prefix ends with it newname <- ifelse(endsWith(prefix, "_"), substr(prefix, 1, nchar(prefix) - 1), prefix) # Create Index column index_col <- paste0(newname, "_index") if (index_col %in% names(x)) index_col <- paste0(".", newname, "_index") x[[index_col]] <- seq_len(nrow(x)) # Reshape long <- stats::reshape(x, varying = iter_cols, idvar = index_col, v.names = paste0(newname, "_value"), timevar = paste0(newname, "_group"), direction = "long" ) row.names(long) <- NULL class(long) <- class(long)[which(inherits(long, "data.frame")):length(class(long))] long } #' @rdname reshape_iterations #' @export reshape_draws <- function(x, prefix = c("draw", "iter", "iteration", "sim")) { .Deprecated("reshape_iterations") reshape_iterations(x, prefix) } bayestestR/R/bayesfactor_parameters.R0000644000176200001440000005066114650172354017467 0ustar liggesusers#' Bayes Factors (BF) for a Single Parameter #' #' This method computes Bayes factors against the null (either a point or an #' interval), based on prior and posterior samples of a single parameter. This #' Bayes factor indicates the degree by which the mass of the posterior #' distribution has shifted further away from or closer to the null value(s) #' (relative to the prior distribution), thus indicating if the null value has #' become less or more likely given the observed data. #' \cr \cr #' When the null is an interval, the Bayes factor is computed by comparing the #' prior and posterior odds of the parameter falling within or outside the null #' interval (Morey & Rouder, 2011; Liao et al., 2020); When the null is a point, #' a Savage-Dickey density ratio is computed, which is also an approximation of #' a Bayes factor comparing the marginal likelihoods of the model against a #' model in which the tested parameter has been restricted to the point null #' (Wagenmakers et al., 2010; Heck, 2019). #' \cr \cr #' Note that the `logspline` package is used for estimating densities and #' probabilities, and must be installed for the function to work. #' \cr \cr #' `bayesfactor_pointnull()` and `bayesfactor_rope()` are wrappers #' around `bayesfactor_parameters` with different defaults for the null to #' be tested against (a point and a range, respectively). Aliases of the main #' functions are prefixed with `bf_*`, like `bf_parameters()` or #' `bf_pointnull()`. #' \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 numerical vector, `stanreg` / `brmsfit` object, #' `emmGrid` or a data frame - representing a posterior distribution(s) #' from (see 'Details'). #' @param prior An object representing a prior distribution (see 'Details'). #' @param direction Test type (see 'Details'). One of `0`, #' `"two-sided"` (default, two tailed), `-1`, `"left"` (left #' tailed) or `1`, `"right"` (right tailed). #' @param null Value of the null, either a scalar (for point-null) or a range #' (for a interval-null). #' @param ... Arguments passed to and from other methods. (Can be used to pass #' arguments to internal [logspline::logspline()].) #' @inheritParams hdi #' #' @return A data frame containing the (log) Bayes factor representing evidence #' *against* the null (Use `as.numeric()` to extract the non-log Bayes #' factors; see examples). #' #' @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 #' This method is used to compute Bayes factors based on prior and posterior #' distributions. #' #' \subsection{One-sided & Dividing Tests (setting an order restriction)}{ #' One sided tests (controlled by `direction`) are conducted by restricting #' the prior and posterior of the non-null values (the "alternative") to one #' side of the null only (\cite{Morey & Wagenmakers, 2014}). For example, if we #' have a prior hypothesis that the parameter should be positive, the #' alternative will be restricted to the region to the right of the null (point #' or interval). For example, for a Bayes factor comparing the "null" of `0-0.1` #' to the alternative `>0.1`, we would set #' `bayesfactor_parameters(null = c(0, 0.1), direction = ">")`. #' \cr\cr #' It is also possible to compute a Bayes factor for **dividing** #' hypotheses - that is, for a null and alternative that are complementary, #' opposing one-sided hypotheses (\cite{Morey & Wagenmakers, 2014}). For #' example, for a Bayes factor comparing the "null" of `<0` to the alternative #' `>0`, we would set `bayesfactor_parameters(null = c(-Inf, 0))`. #' } #' #' @section Setting the correct `prior`: #' For the computation of Bayes factors, the model priors must be proper priors #' (at the very least they should be *not flat*, and it is preferable that #' they be *informative*); As the priors for the alternative get wider, the #' likelihood of the null value(s) increases, to the extreme that for completely #' flat priors the null is infinitely more favorable than the alternative (this #' is called *the Jeffreys-Lindley-Bartlett paradox*). Thus, you should #' only ever try (or want) to compute a Bayes factor when you have an informed #' prior. #' \cr\cr #' (Note that by default, `brms::brm()` uses flat priors for fixed-effects; #' See example below.) #' \cr\cr #' It is important to provide the correct `prior` for meaningful results. #' #' - When `posterior` is a numerical vector, `prior` should also be a numerical vector. #' - When `posterior` is a `data.frame`, `prior` should also be a `data.frame`, with matching column order. #' - When `posterior` is a `stanreg`, `brmsfit` or other supported Bayesian model: #' - `prior` can be set to `NULL`, in which case prior samples are drawn internally. #' - `prior` can also be a model equivalent to `posterior` but with samples from #' the priors *only*. See [unupdate()]. #' - **Note:** When `posterior` is a `brmsfit_multiple` model, `prior` **must** be provided. #' - When `posterior` is an `emmGrid` / `emm_list` object: #' - `prior` should also be an `emmGrid` / `emm_list` object equivalent to `posterior` but #' created with a model of priors samples *only*. See [unupdate()]. #' - `prior` can also be the original (posterior) *model*. If so, the function will try to #' update the `emmGrid` / `emm_list` to use the [unupdate()]d prior-model. #' (*This cannot be done for `brmsfit` models.*) #' - **Note**: When the `emmGrid` has undergone any transformations (`"log"`, `"response"`, etc.), #' or `regrid`ing, then `prior` must be an `emmGrid` object, as stated above. #' #' @section Interpreting Bayes Factors: #' A Bayes factor greater than 1 can be interpreted as evidence against the #' null, at which one convention is that a Bayes factor greater than 3 can be #' considered as "substantial" evidence against the null (and vice versa, a #' Bayes factor smaller than 1/3 indicates substantial evidence in favor of the #' null-model) (\cite{Wetzels et al. 2011}). #' #' @examplesIf require("logspline") #' library(bayestestR) #' prior <- distribution_normal(1000, mean = 0, sd = 1) #' posterior <- distribution_normal(1000, mean = .5, sd = .3) #' (BF_pars <- bayesfactor_parameters(posterior, prior, verbose = FALSE)) #' #' as.numeric(BF_pars) #' #' @examplesIf require("rstanarm") && require("emmeans") && require("logspline") #' \donttest{ #' # rstanarm models #' # --------------- #' contrasts(sleep$group) <- contr.equalprior_pairs # see vingette #' stan_model <- suppressWarnings(stan_lmer( #' extra ~ group + (1 | ID), #' data = sleep, #' refresh = 0 #' )) #' bayesfactor_parameters(stan_model, verbose = FALSE) #' bayesfactor_parameters(stan_model, null = rope_range(stan_model)) #' #' # emmGrid objects #' # --------------- #' group_diff <- pairs(emmeans(stan_model, ~group, data = sleep)) #' bayesfactor_parameters(group_diff, prior = stan_model, verbose = FALSE) #' #' # Or #' # group_diff_prior <- pairs(emmeans(unupdate(stan_model), ~group)) #' # bayesfactor_parameters(group_diff, prior = group_diff_prior, verbose = FALSE) #' } #' @examplesIf require("brms") && require("logspline") #' # brms models #' # ----------- #' \dontrun{ #' 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 #' )) #' bayesfactor_parameters(brms_model, verbose = FALSE) #' } #' #' @references #' #' - Wagenmakers, E. J., Lodewyckx, T., Kuriyal, H., and Grasman, R. (2010). #' Bayesian hypothesis testing for psychologists: A tutorial on the #' Savage-Dickey method. Cognitive psychology, 60(3), 158-189. #' #' - Heck, D. W. (2019). A caveat on the Savage–Dickey density ratio: The #' case of computing Bayes factors for regression parameters. British Journal of #' Mathematical and Statistical Psychology, 72(2), 316-333. #' #' - 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. #' #' - Liao, J. G., Midya, V., & Berg, A. (2020). Connecting and contrasting #' the Bayes factor and a modified ROPE procedure for testing interval null #' hypotheses. The American Statistician, 1-19. #' #' - 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} #' #' @author Mattan S. Ben-Shachar #' #' @export bayesfactor_parameters <- function(posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ...) { UseMethod("bayesfactor_parameters") } #' @rdname bayesfactor_parameters #' @export bayesfactor_pointnull <- function(posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ...) { if (length(null) > 1L && verbose) { insight::format_alert("`null` is a range - computing a ROPE based Bayes factor.") } bayesfactor_parameters( posterior = posterior, prior = prior, direction = direction, null = null, verbose = verbose, ... ) } #' @rdname bayesfactor_parameters #' @export bayesfactor_rope <- function(posterior, prior = NULL, direction = "two-sided", null = rope_range(posterior, verbose = FALSE), verbose = TRUE, ...) { if (length(null) < 2 && verbose) { insight::format_alert("'null' is a point - computing a Savage-Dickey (point null) Bayes factor.") } bayesfactor_parameters( posterior = posterior, prior = prior, direction = direction, null = null, verbose = verbose, ... ) } #' @rdname bayesfactor_parameters #' @export bf_parameters <- bayesfactor_parameters #' @rdname bayesfactor_parameters #' @export bf_pointnull <- bayesfactor_pointnull #' @rdname bayesfactor_parameters #' @export bf_rope <- bayesfactor_rope #' @rdname bayesfactor_parameters #' @export bayesfactor_parameters.numeric <- function(posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ...) { # nm <- insight::safe_deparse(substitute(posterior) if (is.null(prior)) { prior <- posterior if (verbose) { insight::format_warning( "Prior not specified! Please specify a prior (in the form 'prior = distribution_normal(1000, 0, 1)') to get meaningful results." ) } } prior <- data.frame(X = prior) posterior <- data.frame(X = posterior) # colnames(posterior) <- colnames(prior) <- nm # Get BFs sdbf <- bayesfactor_parameters.data.frame( posterior = posterior, prior = prior, direction = direction, null = null, verbose = verbose, ... ) sdbf$Parameter <- NULL sdbf } #' @rdname bayesfactor_parameters #' @export bayesfactor_parameters.stanreg <- function(posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("conditional", "location", "smooth_terms", "sigma", "zi", "zero_inflated", "all"), 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 BFs temp <- bayesfactor_parameters.data.frame( posterior = samps$posterior, prior = samps$prior, direction = direction, null = null, verbose = verbose, ... ) bf_val <- .prepare_output(temp, cleaned_parameters, inherits(posterior, "stanmvreg")) class(bf_val) <- class(temp) attr(bf_val, "clean_parameters") <- cleaned_parameters # don't change the name of this attribute - it is used only internally for "see" and printing attr(bf_val, "hypothesis") <- attr(temp, "hypothesis") attr(bf_val, "direction") <- attr(temp, "direction") attr(bf_val, "plot_data") <- attr(temp, "plot_data") bf_val } #' @rdname bayesfactor_parameters #' @export bayesfactor_parameters.brmsfit <- bayesfactor_parameters.stanreg #' @rdname bayesfactor_parameters #' @export bayesfactor_parameters.blavaan <- function(posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ...) { cleaned_parameters <- insight::clean_parameters(posterior) samps <- .clean_priors_and_posteriors(posterior, prior, verbose = verbose ) # Get BFs temp <- bayesfactor_parameters.data.frame( posterior = samps$posterior, prior = samps$prior, direction = direction, null = null, verbose = verbose, ... ) bf_val <- .prepare_output(temp, cleaned_parameters) class(bf_val) <- class(temp) attr(bf_val, "clean_parameters") <- cleaned_parameters # don't change the name of this attribute - it is used only internally for "see" and printing attr(bf_val, "hypothesis") <- attr(temp, "hypothesis") attr(bf_val, "direction") <- attr(temp, "direction") attr(bf_val, "plot_data") <- attr(temp, "plot_data") bf_val } #' @export bayesfactor_parameters.emmGrid <- function(posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ...) { samps <- .clean_priors_and_posteriors( posterior, prior, verbose = verbose ) # Get BFs bayesfactor_parameters.data.frame( posterior = samps$posterior, prior = samps$prior, direction = direction, null = null, verbose = verbose, ... ) } #' @export bayesfactor_parameters.emm_list <- bayesfactor_parameters.emmGrid #' @rdname bayesfactor_parameters #' @export bayesfactor_parameters.data.frame <- function(posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ...) { # find direction direction <- .get_direction(direction) if (is.null(prior)) { prior <- posterior if (verbose) { insight::format_warning( "Prior not specified! Please specify priors (with column order matching 'posterior') to get meaningful results." ) } } if (verbose && length(null) == 1L && (nrow(posterior) < 4e4 || nrow(prior) < 4e4)) { insight::format_warning( "Bayes factors might not be precise.", "For precise Bayes factors, sampling at least 40,000 posterior samples is recommended." ) } sdlogbf <- numeric(ncol(posterior)) for (par in seq_along(posterior)) { sdlogbf[par] <- .logbayesfactor_parameters( posterior[[par]], prior[[par]], direction = direction, null = null, ... ) } bf_val <- data.frame( Parameter = colnames(posterior), log_BF = sdlogbf, stringsAsFactors = FALSE ) class(bf_val) <- unique(c( "bayesfactor_parameters", "see_bayesfactor_parameters", class(bf_val) )) attr(bf_val, "hypothesis") <- null # don't change the name of this attribute - it is used only internally for "see" and printing attr(bf_val, "direction") <- direction attr(bf_val, "plot_data") <- .make_BF_plot_data(posterior, prior, direction, null, ...) bf_val } #' @export bayesfactor_parameters.draws <- function(posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ...) { bayesfactor_parameters( .posterior_draws_to_df(posterior), prior = prior, direction = direction, null = null, verbose = verbose, ... ) } #' @export bayesfactor_parameters.rvar <- bayesfactor_parameters.draws #' @keywords internal .logbayesfactor_parameters <- function(posterior, prior, direction = 0, null = 0, ...) { stopifnot(length(null) %in% c(1, 2)) if (isTRUE(all.equal(posterior, prior))) { return(0) } insight::check_if_installed("logspline") if (length(null) == 1) { relative_loglikelihood <- function(samples) { f_samples <- .logspline(samples, ...) d_samples <- logspline::dlogspline(null, f_samples, log = TRUE) if (direction < 0) { norm_samples <- logspline::plogspline(null, f_samples) } else if (direction > 0) { norm_samples <- 1 - logspline::plogspline(null, f_samples) } else { norm_samples <- 1 } d_samples - log(norm_samples) } } else if (length(null) == 2) { null <- sort(null) null[is.infinite(null)] <- 1.797693e+308 * sign(null[is.infinite(null)]) relative_loglikelihood <- function(samples) { f_samples <- .logspline(samples, ...) p_samples <- diff(logspline::plogspline(null, f_samples)) if (direction < 0) { norm_samples <- logspline::plogspline(min(null), f_samples) } else if (direction > 0) { norm_samples <- 1 - logspline::plogspline(max(null), f_samples) } else { norm_samples <- 1 - p_samples } log(p_samples) - log(norm_samples) } } relative_loglikelihood(prior) - relative_loglikelihood(posterior) } # Bad Methods ------------------------------------------------------------- #' @export bayesfactor_parameters.bayesfactor_models <- function(...) { insight::format_error( "Oh no, 'bayesfactor_parameters()' does not know how to deal with multiple models :(", "You might want to use 'bayesfactor_inclusion()' here to test specific terms across models." ) } #' @export bayesfactor_parameters.sim <- function(...) { insight::format_error( "Bayes factors are based on the shift from a prior to a posterior.", "Since simulated draws are not based on any priors, computing Bayes factors does not make sense :(", "You might want to try `rope`, `ci`, `pd` or `pmap` for posterior-based inference." ) } #' @export bayesfactor_parameters.sim.merMod <- bayesfactor_parameters.sim bayestestR/R/print.rope.R0000644000176200001440000000547414311464510015034 0ustar liggesusers#' @export print.rope <- function(x, digits = 2, ...) { orig_x <- x # If the model is multivariate, we have have different ROPES depending on # the outcome variable. is_multivariate <- length(unique(x$Response)) > 1 if (isTRUE(is_multivariate)) { insight::print_color(sprintf( "# Proportion%s of samples inside the ROPE.\nROPE with depends on outcome variable.\n\n", ifelse(all(x$CI[1] == x$CI), "", "s") ), "blue") } else { insight::print_color(sprintf( "# Proportion%s of samples inside the ROPE [%.*f, %.*f]:\n\n", ifelse(all(x$CI[1] == x$CI), "", "s"), digits, x$ROPE_low[1], digits, x$ROPE_high[1] ), "blue") } # I think this is something nobody will understand and we'll probably forget # why we did this, so I'll comment a bit... # These are the base columns we want to print cols <- c( "Parameter", "ROPE_Percentage", "Effects", "Component", if (is_multivariate) c("ROPE_low", "ROPE_high") ) # In case we have ropes for different CIs, we also want this information # So we first check if values in the CI column differ, and if so, we also # keep this column for printing if (!all(x$CI[1] == x$CI)) { cols <- c("CI", cols) } # Either way, we need to know the different CI-values, so we can # split the data frame for printing later... ci <- unique(x$CI) # now we check which of the requested columns are actually in our data frame "x" # "x" may differ, depending on if "rope()" was called with a model-object, # or with a simple vector. So we can't hard-code this x <- subset(x, select = intersect(cols, colnames(x))) # This is just cosmetics, to have nicer column names and values x$ROPE_Percentage <- sprintf("%.*f %%", digits, x$ROPE_Percentage * 100) colnames(x)[which(colnames(x) == "ROPE_Percentage")] <- "inside ROPE" # Add ROPE width for multivariate models if (isTRUE(is_multivariate)) { # This is just cosmetics, to have nicer column names and values x$ROPE_low <- sprintf("[%.*f, %.*f]", digits, x$ROPE_low, digits, x$ROPE_high) colnames(x)[which(colnames(x) == "ROPE_low")] <- "ROPE width" x$ROPE_high <- NULL } # In case we have multiple CI values, we create a subset for each CI value. # Else, parameter-rows would be mixed up with both CIs, which is a bit # more difficult to read... if (length(ci) == 1) { # print complete data frame, because we have no different CI values here .print_data_frame(x, digits = digits) } else { for (i in ci) { xsub <- x[x$CI == i, -which(colnames(x) == "CI"), drop = FALSE] insight::print_color(sprintf("ROPE for the %s%% HDI:\n\n", 100 * i), "cyan") .print_data_frame(xsub, digits = digits) cat("\n") } } invisible(orig_x) } bayestestR/R/bayestestR-package.R0000644000176200001440000000166214357655465016472 0ustar liggesusers#' \code{bayestestR} #' #' @title bayestestR: Describing Effects and their Uncertainty, Existence and #' Significance within the Bayesian Framework #' #' @description #' #' Existing R packages allow users to easily fit a large variety of models #' and extract and visualize the posterior draws. However, most of these #' packages only return a limited set of indices (e.g., point-estimates and #' CIs). **bayestestR** provides a comprehensive and consistent set of #' functions to analyze and describe posterior distributions generated by a #' variety of models objects, including popular modeling packages such as #' **rstanarm**, **brms** or **BayesFactor**. #' #' References: #' #' - Makowski et al. (2019) \doi{10.21105/joss.01541} #' - Makowski et al. (2019) \doi{10.3389/fpsyg.2019.02767} #' #' @docType package #' @aliases bayestestR bayestestR-package #' @name bayestestR-package #' @keywords internal "_PACKAGE" bayestestR/R/utils_clean_stan_parameters.R0000644000176200001440000000140414276606712020507 0ustar liggesusers#' @keywords internal .clean_up_tmp_stanreg <- function(tmp, group, cols, parms) { tmp$Group <- group tmp$Parameter <- rep(parms, each = nrow(tmp) / length(parms)) rownames(tmp) <- NULL tmp <- tmp[, c("Parameter", cols)] # clean random effects notation from parameters # tmp$Parameter <- gsub("b\\[(.*) (.*)\\]", "\\2", tmp$Parameter) tmp } #' @keywords internal .clean_up_tmp_brms <- function(tmp, group, component, cols, parms) { tmp$Group <- group tmp$Component <- component tmp$Parameter <- rep(parms, each = nrow(tmp) / length(parms)) rownames(tmp) <- NULL tmp <- tmp[, c("Parameter", cols)] # clean random effects notation from parameters # tmp$Parameter <- gsub("r_(.*)\\.(.*)\\.", "\\1", tmp$Parameter) tmp } bayestestR/R/bayesfactor.R0000644000176200001440000000646414560763455015256 0ustar liggesusers#' Bayes Factors (BF) #' #' This function compte the Bayes factors (BFs) that are appropriate to the #' input. For vectors or single models, it will compute [`BFs for single #' parameters()`][bayesfactor_parameters], or is `hypothesis` is specified, #' [`BFs for restricted models()`][bayesfactor_restricted]. For multiple models, #' it will return the BF corresponding to [`comparison between #' models()`][bayesfactor_models] and if a model comparison is passed, it will #' compute the [`inclusion BF()`][bayesfactor_inclusion]. #' \cr\cr #' For a complete overview of these functions, read the [Bayes factor vignette](https://easystats.github.io/bayestestR/articles/bayes_factors.html). #' #' @param ... A numeric vector, model object(s), or the output from #' `bayesfactor_models`. #' @inheritParams bayesfactor_parameters #' @inheritParams bayesfactor_restricted #' @inheritParams bayesfactor_models #' @inheritParams bayesfactor_inclusion #' #' @return Some type of Bayes factor, depending on the input. See [bayesfactor_parameters()], [bayesfactor_models()] or [bayesfactor_inclusion()] #' #' @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") && require("logspline") #' library(bayestestR) #' #' prior <- distribution_normal(1000, mean = 0, sd = 1) #' posterior <- distribution_normal(1000, mean = .5, sd = .3) #' #' bayesfactor(posterior, prior = prior, verbose = FALSE) #' #' \donttest{ #' # rstanarm models #' # --------------- #' model <- suppressWarnings(rstanarm::stan_lmer(extra ~ group + (1 | ID), data = sleep)) #' bayesfactor(model, verbose = FALSE) #' #' # Frequentist models #' # --------------- #' m0 <- lm(extra ~ 1, data = sleep) #' m1 <- lm(extra ~ group, data = sleep) #' m2 <- lm(extra ~ group + ID, data = sleep) #' #' comparison <- bayesfactor(m0, m1, m2) #' comparison #' #' bayesfactor(comparison) #' } #' @export bayesfactor <- function(..., prior = NULL, direction = "two-sided", null = 0, hypothesis = NULL, effects = c("fixed", "random", "all"), verbose = TRUE, denominator = 1, match_models = FALSE, prior_odds = NULL) { mods <- list(...) effects <- match.arg(effects) if (length(mods) > 1) { bayesfactor_models(..., denominator = denominator) } else if (inherits(mods[[1]], "bayesfactor_models")) { bayesfactor_inclusion(..., match_models = match_models, prior_odds = prior_odds) } else if (inherits(mods[[1]], "BFBayesFactor")) { if (inherits(mods[[1]]@numerator[[1]], "BFlinearModel")) { bayesfactor_inclusion(..., match_models = match_models, prior_odds = prior_odds) } else { bayesfactor_models(...) } } else if (is.null(hypothesis)) { bayesfactor_parameters( ..., prior = prior, direction = direction, null = null, effects = effects, verbose = verbose ) } else { bayesfactor_restricted(..., prior = prior, verbose = verbose, effects = effects ) } } bayestestR/R/utils_bayesfactor.R0000644000176200001440000003100014650172354016446 0ustar liggesusers# clean priors and posteriors --------------------------------------------- #' @keywords internal .clean_priors_and_posteriors <- function(posterior, prior, ...) { UseMethod(".clean_priors_and_posteriors") } #' @keywords internal .clean_priors_and_posteriors.stanreg <- function(posterior, prior, verbose = TRUE, ...) { # Get Priors if (is.null(prior)) { prior <- posterior } prior <- try(unupdate(prior, verbose = verbose), silent = TRUE) if (methods::is(prior, "try-error")) { if (grepl("flat priors", prior, fixed = TRUE)) { prior <- paste0( prior, "Could not therefore compute Bayes factors, as these inform about ", "the raltive likelihood of two 'hypotheses', and flat priors provide no ", "likelihood.\n", "See '?bayesfactor_parameters' for more information.\n" ) } insight::format_error(prior) } prior <- insight::get_parameters(prior, ...) posterior <- insight::get_parameters(posterior, ...) list( posterior = posterior, prior = prior ) } #' @keywords internal .clean_priors_and_posteriors.brmsfit <- .clean_priors_and_posteriors.stanreg #' @keywords internal .clean_priors_and_posteriors.blavaan <- function(posterior, prior, verbose = TRUE, ...) { # Get Priors if (is.null(prior)) { prior <- posterior } prior <- unupdate(prior, verbose = verbose) prior <- insight::get_parameters(prior) posterior <- insight::get_parameters(posterior) list( posterior = posterior, prior = prior ) } #' @keywords internal .clean_priors_and_posteriors.emmGrid <- function(posterior, prior, verbose = TRUE, ...) { insight::check_if_installed("emmeans") if (is.null(prior)) { prior <- posterior if (verbose) { insight::format_warning("Prior not specified! Please provide the original model to get meaningful results.") } } if (!inherits(prior, "emmGrid")) { # then is it a model on.exit( insight::format_error(paste0( "Unable to reconstruct prior estimates.\n", "Perhaps the emmGrid object has been transformed or regrid()-ed?\n", "See function details.\n\n", "Instead, you can reestimate the emmGrid with a prior model, Try:\n", "\tprior_model <- unupdate(mode)\n", "\tprior_emmgrid <- emmeans(prior_model, ...) # pass this as the 'prior' argument." )) ) if (inherits(prior, "brmsfit")) { insight::format_error("Cannot rebuild prior emmGrid from a brmsfit model.") } prior <- try(unupdate(prior, verbose = verbose), silent = TRUE) if (inherits(prior, "try-error")) { on.exit() # undo general error message if (grepl("flat priors", prior, fixed = TRUE)) { prior <- paste0( prior, "Could not therefore compute Bayes factors, as these inform about ", "the raltive likelihood of two 'hypotheses', and flat priors provide no ", "likelihood.\n", "See '?bayesfactor_parameters' for more information.\n" ) } insight::format_error(prior) } prior <- suppressWarnings(emmeans::ref_grid(prior)) prior <- prior@post.beta if (!isTRUE(all.equal(colnames(prior), colnames(posterior@post.beta)))) { insight::format_error("post.beta and prior.beta are non-conformable arguments.") } prior <- stats::update(posterior, post.beta = prior) on.exit() # undo general error message } prior <- insight::get_parameters(prior) posterior <- insight::get_parameters(posterior) list( posterior = posterior, prior = prior ) } .clean_priors_and_posteriors.emm_list <- function(posterior, prior, verbose = TRUE, ...) { if (is.null(prior)) { prior <- posterior if (verbose) { insight::format_warning("Prior not specified! Please provide the original model to get meaningful results.") } } if (!inherits(prior, "emm_list")) { # prior is a model if (inherits(prior, "brmsfit")) { insight::format_error("Cannot rebuild prior emm_list from a brmsfit model.") } prior <- try(unupdate(prior, verbose = verbose), silent = TRUE) if (inherits(prior, "try-error")) { if (grepl("flat priors", prior, fixed = TRUE)) { prior <- paste0( prior, "Could not therefore compute Bayes factors, as these inform about ", "the raltive likelihood of two 'hypotheses', and flat priors provide no ", "likelihood.\n", "See '?bayesfactor_parameters' for more information.\n" ) } insight::format_error(prior) } } # prior is now a model, or emm_list # is it a model? pass_em <- inherits(prior, "emm_list") res <- lapply(seq_along(posterior), function(i) { .clean_priors_and_posteriors.emmGrid( posterior[[i]], prior = if (pass_em) prior[[i]] else prior, verbose = verbose ) }) posterior <- do.call("cbind", lapply(res, "[[", "posterior")) prior <- do.call("cbind", lapply(res, "[[", "prior")) list( posterior = posterior, prior = prior ) } # BMA --------------------------------------------------------------------- #' @keywords internal .get_model_table <- function(BFGrid, priorOdds = NULL, add_effects_table = TRUE, ...) { denominator <- attr(BFGrid, "denominator") BFGrid <- rbind(BFGrid[denominator, ], BFGrid[-denominator, ]) attr(BFGrid, "denominator") <- 1 # This looks like it does nothing, but this is needed to prevent Inf in large BFs. # Small BFs are better than large BFs BFGrid <- stats::update(BFGrid, reference = "top") # Prior and post odds Modelnames <- BFGrid$Model if (is.null(priorOdds)) { priorOdds <- rep(1, length(Modelnames) - 1) } priorOdds <- c(1, priorOdds) prior_logodds <- log(priorOdds) posterior_logodds <- prior_logodds + BFGrid$log_BF # norm prior_logodds <- prior_logodds - log(sum(exp(prior_logodds))) posterior_logodds <- posterior_logodds - log(sum(exp(posterior_logodds))) df.model <- data.frame( Modelnames, priorProbs = exp(prior_logodds), postProbs = exp(posterior_logodds), stringsAsFactors = FALSE ) # add effects table if (add_effects_table) { for (m in seq_len(nrow(df.model))) { tmp_terms <- .make_terms(df.model$Modelnames[m]) if (length(tmp_terms) > 0) { missing_terms <- !tmp_terms %in% colnames(df.model) if (any(missing_terms)) df.model[, tmp_terms[missing_terms]] <- NA df.model[m, tmp_terms] <- TRUE } } } df.model[is.na(df.model)] <- FALSE df.model } #' @keywords internal .make_terms <- function(formula) { sort_interactions <- function(x) { if (grepl(":", x, fixed = TRUE)) { effs <- unlist(strsplit(x, ":", fixed = TRUE)) x <- paste0(sort(effs), collapse = ":") } x } formula.f <- stats::as.formula(paste0("~", formula)) all.terms <- attr(stats::terms(formula.f), "term.labels") # Fixed fix_trms <- all.terms[!grepl("|", all.terms, fixed = TRUE)] # no random if (length(fix_trms) > 0) { fix_trms <- sapply(fix_trms, sort_interactions) } # Random random_parts <- paste0(grep("|", all.terms, fixed = TRUE, value = TRUE)) # only random if (length(random_parts) == 0) { return(fix_trms) } random_units <- sub("^.+\\|\\s+", "", random_parts) tmp_random <- lapply( sub("\\|.+$", "", random_parts), function(x) stats::as.formula(paste0("~", x)) ) rand_trms <- vector("list", length(random_parts)) for (i in seq_along(random_parts)) { tmp_trms <- attr(stats::terms.formula(tmp_random[[i]]), "term.labels") tmp_trms <- sapply(tmp_trms, sort_interactions) if (!any(unlist(strsplit(as.character(tmp_random[[i]])[[2]], " + ", fixed = TRUE)) == "0")) { tmp_trms <- c("1", tmp_trms) } rand_trms[[i]] <- paste0(tmp_trms, ":", random_units[[i]]) } c(fix_trms, unlist(rand_trms)) } # make_BF_plot_data ------------------------------------------------------- #' @keywords internal .make_BF_plot_data <- function(posterior, prior, direction, null, extend_scale = 0.05, precision = 2^8, ...) { insight::check_if_installed("logspline") estimate_samples_density <- function(samples) { nm <- insight::safe_deparse_symbol(substitute(samples)) samples <- utils::stack(samples) samples <- split(samples, samples$ind) samples <- lapply(samples, function(data) { # 1. estimate density x <- data$values 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])) ) x_range <- range(c(x_range, null)[!is.infinite(c(x_range, null))]) 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) # x_axis <- sort(unique(c(x_axis, null))) f_x <- .logspline(x, ...) y <- logspline::dlogspline(x_axis, f_x) d_points <- data.frame(x = x_axis, y = y) # 2. estimate points d_null <- stats::approx(d_points$x, d_points$y, xout = null) d_null$y[is.na(d_null$y)] <- 0 # 3. direction? if (direction > 0) { d_points <- d_points[d_points$x >= min(null), , drop = FALSE] if (is.infinite(min(null))) { norm_factor <- 1 } else { norm_factor <- 1 - logspline::plogspline(min(null), f_x) } d_points$y <- d_points$y / norm_factor d_null$y <- d_null$y / norm_factor } else if (direction < 0) { d_points <- d_points[d_points$x <= max(null), , drop = FALSE] if (is.infinite(max(null))) { norm_factor <- 1 } else { norm_factor <- logspline::plogspline(max(null), f_x) } d_points$y <- d_points$y / norm_factor d_null$y <- d_null$y / norm_factor } d_points$ind <- d_null$ind <- data$ind[1] list(d_points, d_null) }) # 4a. organize point0 <- lapply(samples, function(.) as.data.frame(.[[2]])) point0 <- do.call("rbind", point0) samplesX <- lapply(samples, function(.) .[[1]]) samplesX <- do.call("rbind", samplesX) samplesX$Distribution <- point0$Distribution <- nm rownames(samplesX) <- rownames(point0) <- NULL list(samplesX, point0) } # 4b. orgenize posterior <- estimate_samples_density(posterior) prior <- estimate_samples_density(prior) list( plot_data = rbind(posterior[[1]], prior[[1]]), d_points = rbind(posterior[[2]], prior[[2]]) ) } # As numeric vector ------------------------------------------------------- #' @export as.numeric.bayesfactor_inclusion <- function(x, log = FALSE, ...) { out <- x[["log_BF"]] if (!log) out <- exp(out) return(out) } #' @export as.numeric.bayesfactor_models <- as.numeric.bayesfactor_inclusion #' @export as.numeric.bayesfactor_parameters <- as.numeric.bayesfactor_inclusion #' @export as.numeric.bayesfactor_restricted <- as.numeric.bayesfactor_inclusion ## Double: #' @export as.double.bayesfactor_inclusion <- as.numeric.bayesfactor_inclusion #' @export as.double.bayesfactor_models <- as.numeric.bayesfactor_inclusion #' @export as.double.bayesfactor_parameters <- as.numeric.bayesfactor_inclusion #' @export as.double.bayesfactor_restricted <- as.numeric.bayesfactor_inclusion # logspline --------------------------------------------------------------- #' @keywords internal .logspline <- function(x, ...) { insight::check_if_installed("logspline") in_args <- list(...) # arg_names <- names(formals(logspline::logspline, envir = parent.frame())) arg_names <- names(formals(logspline::logspline)) in_args <- in_args[names(in_args) %in% arg_names] in_args <- c(list(x = x), in_args) suppressWarnings(do.call(logspline::logspline, in_args)) } bayestestR/R/utils.R0000644000176200001440000001140114650172354014067 0ustar liggesusers# small wrapper around this commonly used try-catch .safe <- function(code, on_error = NULL) { tryCatch(code, error = function(e) on_error) } # select rows where values in "variable" match "value" #' @keywords internal .select_rows <- function(data, variable, value) { data[which(data[[variable]] == value), ] } #' select numerics columns #' @keywords internal .select_nums <- function(x) { x[unlist(lapply(x, is.numeric))] } #' @keywords internal .get_direction <- function(direction) { if (length(direction) > 1) { insight::format_warning("Using first 'direction' value.") } if (is.numeric(direction[1])) { return(sign(direction[1])) } Value <- c( left = -1, right = 1, "two-sided" = 0, twosided = 0, "one-sided" = 1, onesided = 1, "<" = -1, ">" = 1, "=" = 0, "==" = 0, "-1" = -1, "0" = 0, "1" = 1, "+1" = 1 ) direction <- Value[tolower(direction[1])] if (is.na(direction)) { insight::format_error("Unrecognized 'direction' argument.") } direction } #' @keywords internal .prepare_output <- function(temp, cleaned_parameters, is_stan_mv = FALSE, is_brms_mv = FALSE) { if (is.null(cleaned_parameters)) { return(temp) } if (isTRUE(is_stan_mv)) { # for models with multiple responses, we create a separate response column temp$Response <- gsub("(b\\[)*(.*)\\|(.*)", "\\2", temp$Parameter) # from the parameter names, we can now remove the name of the respone variables for (i in unique(temp$Response)) { temp$Parameter <- gsub(sprintf("%s|", i), "", temp$Parameter, fixed = TRUE) } merge_by <- c("Parameter", "Effects", "Component", "Response") remove_cols <- c("Group", "Cleaned_Parameter", "Function", ".roworder") } else if (isTRUE(is_brms_mv)) { # for models with multiple responses, we create a separate response column temp$Response <- gsub("(.*)_(.*)_(.*)", "\\2", temp$Parameter) merge_by <- c("Parameter", "Effects", "Component", "Response") remove_cols <- c("Group", "Cleaned_Parameter", "Function", ".roworder") } else { # By default, we only merge by these three columns merge_by <- c("Parameter", "Effects", "Component") remove_cols <- c("Group", "Cleaned_Parameter", "Response", "Function", ".roworder") } # in "temp", we have the data frame from the related functions (like # `point_estimate()`, `ci()` etc.). "cleaned_parameters" is a data frame # only with original parameter names, model components and "cleaned" # parameter names (retrieved from `insight::clean_parameters()`). merge_by <- intersect(merge_by, colnames(temp)) temp$.roworder <- seq_len(nrow(temp)) out <- merge(x = temp, y = cleaned_parameters, by = merge_by, all.x = TRUE) # hope this works for stanmvreg... if ((isTRUE(is_stan_mv) || isTRUE(is_brms_mv)) && all(is.na(out$Effects)) && all(is.na(out$Component))) { out$Effects <- cleaned_parameters$Effects[seq_len(nrow(out))] out$Component <- cleaned_parameters$Component[seq_len(nrow(out))] } # this here is required for multiple response models... if (all(is.na(out$Effects)) || all(is.na(out$Component))) { out <- out[!duplicated(out$.roworder), ] } else { out <- out[!is.na(out$Effects) & !is.na(out$Component) & !duplicated(out$.roworder), ] } attr(out, "Cleaned_Parameter") <- out$Cleaned_Parameter[order(out$.roworder)] datawizard::data_remove(out[order(out$.roworder), ], remove_cols, verbose = FALSE) } #' @keywords internal .merge_and_sort <- function(x, y, by, all) { if (is.null(ncol(y))) { return(x) } x$.rowid <- seq_len(nrow(x)) x <- merge(x, y, by = by, all = all) datawizard::data_remove(x[order(x$.rowid), ], ".rowid", verbose = FALSE) } # returns the variables that were used for grouping data frames (dplyr::group_var()) #' @keywords internal .group_vars <- function(x) { # dplyr < 0.8.0 returns attribute "indices" grps <- attr(x, "groups", exact = TRUE) # dplyr < 0.8.0? if (is.null(grps)) { ## TODO fix for dplyr < 0.8 attr(x, "vars", exact = TRUE) } else { setdiff(colnames(grps), ".rows") } } #' @keywords internal .is_baysian_emmeans <- function(x) { if (inherits(x, "emm_list")) { x <- x[[1]] } post.beta <- methods::slot(x, "post.beta") !(all(dim(post.beta) == 1) && is.na(post.beta)) } # safe add cleaned parameter names to a model object .add_clean_parameters_attribute <- function(params, model) { cp <- tryCatch( { insight::clean_parameters(model) }, error = function(e) { NULL } ) attr(params, "clean_parameters") <- cp params } bayestestR/R/utils_hdi_ci.R0000644000176200001440000000537014461433341015372 0ustar liggesusers#' @keywords internal .check_ci_fun <- function(dots) { ci_fun <- "hdi" if (identical(dots$ci_method, "spi")) { ci_fun <- "spi" } ci_fun } #' @keywords internal .check_ci_argument <- function(x, ci, verbose = TRUE) { if (ci > 1) { if (verbose) { insight::format_warning("`ci` should be less than 1, returning NAs.") } return(data.frame( "CI" = ci, "CI_low" = NA, "CI_high" = NA )) } if (ci == 1) { return(data.frame( "CI" = ci, "CI_low" = min(x, na.rm = TRUE), "CI_high" = max(x, na.rm = TRUE) )) } if (length(x) < 3) { if (verbose) { insight::format_warning("The posterior is too short, returning NAs.") } return(data.frame( "CI" = ci, "CI_low" = NA, "CI_high" = NA )) } NULL } #' @keywords internal .compute_interval_dataframe <- function(x, ci, verbose, fun) { numeric_variables <- vapply(x, is.numeric, TRUE) out <- insight::compact_list(lapply( x[, numeric_variables, drop = FALSE], get(fun, asNamespace("bayestestR")), ci = ci, verbose = verbose )) dat <- data.frame( Parameter = rep(names(out), each = length(ci)), do.call(rbind, out), stringsAsFactors = FALSE, row.names = NULL ) # rename for SPI, should be HDI if (identical(fun, "spi")) { class(dat) <- unique(c("bayestestR_hdi", "see_hdi", "bayestestR_spi", class(dat))) } else { class(dat) <- unique(c(paste0("bayestestR_", fun), paste0("see_", fun), class(dat))) } dat } #' @keywords internal .compute_interval_simMerMod <- function(x, ci, effects, parameters, verbose, fun) { fixed <- fixed.data <- NULL random <- random.data <- NULL if (effects %in% c("fixed", "all")) { fixed.data <- insight::get_parameters(x, effects = "fixed", parameters = parameters) fixed <- .compute_interval_dataframe(fixed.data, ci, verbose, fun) fixed$Group <- "fixed" } if (effects %in% c("random", "all")) { random.data <- insight::get_parameters(x, effects = "random", parameters = parameters) random <- .compute_interval_dataframe(random.data, ci, verbose, fun) random$Group <- "random" } d <- do.call(rbind, list(fixed, random)) if (length(unique(d$Group)) == 1) { d <- datawizard::data_remove(d, "Group", verbose = FALSE) } list(result = d, data = do.call(cbind, insight::compact_list(list(fixed.data, random.data)))) } #' @keywords internal .compute_interval_sim <- function(x, ci, parameters, verbose, fun) { fixed.data <- insight::get_parameters(x, parameters = parameters) d <- .compute_interval_dataframe(fixed.data, ci, verbose, fun) list(result = d, data = fixed.data) } bayestestR/R/ci.R0000644000176200001440000002205414461433341013324 0ustar liggesusers#' Confidence/Credible/Compatibility Interval (CI) #' #' Compute Confidence/Credible/Compatibility Intervals (CI) or Support Intervals #' (SI) for Bayesian and frequentist models. The Documentation is accessible #' for: #' #' - [Bayesian models](https://easystats.github.io/bayestestR/articles/credible_interval.html) #' - [Frequentist models](https://easystats.github.io/parameters/reference/ci.default.html) #' #' @param x A `stanreg` or `brmsfit` model, or a vector representing a posterior #' distribution. #' @param method Can be ["ETI"][eti] (default), ["HDI"][hdi], ["BCI"][bci], #' ["SPI"][spi] or ["SI"][si]. #' @param ci Value or vector of probability of the CI (between 0 and 1) #' to be estimated. Default to `0.95` (`95%`). #' @inheritParams hdi #' @inheritParams si #' @inherit hdi seealso #' @family ci #' #' @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 credible interval. #' - `CI_low`, `CI_high` The lower and upper credible interval limits for the parameters. #' #' @note When it comes to interpretation, we recommend thinking of the CI in terms of #' an "uncertainty" or "compatibility" interval, the latter being defined as #' "Given any value in the interval and the background assumptions, #' the data should not seem very surprising" (_Gelman & Greenland 2019_). #' #' 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 #' Gelman A, Greenland S. Are confidence intervals better termed "uncertainty #' intervals"? BMJ 2019;l5381. 10.1136/bmj.l5381 #' #' @examplesIf require("rstanarm", quietly = TRUE) #' library(bayestestR) #' #' posterior <- rnorm(1000) #' ci(posterior, method = "ETI") #' ci(posterior, method = "HDI") #' #' df <- data.frame(replicate(4, rnorm(100))) #' ci(df, method = "ETI", ci = c(0.80, 0.89, 0.95)) #' ci(df, method = "HDI", ci = c(0.80, 0.89, 0.95)) #' #' model <- suppressWarnings( #' stan_glm(mpg ~ wt, data = mtcars, chains = 2, iter = 200, refresh = 0) #' ) #' ci(model, method = "ETI", ci = c(0.80, 0.89)) #' ci(model, method = "HDI", ci = c(0.80, 0.89)) #' #' @examplesIf require("BayesFactor", quietly = TRUE) #' bf <- ttestBF(x = rnorm(100, 1, 1)) #' ci(bf, method = "ETI") #' ci(bf, method = "HDI") #' #' @examplesIf require("emmeans", quietly = TRUE) && require("rstanarm", quietly = TRUE) #' model <- emtrends(model, ~1, "wt", data = mtcars) #' ci(model, method = "ETI") #' ci(model, method = "HDI") #' @export ci <- function(x, ...) { UseMethod("ci") } #' @keywords internal .ci_bayesian <- function(x, ci = 0.95, method = "ETI", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, BF = 1, ...) { if (tolower(method) %in% c("eti", "equal", "ci", "quantile")) { return( eti( x, ci = ci, effects = effects, component = component, parameters = parameters, verbose = verbose, ... ) ) } else if (tolower(method) %in% c("bci", "bca", "bcai")) { return( bci( x, ci = ci, effects = effects, component = component, parameters = parameters, verbose = verbose, ... ) ) } else if (tolower(method) == "hdi") { return( hdi( x, ci = ci, effects = effects, component = component, parameters = parameters, verbose = verbose, ... ) ) } else if (tolower(method) == "spi") { return( spi( x, ci = ci, effects = effects, component = component, parameters = parameters, verbose = verbose, ... ) ) } else if (tolower(method) == "si") { return( si( x, BF = BF, effects = effects, component = component, parameters = parameters, verbose = verbose, ... ) ) } else { insight::format_error(paste0( "`method` should be 'ETI' (for equal-tailed interval), ", "'HDI' (for highest density interval), 'BCI' (for bias corrected and ", "accelerated bootstrap intervals), 'SPI' (for shortest probability ", "interval) or 'SI' (for support interval)." )) } } #' @rdname ci #' @export ci.numeric <- function(x, ci = 0.95, method = "ETI", verbose = TRUE, BF = 1, ...) { .ci_bayesian(x, ci = ci, method = method, verbose = verbose, BF = BF, ...) } #' @rdname ci #' @export ci.data.frame <- ci.numeric #' @export ci.draws <- function(x, ci = 0.95, method = "ETI", verbose = TRUE, BF = 1, ...) { .ci_bayesian(.posterior_draws_to_df(x), ci = ci, method = method, verbose = verbose, BF = BF, ...) } #' @export ci.rvar <- ci.draws #' @export ci.emmGrid <- function(x, ci = NULL, ...) { if (!.is_baysian_emmeans(x)) { insight::check_if_installed("parameters") if (is.null(ci)) ci <- 0.95 return(parameters::ci(model = x, ci = ci, ...)) } if (is.null(ci)) ci <- 0.95 x <- insight::get_parameters(x) ci(x, ci = ci, ...) } #' @export ci.emm_list <- ci.emmGrid #' @rdname ci #' @export ci.sim.merMod <- function(x, ci = 0.95, method = "ETI", effects = c("fixed", "random", "all"), parameters = NULL, verbose = TRUE, ...) { .ci_bayesian( x, ci = ci, method = method, effects = effects, parameters = parameters, verbose = verbose, ... ) } #' @rdname ci #' @export ci.sim <- function(x, ci = 0.95, method = "ETI", parameters = NULL, verbose = TRUE, ...) { .ci_bayesian( x, ci = ci, method = method, parameters = parameters, verbose = verbose, ... ) } #' @rdname ci #' @export ci.stanreg <- function(x, ci = 0.95, method = "ETI", effects = c("fixed", "random", "all"), component = c( "location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary" ), parameters = NULL, verbose = TRUE, BF = 1, ...) { .ci_bayesian( x, ci = ci, method = method, effects = effects, component = component, parameters = parameters, verbose = verbose, BF = BF, ... ) } #' @rdname ci #' @export ci.brmsfit <- function(x, ci = 0.95, method = "ETI", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, BF = 1, ...) { .ci_bayesian( x, ci = ci, method = method, effects = effects, component = component, parameters = parameters, verbose = verbose, BF = BF, ... ) } #' @export ci.stanfit <- ci.stanreg #' @export ci.blavaan <- ci.stanreg #' @rdname ci #' @export ci.BFBayesFactor <- ci.numeric #' @rdname ci #' @export ci.MCMCglmm <- function(x, ci = 0.95, method = "ETI", verbose = TRUE, ...) { nF <- x$Fixed$nfl ci( as.data.frame(x$Sol[, 1:nF, drop = FALSE]), ci = ci, method = method, verbose = verbose, ... ) } #' @export ci.bamlss <- function(x, ci = 0.95, method = "ETI", component = c("all", "conditional", "location"), verbose = TRUE, ...) { component <- match.arg(component) ci( insight::get_parameters(x, component = component), ci = ci, method = method, verbose = verbose, ... ) } #' @export ci.bcplm <- function(x, ci = 0.95, method = "ETI", verbose = TRUE, ...) { ci(insight::get_parameters(x), ci = ci, method = method, verbose = verbose, ...) } #' @export ci.blrm <- ci.bcplm #' @export ci.mcmc <- ci.bcplm #' @export ci.mcmc.list <- ci.bcplm #' @export ci.BGGM <- ci.bcplm #' @export ci.get_predicted <- ci.data.frame bayestestR/R/datasets.R0000644000176200001440000000132214357655465014555 0ustar liggesusers#' Moral Disgust Judgment #' #' A sample (simulated) dataset, used in tests and some examples. #' #' @author Richard D. Morey #' #' @docType data #' #' @name disgust #' #' @keywords data #' #' @format A data frame with 500 rows and 5 variables: #' \describe{ #' \item{score}{Score on the questionnaire, which ranges from 0 to 50 with higher scores representing harsher moral judgment} #' \item{condition}{one of three conditions, differing by the odor present in the room: a pleasant scent associated with cleanliness (lemon), a disgusting scent (sulfur), and a control condition in which no unusual odor is present} #' } #' #' ```{r} #' data("disgust") #' head(disgust, n = 5) #' ```` #' NULL bayestestR/R/model_to_priors.R0000644000176200001440000000320114505754740016132 0ustar liggesusers#' Convert model's posteriors to priors (EXPERIMENTAL) #' #' Convert model's posteriors to (normal) priors. #' #' @param model A Bayesian model. #' @param scale_multiply The SD of the posterior will be multiplied by this amount before being set as a prior to avoid overly narrow priors. #' @param ... Other arguments for \code{insight::get_prior()} or \code{\link{describe_posterior}}. #' #' @examples #' \donttest{ #' # brms models #' # ----------------------------------------------- #' if (require("brms")) { #' formula <- brms::brmsformula(mpg ~ wt + cyl, center = FALSE) #' #' model <- brms::brm(formula, data = mtcars, refresh = 0) #' priors <- model_to_priors(model) #' priors <- brms::validate_prior(priors, formula, data = mtcars) #' priors #' #' model2 <- brms::brm(formula, data = mtcars, prior = priors, refresh = 0) #' } #' } #' @export model_to_priors <- function(model, scale_multiply = 3, ...) { UseMethod("model_to_priors") } #' @export model_to_priors.brmsfit <- function(model, scale_multiply = 3, ...) { params <- describe_posterior(model, centrality = "mean", dispersion = TRUE, ci = NULL, test = NULL, ...) priors_params <- attributes(insight::get_priors(model, ...))$priors priors <- brms::prior_summary(model) for (p in priors_params$Parameter) { if (p %in% params$Parameter) { subset <- params[params$Parameter == p, ] priors$prior[priors_params$Parameter == p] <- paste0( "normal(", insight::format_value(subset$Mean), ", ", insight::format_value(subset$SD * scale_multiply), ")" ) } } priors } bayestestR/R/sexit_thresholds.R0000644000176200001440000001216314505754740016334 0ustar liggesusers#' @title Find Effect Size Thresholds #' #' @description This function attempts at automatically finding suitable default #' values for a "significant" (i.e., non-negligible) and "large" effect. This is #' to be used with care, and the chosen threshold should always be explicitly #' reported and justified. See the detail section in [`sexit()`][sexit] for more #' information. #' #' @inheritParams rope #' #' @examples #' sexit_thresholds(rnorm(1000)) #' \donttest{ #' if (require("rstanarm")) { #' model <- suppressWarnings(stan_glm( #' mpg ~ wt + gear, #' data = mtcars, #' chains = 2, #' iter = 200, #' refresh = 0 #' )) #' sexit_thresholds(model) #' #' model <- suppressWarnings( #' stan_glm(vs ~ mpg, data = mtcars, family = "binomial", refresh = 0) #' ) #' sexit_thresholds(model) #' } #' #' if (require("brms")) { #' model <- brm(mpg ~ wt + cyl, data = mtcars) #' sexit_thresholds(model) #' } #' #' if (require("BayesFactor")) { #' bf <- ttestBF(x = rnorm(100, 1, 1)) #' sexit_thresholds(bf) #' } #' } #' @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 sexit_thresholds <- function(x, ...) { UseMethod("sexit_thresholds") } #' @export sexit_thresholds.brmsfit <- function(x, verbose = TRUE, ...) { response <- insight::get_response(x, source = "mf") information <- insight::model_info(x, verbose = FALSE) if (insight::is_multivariate(x)) { mapply(function(i, j) .sexit_thresholds(i, j), x, information, response, verbose) } else { .sexit_thresholds(x, information, response, verbose) } } #' @export sexit_thresholds.stanreg <- sexit_thresholds.brmsfit #' @export sexit_thresholds.BFBayesFactor <- function(x, verbose = TRUE, ...) { fac <- 1 if (inherits(x@numerator[[1]], "BFlinearModel")) { response <- .safe(insight::get_response(x, source = "mf")) if (!is.null(response)) { fac <- stats::sd(response, na.rm = TRUE) } } fac * .sexit_thresholds(x, verbose = verbose) } #' @export sexit_thresholds.lm <- sexit_thresholds.brmsfit #' @export sexit_thresholds.glm <- sexit_thresholds.brmsfit #' @export sexit_thresholds.merMod <- sexit_thresholds.brmsfit #' @export sexit_thresholds.glmmTMB <- sexit_thresholds.brmsfit #' @export sexit_thresholds.mixed <- sexit_thresholds.brmsfit #' @export sexit_thresholds.MixMod <- sexit_thresholds.brmsfit #' @export sexit_thresholds.wbm <- sexit_thresholds.brmsfit #' @export sexit_thresholds.feis <- sexit_thresholds.brmsfit #' @export sexit_thresholds.gee <- sexit_thresholds.brmsfit #' @export sexit_thresholds.geeglm <- sexit_thresholds.brmsfit #' @export sexit_thresholds.lme <- sexit_thresholds.brmsfit #' @export sexit_thresholds.felm <- sexit_thresholds.brmsfit #' @export sexit_thresholds.fixest <- sexit_thresholds.brmsfit #' @export sexit_thresholds.gls <- sexit_thresholds.brmsfit #' @export sexit_thresholds.hurdle <- sexit_thresholds.brmsfit #' @export sexit_thresholds.zeroinfl <- sexit_thresholds.brmsfit #' @export sexit_thresholds.bayesQR <- sexit_thresholds.brmsfit #' @export sexit_thresholds.default <- function(x, verbose = TRUE, ...) { .sexit_thresholds(x, verbose = verbose) } #' @export sexit_thresholds.mlm <- function(x, verbose = TRUE, ...) { response <- insight::get_response(x, type = "mf") information <- insight::model_info(x, verbose = FALSE) lapply(response, function(i) .sexit_thresholds(x, information, i, verbose = verbose)) } # helper ------------------ .sexit_thresholds <- function(x, information = NULL, response = NULL, verbose = TRUE) { if (is.null(information) && is.null(response)) { norm <- 1 } else { norm <- tryCatch( { # Linear Models if (information$is_linear) { stats::sd(response, na.rm = TRUE) # Logistic Regression Models } else if (information$is_binomial) { pi / sqrt(3) # Count Models } else if (information$is_count) { sig <- stats::sigma(x) if (!is.null(sig) && length(sig) > 0 && !is.na(sig)) { sig } else { 1 } # T-tests } else if (information$is_ttest) { if (inherits(x, "BFBayesFactor")) { stats::sd(x@data[, 1]) } else { if (verbose) { insight::format_warning("Could not estimate good thresholds, using default values.") } 1 } # Correlations } else if (information$is_correlation) { # https://github.com/easystats/bayestestR/issues/121 1 # Default } else { 1 } }, error = function(e) { if (verbose) { insight::format_warning("Could not estimate good thresholds, using default values.") } 1 } ) } c(0.05, 0.3) * norm } bayestestR/R/p_rope.R0000644000176200001440000001222514560763455014230 0ustar liggesusers#' Probability of being in the ROPE #' #' Compute the proportion of the whole posterior distribution that doesn't lie within a region of practical equivalence (ROPE). It is equivalent to running `rope(..., ci = 1)`. #' #' @inheritParams rope #' #' @examples #' library(bayestestR) #' #' p_rope(x = rnorm(1000, 0, 0.01), range = c(-0.1, 0.1)) #' p_rope(x = mtcars, range = c(-0.1, 0.1)) #' @export p_rope <- function(x, ...) { UseMethod("p_rope") } #' @method as.double p_rope #' @export as.double.p_rope <- function(x, ...) { x } #' @export p_rope.default <- function(x, ...) { NULL } #' @rdname p_rope #' @export p_rope.numeric <- function(x, range = "default", verbose = TRUE, ...) { out <- .p_rope(rope(x, range = range, ci = 1, verbose = verbose, ...)) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.data.frame <- p_rope.numeric #' @export p_rope.draws <- function(x, range = "default", verbose = TRUE, ...) { p_rope(.posterior_draws_to_df(x), range = range, verbose = verbose, ...) } #' @export p_rope.rvar <- p_rope.draws #' @export p_rope.emmGrid <- function(x, range = "default", verbose = TRUE, ...) { xdf <- insight::get_parameters(x) out <- p_rope(xdf, range = range, verbose = verbose) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.emm_list <- p_rope.emmGrid #' @export p_rope.BFBayesFactor <- p_rope.numeric #' @export p_rope.MCMCglmm <- p_rope.numeric #' @rdname p_rope #' @export p_rope.stanreg <- function(x, range = "default", effects = c("fixed", "random", "all"), component = c( "location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary" ), parameters = NULL, verbose = verbose, ...) { out <- .p_rope(rope( x, range = range, ci = 1, effects = effects, component = component, parameters = parameters, verbose = verbose, ... )) out <- .add_clean_parameters_attribute(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.stanfit <- p_rope.stanreg #' @export p_rope.blavaan <- p_rope.stanreg #' @rdname p_rope #' @export p_rope.brmsfit <- function(x, range = "default", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = verbose, ...) { out <- .p_rope(rope( x, range = range, ci = 1, effects = effects, component = component, parameters = parameters, verbose = verbose, ... )) out <- .add_clean_parameters_attribute(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.sim.merMod <- p_rope.stanreg #' @export p_rope.sim <- function(x, range = "default", parameters = NULL, verbose = TRUE, ...) { out <- .p_rope(rope(x, range = range, ci = 1, parameters = parameters, verbose = verbose, ...)) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.bamlss <- function(x, range = "default", component = c("all", "conditional", "location"), parameters = NULL, verbose = TRUE, ...) { component <- match.arg(component) out <- .p_rope(rope( x, range = range, ci = 1, effects = "all", component = component, parameters = parameters, verbose = verbose, ... )) out <- .add_clean_parameters_attribute(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.mcmc <- function(x, range = "default", parameters = NULL, verbose = TRUE, ...) { out <- .p_rope(rope(x, range = range, ci = 1, parameters = parameters, verbose = verbose, ...)) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.bcplm <- p_rope.mcmc #' @export p_rope.BGGM <- p_rope.mcmc #' @export p_rope.blrm <- p_rope.mcmc #' @export p_rope.mcmc.list <- p_rope.mcmc # Internal ---------------------------------------------------------------- #' @keywords internal .p_rope <- function(rope_rez) { cols <- c("Parameter", "ROPE_low", "ROPE_high", "ROPE_Percentage", "Effects", "Component") out <- as.data.frame(rope_rez[cols[cols %in% names(rope_rez)]]) names(out)[names(out) == "ROPE_Percentage"] <- "p_ROPE" class(out) <- c("p_rope", "see_p_rope", "data.frame") out } bayestestR/R/distribution.R0000644000176200001440000001553114407021360015444 0ustar liggesusers#' Empirical Distributions #' #' Generate a sequence of n-quantiles, i.e., a sample of size `n` with a #' near-perfect distribution. #' #' @param type Can be any of the names from base R's #' [Distributions][stats::Distributions], like `"cauchy"`, `"pois"` or #' `"beta"`. #' @param random Generate near-perfect or random (simple wrappers for the base R #' `r*` functions) distributions. #' @param xi For tweedie distributions, the value of `xi` such that the variance #' is `var(Y) = phi * mu^xi`. #' @param power Alias for `xi`. #' @param ... Arguments passed to or from other methods. #' @inheritParams tweedie::rtweedie #' #' @details #' When `random = FALSE`, these function return `q*(ppoints(n), ...)`. #' #' @examples #' library(bayestestR) #' x <- distribution(n = 10) #' plot(density(x)) #' #' x <- distribution(type = "gamma", n = 100, shape = 2) #' plot(density(x)) #' @export distribution <- function(type = "normal", ...) { basr_r_distributions <- c( "beta", "binom", "binomial", "cauchy", "chisq", "chisquared", "exp", "f", "gamma", "geom", "hyper", "lnorm", "multinom", "nbinom", "normal", "gaussian", "pois", "poisson", "student", "t", "student_t", "unif", "uniform", "weibull" ) switch(match.arg(arg = type, choices = basr_r_distributions), "beta" = distribution_beta(...), "binom" = , "binomial" = distribution_binomial(...), "cauchy" = distribution_cauchy(...), "chisq" = , "chisquared" = distribution_chisquared(...), "gamma" = distribution_gamma(...), "gaussian" = , "normal" = distribution_normal(...), "nbinom" = distribution_nbinom(...), "poisson" = distribution_poisson(...), "t" = , "student" = , "student_t" = distribution_student(...), "uniform" = distribution_uniform(...), distribution_custom(type = type, ...) ) } #' @rdname distribution #' @inheritParams distribution #' @export distribution_custom <- function(n, type = "norm", ..., random = FALSE) { if (random) { f <- match.fun(paste0("r", type)) f(n, ...) } else { f <- match.fun(paste0("q", type)) f(stats::ppoints(n), ...) } } #' @rdname distribution #' @inheritParams stats::rbeta #' @export distribution_beta <- function(n, shape1, shape2, ncp = 0, random = FALSE, ...) { if (random) { stats::rbeta(n, shape1, shape2, ncp = ncp) } else { stats::qbeta(stats::ppoints(n), shape1, shape2, ncp = ncp, ...) } } #' @rdname distribution #' @inheritParams stats::rbinom #' @export distribution_binomial <- function(n, size = 1, prob = 0.5, random = FALSE, ...) { if (random) { stats::rbinom(n, size, prob) } else { stats::qbinom(stats::ppoints(n), size, prob, ...) } } #' @rdname distribution #' @export distribution_binom <- distribution_binomial #' @rdname distribution #' @inheritParams stats::rcauchy #' @export distribution_cauchy <- function(n, location = 0, scale = 1, random = FALSE, ...) { if (random) { stats::rcauchy(n, location, scale) } else { stats::qcauchy(stats::ppoints(n), location, scale, ...) } } #' @rdname distribution #' @inheritParams stats::rchisq #' @export distribution_chisquared <- function(n, df, ncp = 0, random = FALSE, ...) { if (random) { stats::rchisq(n, df, ncp) } else { stats::qchisq(stats::ppoints(n), df, ncp, ...) } } #' @rdname distribution #' @export distribution_chisq <- distribution_chisquared #' @rdname distribution #' @inheritParams stats::rgamma #' @param shape Shape parameter. #' @export distribution_gamma <- function(n, shape, scale = 1, random = FALSE, ...) { if (random) { stats::rgamma(n = n, shape = shape, scale = scale) } else { stats::qgamma(p = stats::ppoints(n), shape = shape, scale = scale) } } #' @rdname distribution #' @inheritParams stats::rnorm #' @export distribution_mixture_normal <- function(n, mean = c(-3, 3), sd = 1, random = FALSE, ...) { n <- round(n / length(mean)) sd <- sd if (length(sd) != length(mean)) { sd <- rep(sd, length.out = length(mean)) } x <- NULL for (i in seq_along(mean)) { x <- c(x, distribution_normal(n = n, mean = mean[i], sd = sd[i], random = random)) } x } #' @rdname distribution #' @inheritParams stats::rnorm #' @export distribution_normal <- function(n, mean = 0, sd = 1, random = FALSE, ...) { if (random) { stats::rnorm(n, mean, sd) } else { stats::qnorm(stats::ppoints(n), mean, sd, ...) } } #' @rdname distribution #' @export distribution_gaussian <- distribution_normal #' @rdname distribution #' @inheritParams stats::rnbinom #' @param phi Corresponding to `glmmTMB`'s implementation of nbinom #' distribution, where `size=mu/phi`. #' @export distribution_nbinom <- function(n, size, prob, mu, phi, random = FALSE, ...) { if (missing(size)) { size <- mu / phi } if (random) { stats::rnbinom(n, size, prob, mu) } else { stats::qnbinom(stats::ppoints(n), size, prob, mu, ...) } } #' @rdname distribution #' @inheritParams stats::rpois #' @export distribution_poisson <- function(n, lambda = 1, random = FALSE, ...) { if (random) { stats::rpois(n, lambda) } else { stats::qpois(stats::ppoints(n), lambda, ...) } } #' @rdname distribution #' @inheritParams stats::rt #' @export distribution_student <- function(n, df, ncp, random = FALSE, ...) { if (random) { stats::rt(n, df, ncp) } else { stats::qt(stats::ppoints(n), df, ncp, ...) } } #' @rdname distribution #' @export distribution_t <- distribution_student #' @rdname distribution #' @export distribution_student_t <- distribution_student #' @rdname distribution #' @inheritParams tweedie::rtweedie #' @export distribution_tweedie <- function(n, xi = NULL, mu, phi, power = NULL, random = FALSE, ...) { insight::check_if_installed("tweedie") if (random) { tweedie::rtweedie( n = n, xi = xi, mu = mu, phi = phi, power = power ) } else { tweedie::qtweedie( p = stats::ppoints(n), xi = xi, mu = mu, phi = phi, power = power ) } } #' @rdname distribution #' @inheritParams stats::runif #' @export distribution_uniform <- function(n, min = 0, max = 1, random = FALSE, ...) { if (random) { stats::runif(n, min, max) } else { stats::qunif(stats::ppoints(n), min, max, ...) } } #' @rdname distribution #' @inheritParams stats::rnorm #' @export rnorm_perfect <- function(n, mean = 0, sd = 1) { .Deprecated("distribution_normal") stats::qnorm(stats::ppoints(n), mean, sd) } bayestestR/R/eti.R0000644000176200001440000001722514560763455013532 0ustar liggesusers#' Equal-Tailed Interval (ETI) #' #' Compute the **Equal-Tailed Interval (ETI)** of posterior distributions using #' the quantiles method. The probability of being below this interval is equal #' to the probability of being above it. The ETI can be used in the context of #' uncertainty characterisation of posterior distributions as #' **Credible Interval (CI)**. #' #' @inheritParams hdi #' @inherit ci return #' @inherit hdi details #' @inherit hdi seealso #' @family ci #' #' @examplesIf require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor") #' library(bayestestR) #' #' posterior <- rnorm(1000) #' eti(posterior) #' eti(posterior, ci = c(0.80, 0.89, 0.95)) #' #' df <- data.frame(replicate(4, rnorm(100))) #' eti(df) #' eti(df, ci = c(0.80, 0.89, 0.95)) #' \donttest{ #' model <- suppressWarnings( #' rstanarm::stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) #' ) #' eti(model) #' eti(model, ci = c(0.80, 0.89, 0.95)) #' #' eti(emmeans::emtrends(model, ~1, "wt", data = mtcars)) #' #' model <- brms::brm(mpg ~ wt + cyl, data = mtcars) #' eti(model) #' eti(model, ci = c(0.80, 0.89, 0.95)) #' #' bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) #' eti(bf) #' eti(bf, ci = c(0.80, 0.89, 0.95)) #' } #' #' @export eti <- function(x, ...) { UseMethod("eti") } #' @export eti.default <- function(x, ...) { insight::format_error(paste0("'eti()' is not yet implemented for objects of class '", class(x)[1], "'.")) } #' @rdname eti #' @export eti.numeric <- function(x, ci = 0.95, verbose = TRUE, ...) { out <- do.call(rbind, lapply(ci, function(i) { .eti(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 } #' @export eti.data.frame <- function(x, ci = 0.95, verbose = TRUE, ...) { dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "eti") attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.draws <- function(x, ci = 0.95, verbose = TRUE, ...) { dat <- .compute_interval_dataframe(x = .posterior_draws_to_df(x), ci = ci, verbose = verbose, fun = "eti") attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.rvar <- eti.draws #' @export eti.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 = "eti") attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.mcmc <- function(x, ci = 0.95, verbose = TRUE, ...) { d <- as.data.frame(x) dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = "eti") attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.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 = "eti") attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.bcplm <- function(x, ci = 0.95, verbose = TRUE, ...) { d <- insight::get_parameters(x) dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = "eti") attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.bayesQR <- eti.bcplm #' @export eti.blrm <- eti.bcplm #' @export eti.mcmc.list <- eti.bcplm #' @export eti.BGGM <- eti.bcplm #' @export eti.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 = "eti" ) out <- dat$result attr(out, "data") <- dat$data out } #' @export eti.sim <- function(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) { dat <- .compute_interval_sim(x = x, ci = ci, parameters = parameters, verbose = verbose, fun = "eti") out <- dat$result attr(out, "data") <- dat$data out } #' @export eti.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) { xdf <- insight::get_parameters(x) dat <- eti(xdf, ci = ci, verbose = verbose, ...) attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.emm_list <- eti.emmGrid #' @rdname eti #' @export eti.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( eti( 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 eti.stanfit <- eti.stanreg #' @export eti.blavaan <- eti.stanreg #' @rdname eti #' @export eti.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( eti( 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 } #' @export eti.BFBayesFactor <- function(x, ci = 0.95, verbose = TRUE, ...) { out <- eti(insight::get_parameters(x), ci = ci, verbose = verbose, ...) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @rdname eti #' @export eti.get_predicted <- function(x, ci = 0.95, use_iterations = FALSE, verbose = TRUE, ...) { if (isTRUE(use_iterations)) { if ("iterations" %in% names(attributes(x))) { out <- eti(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 <- eti(as.numeric(x), ci = ci, verbose = verbose, ...) } out } # Helper ------------------------------------------------------------------ .eti <- function(x, ci, verbose = TRUE) { check_ci <- .check_ci_argument(x, ci, verbose) if (!is.null(check_ci)) { return(check_ci) } results <- as.vector(stats::quantile( x, probs = c((1 - ci) / 2, (1 + ci) / 2), names = FALSE, na.rm = TRUE )) data.frame( "CI" = ci, "CI_low" = results[1], "CI_high" = results[2] ) } bayestestR/R/p_to_bf.R0000644000176200001440000001004314560763455014350 0ustar liggesusers#' Convert p-values to (pseudo) Bayes Factors #' #' Convert p-values to (pseudo) Bayes Factors. This transformation has been #' suggested by Wagenmakers (2022), but is based on a vast amount of assumptions. #' It might therefore be not reliable. Use at your own risks. For more accurate #' approximate Bayes factors, use [bic_to_bf()] instead. #' #' @param x A (frequentist) model object, or a (numeric) vector of p-values. #' @param n_obs Number of observations. Either length 1, or same length as `p`. #' @param log Wether to return log Bayes Factors. **Note:** The `print()` method #' always shows `BF` - the `"log_BF"` column is only accessible from the returned #' data frame. #' @param ... Other arguments to be passed (not used for now). #' #' @references #' - Wagenmakers, E.J. (2022). Approximate objective Bayes factors from p-values #' and sample size: The 3p(sqrt(n)) rule. Preprint available on ArXiv: #' https://psyarxiv.com/egydq #' #' @examplesIf require("parameters") #' data(iris) #' model <- lm(Petal.Length ~ Sepal.Length + Species, data = iris) #' p_to_bf(model) #' #' # Examples that demonstrate comparison between #' # BIC-approximated and pseudo BF #' # -------------------------------------------- #' m0 <- lm(mpg ~ 1, mtcars) #' m1 <- lm(mpg ~ am, mtcars) #' m2 <- lm(mpg ~ factor(cyl), mtcars) #' #' # In this first example, BIC-approximated BF and #' # pseudo-BF based on p-values are close... #' #' # BIC-approximated BF, m1 against null model #' bic_to_bf(BIC(m1), denominator = BIC(m0)) #' #' # pseudo-BF based on p-values - dropping intercept #' p_to_bf(m1)[-1, ] #' #' # The second example shows that results from pseudo-BF are less accurate #' # and should be handled wit caution! #' bic_to_bf(BIC(m2), denominator = BIC(m0)) #' p_to_bf(anova(m2), n_obs = nrow(mtcars)) #' #' @return A data frame with the p-values and pseudo-Bayes factors (against the null). #' #' @seealso [bic_to_bf()] for more accurate approximate Bayes factors. #' #' @export p_to_bf <- function(x, ...) { UseMethod("p_to_bf") } #' @export #' @rdname p_to_bf p_to_bf.numeric <- function(x, log = FALSE, n_obs = NULL, ...) { p <- x # Validate n_obs if (is.null(n_obs)) { insight::format_error("Argument `n_obs` must be specified.") } else if (length(n_obs) == 1L) { n_obs <- rep(n_obs, times = length(p)) } else if (length(n_obs) != length(p)) { insight::format_error("`n_obs` must be of length 1 or same length as `p`.") } # Convert log_BF <- vector("numeric", length = length(p)) for (i in seq_along(p)) { if (p[i] <= 0.1) { log_BF[i] <- log(3 * p[i] * sqrt(n_obs[i])) } else if (p[i] <= 0.5) { # log_BF[i] <- log((4 / 3) * p[i] ^ (2 / 3) * sqrt(n_obs[i])) log_BF[i] <- log(p[i]) * (2 / 3) + log(sqrt(n_obs[i]) * (4 / 3)) } else { # log_BF[i] <- p[i] ^ .25 * sqrt(n_obs[i]) log_BF[i] <- log(p[i]) / 4 + log(sqrt(n_obs[i])) } } # Clean up out <- data.frame( p = p, # IMPORTANT! This is BF10! log_BF = -log_BF, stringsAsFactors = FALSE ) if (!log) { out$BF <- exp(out$log_BF) out$log_BF <- NULL } class(out) <- c("p_to_pseudo_bf", "data.frame") out } #' @export #' @rdname p_to_bf p_to_bf.default <- function(x, log = FALSE, ...) { if (insight::is_model(x)) { insight::check_if_installed("parameters") params <- parameters::p_value(x) p <- params$p n_obs <- insight::n_obs(x) # validation check if (is.null(n_obs)) { # user may also pass n_obs via dots... n_obs <- list(...)$n_obs } } else { insight::format_error("Argument `x` must be a model object, or a numeric vector of p-values.") } out <- p_to_bf(p, n_obs = n_obs, log = log) out <- cbind(params, out[, -1, drop = FALSE]) class(out) <- c("p_to_pseudo_bf", "data.frame") out } # methods --------------- #' @export print.p_to_pseudo_bf <- function(x, ...) { cat(insight::export_table(insight::format_table(x), caption = "Pseudo-BF (against NULL)")) } bayestestR/R/print.equivalence_test.R0000644000176200001440000000576614560763455017453 0ustar liggesusers#' @export print.equivalence_test <- function(x, digits = 2, ...) { orig_x <- x insight::print_color("# Test for Practical Equivalence\n\n", "blue") cat(sprintf(" ROPE: [%.*f %.*f]\n\n", digits, x$ROPE_low[1], digits, x$ROPE_high[1])) # fix "sd" pattern model <- .retrieve_model(x) if (!is.null(model)) { cp <- insight::clean_parameters(model) if (!is.null(cp$Group) && any(startsWith(cp$Group, "SD/Cor"))) { cp <- cp[startsWith(cp$Group, "SD/Cor"), ] matches <- match(cp$Parameter, x$Parameter) if (length(matches)) { new_pattern <- paste0( "SD/Cor: ", cp$Cleaned_Parameter[unique(stats::na.omit(match(x$Parameter, cp$Parameter)))] ) if (length(new_pattern) == length(matches)) { x$Parameter[matches] <- new_pattern } } } } # find the longest HDI-value, so we can align the brackets in the ouput x$HDI_low <- sprintf("%.*f", digits, x$HDI_low) x$HDI_high <- sprintf("%.*f", digits, x$HDI_high) maxlen_low <- max(nchar(x$HDI_low)) maxlen_high <- max(nchar(x$HDI_high)) x$ROPE_Percentage <- sprintf("%.*f %%", digits, x$ROPE_Percentage * 100) x$HDI <- sprintf("[%*s %*s]", maxlen_low, x$HDI_low, maxlen_high, x$HDI_high) ci <- unique(x$CI) keep.columns <- c("CI", "Parameter", "ROPE_Equivalence", "ROPE_Percentage", "HDI", "Effects", "Component") x <- x[, intersect(keep.columns, colnames(x))] colnames(x)[which(colnames(x) == "ROPE_Equivalence")] <- "H0" colnames(x)[which(colnames(x) == "ROPE_Percentage")] <- "inside ROPE" .print_equivalence_component(x, ci, digits) invisible(orig_x) } .print_equivalence_component <- function(x, ci, digits) { for (i in ci) { xsub <- x[x$CI == i, -which(colnames(x) == "CI"), drop = FALSE] colnames(xsub)[colnames(xsub) == "HDI"] <- sprintf("%i%% HDI", 100 * i) .print_data_frame(xsub, digits = digits) cat("\n") } } .retrieve_model <- function(x) { # retrieve model obj_name <- attr(x, "object_name", exact = TRUE) model <- NULL if (!is.null(obj_name)) { # first try, parent frame model <- tryCatch(get(obj_name, envir = parent.frame()), error = function(e) NULL) if (is.null(model)) { # second try, global env model <- tryCatch(get(obj_name, envir = globalenv()), error = function(e) NULL) } if (is.null(model)) { # last try model <- .dynGet(obj_name, ifnotfound = NULL) } } model } .dynGet <- function(x, ifnotfound = stop(gettextf("%s not found", sQuote(x)), domain = NA), minframe = 1L, inherits = FALSE) { x <- insight::safe_deparse(x) n <- sys.nframe() myObj <- structure(list(.b = as.raw(7)), foo = 47L) while (n > minframe) { n <- n - 1L env <- sys.frame(n) r <- get0(x, envir = env, inherits = inherits, ifnotfound = myObj) if (!identical(r, myObj)) { return(r) } } ifnotfound } bayestestR/R/area_under_curve.R0000644000176200001440000000401614650172354016244 0ustar liggesusers#' Area under the Curve (AUC) #' #' Based on the DescTools `AUC` function. It can calculate the area under the #' curve with a naive algorithm or a more elaborated spline approach. The curve #' must be given by vectors of xy-coordinates. This function can handle unsorted #' x values (by sorting x) and ties for the x values (by ignoring duplicates). #' #' @param x Vector of x values. #' @param y Vector of y values. #' @param method Method to compute the Area Under the Curve (AUC). Can be #' `"trapezoid"` (default), `"step"` or `"spline"`. If "trapezoid", the curve #' is formed by connecting all points by a direct line (composite trapezoid #' rule). If "step" is chosen then a stepwise connection of two points is #' used. For calculating the area under a spline interpolation the splinefun #' function is used in combination with integrate. #' @param ... Arguments passed to or from other methods. #' #' #' @examples #' library(bayestestR) #' posterior <- distribution_normal(1000) #' #' dens <- estimate_density(posterior) #' dens <- dens[dens$x > 0, ] #' x <- dens$x #' y <- dens$y #' #' area_under_curve(x, y, method = "trapezoid") #' area_under_curve(x, y, method = "step") #' area_under_curve(x, y, method = "spline") #' @seealso DescTools #' @export area_under_curve <- function(x, y, method = c("trapezoid", "step", "spline"), ...) { # From DescTools [GPL-3]: https://github.com/cran/DescTools/blob/master/R/StatsAndCIs.r if (length(x) != length(y)) { insight::format_error("Length of x must be equal to length of y.") } idx <- order(x) x <- x[idx] y <- y[idx] switch(match.arg(arg = method, choices = c("trapezoid", "step", "spline")), trapezoid = sum((rowMeans(cbind(y[-length(y)], y[-1]))) * (x[-1] - x[-length(x)])), step = sum(y[-length(y)] * (x[-1] - x[-length(x)])), spline = stats::integrate(stats::splinefun(x, y, method = "natural"), lower = min(x), upper = max(x))$value ) } #' @rdname area_under_curve #' @export auc <- area_under_curve bayestestR/R/utils_posterior.R0000644000176200001440000000160414407021360016167 0ustar liggesusers# helper ------------------------------ .posterior_draws_to_df <- function(x) { UseMethod(".posterior_draws_to_df") } .posterior_draws_to_df.default <- function(x) { insight::format_error(paste0("Objects of class `%s` are not yet supported.", class(x)[1])) } .posterior_draws_to_df.data.frame <- function(x) { x } .posterior_draws_to_df.draws_df <- function(x) { insight::check_if_installed("posterior") datawizard::data_remove(as.data.frame(posterior::as_draws_df(x)), c(".chain", ".iteration", ".draw")) } .posterior_draws_to_df.draws_matrix <- .posterior_draws_to_df.draws_df .posterior_draws_to_df.draws_array <- .posterior_draws_to_df.draws_df .posterior_draws_to_df.draws_list <- .posterior_draws_to_df.draws_df .posterior_draws_to_df.draws_rvars <- .posterior_draws_to_df.draws_df .posterior_draws_to_df.rvar <- .posterior_draws_to_df.draws_df bayestestR/R/estimate_density.R0000644000176200001440000005340614650172354016314 0ustar liggesusers#' Density Estimation #' #' This function is a wrapper over different methods of density estimation. By #' default, it uses the base R `density` with by default uses a different smoothing #' bandwidth (`"SJ"`) from the legacy default implemented the base R `density` #' function (`"nrd0"`). However, Deng and Wickham suggest that `method = "KernSmooth"` #' is the fastest and the most accurate. #' #' @inheritParams hdi #' @inheritParams stats::density #' @param bw See the eponymous argument in `density`. Here, the default has been #' changed for `"SJ"`, which is recommended. #' @param ci The confidence interval threshold. Only used when `method = "kernel"`. #' This feature is experimental, use with caution. #' @param method Density estimation method. Can be `"kernel"` (default), `"logspline"` #' or `"KernSmooth"`. #' @param precision Number of points of density data. See the `n` parameter in `density`. #' @param extend Extend the range of the x axis by a factor of `extend_scale`. #' @param extend_scale Ratio of range by which to extend the x axis. A value of `0.1` #' means that the x axis will be extended by `1/10` of the range of the data. #' @param select Character vector of column names. If `NULL` (the default), all #' numeric variables will be selected. Other arguments from #' [`datawizard::extract_column_names()`] (such as `exclude`) can also be used. #' @param by Optional character vector. If not `NULL` and input is a data frame, #' density estimation is performed for each group (subsets) indicated by `by`. #' See examples. #' @param at Deprecated in favour of `by`. #' #' @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("logspline") && require("KernSmooth") && require("mclust") && require("emmeans") && require("rstanarm") && require("brms") #' library(bayestestR) #' #' set.seed(1) #' x <- rnorm(250, mean = 1) #' #' # Basic usage #' density_kernel <- estimate_density(x) # default method is "kernel" #' #' hist(x, prob = TRUE) #' lines(density_kernel$x, density_kernel$y, col = "black", lwd = 2) #' lines(density_kernel$x, density_kernel$CI_low, col = "gray", lty = 2) #' lines(density_kernel$x, density_kernel$CI_high, col = "gray", lty = 2) #' legend("topright", #' legend = c("Estimate", "95% CI"), #' col = c("black", "gray"), lwd = 2, lty = c(1, 2) #' ) #' #' # Other Methods #' density_logspline <- estimate_density(x, method = "logspline") #' density_KernSmooth <- estimate_density(x, method = "KernSmooth") #' density_mixture <- estimate_density(x, method = "mixture") #' #' hist(x, prob = TRUE) #' lines(density_kernel$x, density_kernel$y, col = "black", lwd = 2) #' lines(density_logspline$x, density_logspline$y, col = "red", lwd = 2) #' lines(density_KernSmooth$x, density_KernSmooth$y, col = "blue", lwd = 2) #' lines(density_mixture$x, density_mixture$y, col = "green", lwd = 2) #' #' # Extension #' density_extended <- estimate_density(x, extend = TRUE) #' density_default <- estimate_density(x, extend = FALSE) #' #' hist(x, prob = TRUE) #' lines(density_extended$x, density_extended$y, col = "red", lwd = 3) #' lines(density_default$x, density_default$y, col = "black", lwd = 3) #' #' # Multiple columns #' head(estimate_density(iris)) #' head(estimate_density(iris, select = "Sepal.Width")) #' #' # Grouped data #' head(estimate_density(iris, by = "Species")) #' head(estimate_density(iris$Petal.Width, by = iris$Species)) #' \donttest{ #' # rstanarm models #' # ----------------------------------------------- #' library(rstanarm) #' model <- suppressWarnings( #' stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) #' ) #' head(estimate_density(model)) #' #' library(emmeans) #' head(estimate_density(emtrends(model, ~1, "wt", data = mtcars))) #' #' # brms models #' # ----------------------------------------------- #' library(brms) #' model <- brms::brm(mpg ~ wt + cyl, data = mtcars) #' estimate_density(model) #' } #' #' @references Deng, H., & Wickham, H. (2011). Density estimation in R. Electronic publication. #' #' @export estimate_density <- function(x, ...) { UseMethod("estimate_density") } #' @export estimate_density.default <- function(x, ...) { insight::format_error( paste0("`estimate_density()` is not yet implemented for objects of class `", class(x)[1], "`.") ) } #' @keywords internal .estimate_density <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ci = NULL, ...) { method <- match.arg( tolower(method), c("kernel", "logspline", "kernsmooth", "smooth", "mixture", "mclust") ) # Remove NA x <- x[!is.na(x)] if (length(x) < 2) { return(stats::setNames( data.frame(matrix(ncol = 3, nrow = 0)), c("Parameter", "x", "y") )) } # Range x_range <- range(x) if (extend) { extension_scale <- diff(x_range) * extend_scale x_range[1] <- x_range[1] - extension_scale x_range[2] <- x_range[2] + extension_scale } # Replace inf values if needed x_range[is.infinite(x_range)] <- 5.565423e+156 # Kernel if (method == "kernel") { kde <- .estimate_density_kernel(x, x_range, precision, bw, ci, ...) # Logspline } else if (method == "logspline") { kde <- .estimate_density_logspline(x, x_range, precision, ...) # KernSmooth } else if (method %in% c("kernsmooth", "smooth")) { kde <- .estimate_density_KernSmooth(x, x_range, precision, ...) # Mixture } else if (method %in% c("mixture", "mclust")) { kde <- .estimate_density_mixture(x, x_range, precision, ...) } else { insight::format_error("method should be one of 'kernel', 'logspline', 'KernSmooth' or 'mixture'.") } kde } # Methods ----------------------------------------------------------------- #' @export estimate_density.numeric <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ci = NULL, by = NULL, at = NULL, ...) { # TODO remove deprecation warning # Sanity if (!is.null(at)) { insight::format_warning( "The `at` argument is deprecated and might be removed in a future update. Please replace by `by`." ) by <- at } if (!is.null(by)) { if (length(by) == 1) { insight::format_error(paste0( "`by` must be either the name of a group column if a data frame is entered as input,", " or in this case (where a single vector was passed) a vector of same length." )) } out <- estimate_density( data.frame(V1 = x, Group = by, stringsAsFactors = FALSE), method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ci = ci, by = "Group", ... ) out$Parameter <- NULL return(out) } out <- .estimate_density( x, method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ci = ci, ... ) class(out) <- .set_density_class(out) out } #' @rdname estimate_density #' @export estimate_density.data.frame <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ci = NULL, select = NULL, by = NULL, at = NULL, ...) { # Sanity if (!is.null(at)) { insight::format_warning(paste0( "The `at` argument is deprecated and might be removed in a future update.", " Please replace by `by`." )) by <- at } if (is.null(by)) { # No grouping ------------------- out <- .estimate_density_df( x = x, method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ci = ci, select = select, ... ) } else { # Deal with by- grouping -------- groups <- insight::get_datagrid(x[, by, drop = FALSE], by = by) # Get combinations out <- data.frame() for (row in seq_len(nrow(groups))) { subdata <- datawizard::data_match(x, groups[row, , drop = FALSE]) subdata[names(groups)] <- NULL subdata <- .estimate_density_df( subdata, method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ci = ci, select = select, ... ) out <- rbind(out, merge(subdata, groups[row, , drop = FALSE])) } } class(out) <- .set_density_df_class(out) out } #' @export estimate_density.draws <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ci = NULL, select = NULL, by = NULL, at = NULL, ...) { if (!is.null(at)) { insight::format_warning(paste0( "The `at` argument is deprecated and might be removed in a future update.", " Please replace by `by`." )) by <- at } estimate_density( .posterior_draws_to_df(x), method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, select = select, by = by ) } #' @export estimate_density.rvar <- estimate_density.draws #' @export estimate_density.grouped_df <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ci = NULL, select = NULL, ...) { groups <- .group_vars(x) ungrouped_x <- as.data.frame(x) xlist <- split(ungrouped_x, ungrouped_x[groups]) out <- lapply(names(xlist), function(group) { dens <- estimate_density( xlist[[group]], method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ci = ci, select = select, ... ) dens$Group <- group dens }) do.call(rbind, out) } # to avoid class conflicts - e.g., numeric variables imported with the # haven package are of class "haven_labelled" and "double", which causes # problems with the generic or numeric method. #' @export estimate_density.double <- estimate_density.numeric #' @export estimate_density.emmGrid <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ...) { x <- insight::get_parameters(x) out <- estimate_density(x, method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ... ) class(out) <- .set_density_class(out) out } #' @export estimate_density.emm_list <- estimate_density.emmGrid #' @export estimate_density.stanreg <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", 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) out <- estimate_density( insight::get_parameters(x, effects = effects, component = component, parameters = parameters), method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ... ) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) class(out) <- .set_density_class(out) out } #' @export estimate_density.stanfit <- estimate_density.stanreg #' @export estimate_density.blavaan <- estimate_density.stanreg #' @export estimate_density.brmsfit <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, ...) { effects <- match.arg(effects) component <- match.arg(component) out <- estimate_density( insight::get_parameters(x, effects = effects, component = component, parameters = parameters), method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ... ) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) class(out) <- .set_density_class(out) out } #' @export estimate_density.MCMCglmm <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", parameters = NULL, ...) { nF <- x$Fixed$nfl out <- estimate_density( as.data.frame(x$Sol[, 1:nF, drop = FALSE]), method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ... ) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) class(out) <- .set_density_class(out) out } #' @export estimate_density.mcmc <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", parameters = NULL, ...) { out <- estimate_density( insight::get_parameters(x, parameters = parameters), method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ... ) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) class(out) <- .set_density_class(out) out } #' @export estimate_density.bayesQR <- estimate_density.mcmc #' @export estimate_density.blrm <- estimate_density.mcmc #' @export estimate_density.bcplm <- estimate_density.mcmc #' @export estimate_density.BGGM <- estimate_density.mcmc #' @export estimate_density.mcmc.list <- estimate_density.mcmc #' @export estimate_density.bamlss <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", component = c("all", "conditional", "location"), parameters = NULL, ...) { component <- match.arg(component) out <- estimate_density( insight::get_parameters(x, component = component, parameters = parameters), method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ... ) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) class(out) <- .set_density_class(out) out } #' Coerce to a Data Frame #' #' @inheritParams base::as.data.frame #' @method as.data.frame density #' @export as.data.frame.density <- function(x, ...) { data.frame(x = x$x, y = x$y) } # helper ------------------ .estimate_density_df <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ci = NULL, select = NULL, ...) { # TODO: replace by exposed select argument if (is.null(select)) { x <- .select_nums(x) } else { x <- datawizard::data_select(x, select, ...) } out <- sapply( x, estimate_density, method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ci = ci, simplify = FALSE ) for (i in names(out)) { if (nrow(out[[i]]) == 0) { insight::format_warning(paste0("`", i, "`, or one of its groups specified in `by`, is empty and has no density information.")) } else { out[[i]]$Parameter <- i } } out <- do.call(rbind, out) row.names(out) <- NULL out[, c("Parameter", "x", "y")] } #' Density Probability at a Given Value #' #' Compute the density value at a given point of a distribution (i.e., #' the value of the `y` axis of a value `x` of a distribution). #' #' @param posterior Vector representing a posterior distribution. #' @param x The value of which to get the approximate probability. #' @inheritParams estimate_density #' #' @examples #' library(bayestestR) #' posterior <- distribution_normal(n = 10) #' density_at(posterior, 0) #' density_at(posterior, c(0, 1)) #' @export density_at <- function(posterior, x, precision = 2^10, method = "kernel", ...) { posterior_density <- estimate_density(posterior, precision = precision, method = method, ...) stats::approx(posterior_density$x, posterior_density$y, xout = x)$y } # Different functions ----------------------------------------------------- .estimate_density_kernel <- function(x, x_range, precision, bw, ci = 0.95, ...) { # unsupported arguments raise warnings dots <- list(...) dots[c("effects", "component", "parameters")] <- NULL # Get the kernel density estimation (KDE) my_args <- c(dots, list( x = x, n = precision, bw = bw, from = x_range[1], to = x_range[2] )) fun <- get("density", asNamespace("stats")) kde <- suppressWarnings(do.call("fun", my_args)) my_df <- as.data.frame(kde) # Get CI (https://bookdown.org/egarpor/NP-UC3M/app-kde-ci.html) if (!is.null(ci)) { h <- kde$bw # Selected bandwidth # R(K) for a normal Rk <- 1 / (2 * sqrt(pi)) # Estimate the SD sd_kde <- sqrt(my_df$y * Rk / (length(x) * h)) # CI with estimated variance z_alpha <- stats::qnorm(ci) my_df$CI_low <- my_df$y - z_alpha * sd_kde my_df$CI_high <- my_df$y + z_alpha * sd_kde } my_df } .estimate_density_logspline <- function(x, x_range, precision, ...) { insight::check_if_installed("logspline") x_axis <- seq(x_range[1], x_range[2], length.out = precision) y <- logspline::dlogspline(x_axis, logspline::logspline(x, ...), ...) data.frame(x = x_axis, y = y) } .estimate_density_KernSmooth <- function(x, x_range, precision, ...) { insight::check_if_installed("KernSmooth") as.data.frame(KernSmooth::bkde(x, range.x = x_range, gridsize = precision, truncate = TRUE, ...)) } .estimate_density_mixture <- function(x, x_range, precision, ...) { insight::check_if_installed("mclust") x_axis <- seq(x_range[1], x_range[2], length.out = precision) y <- stats::predict(mclust::densityMclust(x, verbose = FALSE, ...), newdata = x_axis, ...) data.frame(x = x_axis, y = y) } .set_density_df_class <- function(out) { setdiff( unique(c("estimate_density_df", "see_estimate_density_df", class(out))), c("estimate_density", "see_estimate_density") ) } .set_density_class <- function(out) { if (is.null(out)) { return(NULL) } setdiff( unique(c("estimate_density", "see_estimate_density", class(out))), c("estimate_density_df", "see_estimate_density_df") ) } bayestestR/R/reexports.R0000644000176200001440000000034214505754740014770 0ustar liggesusers# DO NOT REMOVE # Re-exported generics for which the current package defines S3 methods #' @importFrom insight print_html #' @export insight::print_html #' @importFrom insight print_md #' @export insight::print_md bayestestR/R/hdi.R0000644000176200001440000003565114560763455013520 0ustar liggesusers#' Highest Density Interval (HDI) #' #' Compute the **Highest Density Interval (HDI)** of posterior distributions. #' All points within this interval have a higher probability density than points #' outside the interval. The HDI can be used in the context of uncertainty #' characterisation of posterior distributions as **Credible Interval (CI)**. #' #' @param x Vector representing a posterior distribution, or a data frame of such #' vectors. Can also be a Bayesian model. **bayestestR** supports a wide range #' of models (see, for example, `methods("hdi")`) and not all of those are #' documented in the 'Usage' section, because methods for other classes mostly #' resemble the arguments of the `.numeric` or `.data.frame`methods. #' @param ci Value or vector of probability of the (credible) interval - CI #' (between 0 and 1) to be estimated. Default to `.95` (`95%`). #' @param effects Should results for fixed effects, random effects or both be #' returned? Only applies to mixed models. May be abbreviated. #' @param component Should results for all parameters, parameters for the #' conditional model or the zero-inflated part of the model be returned? May #' be abbreviated. Only applies to \pkg{brms}-models. #' @param parameters Regular expression pattern that describes the parameters #' that should be returned. Meta-parameters (like `lp__` or `prior_`) are #' filtered by default, so only parameters that typically appear in the #' `summary()` are returned. Use `parameters` to select specific parameters #' for the output. #' @param use_iterations Logical, if `TRUE` and `x` is a `get_predicted` object, #' (returned by [`insight::get_predicted()`]), the function is applied to the #' iterations instead of the predictions. This only applies to models that return #' iterations for predicted values (e.g., `brmsfit` models). #' @param verbose Toggle off warnings. #' @param ... Currently not used. #' #' @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 Unlike equal-tailed intervals (see `eti()`) that typically exclude `2.5%` #' from each tail of the distribution and always include the median, the HDI is #' *not* equal-tailed and therefore always includes the mode(s) of posterior #' distributions. While this can be useful to better represent the credibility #' mass of a distribution, the HDI also has some limitations. See [`spi()`] for #' details. #' #' The [`95%` or `89%` Credible Intervals (CI)](https://easystats.github.io/bayestestR/articles/credible_interval.html) #' are two reasonable ranges to characterize the uncertainty related to the #' estimation (see [here](https://easystats.github.io/bayestestR/articles/credible_interval.html) #' for a discussion about the differences between these two values). #' #' The `89%` intervals (`ci = 0.89`) are deemed to be more stable than, for #' instance, `95%` intervals (_Kruschke, 2014_). An effective sample size #' of at least 10.000 is recommended if one wants to estimate `95%` intervals #' with high precision (_Kruschke, 2014, p. 183ff_). Unfortunately, the #' default number of posterior samples for most Bayes packages (e.g., `rstanarm` #' or `brms`) is only 4.000 (thus, you might want to increase it when fitting #' your model). Moreover, 89 indicates the arbitrariness of interval limits - #' its only remarkable property is being the highest prime number that does not #' exceed the already unstable `95%` threshold (_McElreath, 2015_). #' #' However, `95%` has some [advantages #' too](https://easystats.github.io/blog/posts/bayestestr_95/). For instance, it #' shares (in the case of a normal posterior distribution) an intuitive #' relationship with the standard deviation and it conveys a more accurate image #' of the (artificial) bounds of the distribution. Also, because it is wider, it #' makes analyses more conservative (i.e., the probability of covering 0 is #' larger for the `95%` CI than for lower ranges such as `89%`), which is a good #' thing in the context of the reproducibility crisis. #' #' A `95%` equal-tailed interval (ETI) has `2.5%` of the distribution on either #' side of its limits. It indicates the 2.5th percentile and the 97.5h #' percentile. In symmetric distributions, the two methods of computing credible #' intervals, the ETI and the [HDI][hdi], return similar results. #' #' This is not the case for skewed distributions. Indeed, it is possible that #' parameter values in the ETI have lower credibility (are less probable) than #' parameter values outside the ETI. This property seems undesirable as a summary #' of the credible values in a distribution. #' #' On the other hand, the ETI range does change when transformations are applied #' to the distribution (for instance, for a log odds scale to probabilities): #' the lower and higher bounds of the transformed distribution will correspond #' to the transformed lower and higher bounds of the original distribution. #' On the contrary, applying transformations to the distribution will change #' the resulting HDI. #' #' @inherit ci return #' #' @family ci #' @seealso Other interval functions, such as [hdi()], [eti()], [bci()], [spi()], [si()], [cwi()]. #' #' @examplesIf require("rstanarm") && require("brms") && require("emmeans") && require("BayesFactor") #' library(bayestestR) #' #' posterior <- rnorm(1000) #' hdi(posterior, ci = 0.89) #' hdi(posterior, ci = c(0.80, 0.90, 0.95)) #' #' bayestestR::hdi(iris[1:4]) #' bayestestR::hdi(iris[1:4], ci = c(0.80, 0.90, 0.95)) #' \donttest{ #' model <- suppressWarnings( #' rstanarm::stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) #' ) #' bayestestR::hdi(model) #' bayestestR::hdi(model, ci = c(0.80, 0.90, 0.95)) #' #' bayestestR::hdi(emmeans::emtrends(model, ~1, "wt", data = mtcars)) #' #' model <- brms::brm(mpg ~ wt + cyl, data = mtcars) #' bayestestR::hdi(model) #' bayestestR::hdi(model, ci = c(0.80, 0.90, 0.95)) #' #' bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) #' bayestestR::hdi(bf) #' bayestestR::hdi(bf, ci = c(0.80, 0.90, 0.95)) #' } #' @author Credits go to **ggdistribute** and [**HDInterval**](https://github.com/mikemeredith/HDInterval). #' #' @references #' - Kruschke, J. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, #' and Stan. Academic Press. #' - McElreath, R. (2015). Statistical rethinking: A Bayesian course with #' examples in R and Stan. Chapman and Hall/CRC. #' #' @export hdi <- function(x, ...) { UseMethod("hdi") } #' @export hdi.default <- function(x, ...) { insight::format_error(paste0("'hdi()' is not yet implemented for objects of class '", class(x)[1], "'.")) } #' @rdname hdi #' @export hdi.numeric <- function(x, ci = 0.95, verbose = TRUE, ...) { out <- do.call(rbind, lapply(ci, function(i) { .hdi(x, ci = i, verbose = verbose) })) class(out) <- unique(c("bayestestR_hdi", "see_hdi", "bayestestR_ci", "see_ci", class(out))) attr(out, "data") <- x out } #' @rdname hdi #' @export hdi.data.frame <- function(x, ci = 0.95, verbose = TRUE, ...) { dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "hdi") attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export hdi.draws <- function(x, ci = 0.95, verbose = TRUE, ...) { dat <- .compute_interval_dataframe(x = .posterior_draws_to_df(x), ci = ci, verbose = verbose, fun = "hdi") attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export hdi.rvar <- hdi.draws #' @export hdi.MCMCglmm <- function(x, ci = 0.95, verbose = TRUE, ...) { ci_fun <- .check_ci_fun(list(...)) 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 = ci_fun) attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export hdi.bamlss <- function(x, ci = 0.95, component = c("all", "conditional", "location"), verbose = TRUE, ...) { ci_fun <- .check_ci_fun(list(...)) component <- match.arg(component) d <- insight::get_parameters(x, component = component) dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = ci_fun) dat <- .add_clean_parameters_attribute(dat, x) attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export hdi.mcmc <- function(x, ci = 0.95, verbose = TRUE, ...) { ci_fun <- .check_ci_fun(list(...)) d <- as.data.frame(x) dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = ci_fun) attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export hdi.bcplm <- function(x, ci = 0.95, verbose = TRUE, ...) { ci_fun <- .check_ci_fun(list(...)) d <- insight::get_parameters(x) dat <- .compute_interval_dataframe(x = d, ci = ci, verbose = verbose, fun = ci_fun) attr(dat, "data") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export hdi.bayesQR <- hdi.bcplm #' @export hdi.blrm <- hdi.bcplm #' @export hdi.mcmc.list <- hdi.bcplm #' @export hdi.BGGM <- hdi.bcplm #' @export hdi.sim.merMod <- function(x, ci = 0.95, effects = c("fixed", "random", "all"), parameters = NULL, verbose = TRUE, ...) { ci_fun <- .check_ci_fun(list(...)) effects <- match.arg(effects) dat <- .compute_interval_simMerMod( x = x, ci = ci, effects = effects, parameters = parameters, verbose = verbose, fun = ci_fun ) out <- dat$result attr(out, "data") <- dat$data out } #' @export hdi.sim <- function(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) { ci_fun <- .check_ci_fun(list(...)) dat <- .compute_interval_sim( x = x, ci = ci, parameters = parameters, verbose = verbose, fun = ci_fun ) out <- dat$result attr(out, "data") <- dat$data out } #' @export hdi.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) { xdf <- insight::get_parameters(x) out <- hdi(xdf, ci = ci, verbose = verbose, ...) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export hdi.emm_list <- hdi.emmGrid #' @rdname hdi #' @export hdi.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( hdi( 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", class(out))) out } #' @export hdi.stanfit <- hdi.stanreg #' @export hdi.blavaan <- hdi.stanreg #' @rdname hdi #' @export hdi.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( hdi( 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", class(out))) out } #' @export hdi.BFBayesFactor <- function(x, ci = 0.95, verbose = TRUE, ...) { out <- hdi(insight::get_parameters(x), ci = ci, verbose = verbose, ...) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @rdname hdi #' @export hdi.get_predicted <- function(x, ci = 0.95, use_iterations = FALSE, verbose = TRUE, ...) { if (isTRUE(use_iterations)) { if ("iterations" %in% names(attributes(x))) { out <- hdi(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 <- hdi(as.numeric(x), ci = ci, verbose = verbose, ...) } out } # Helper ------------------------------------------------------------------ #' @keywords internal .hdi <- function(x, ci = 0.95, verbose = TRUE) { check_ci <- .check_ci_argument(x, ci, verbose) if (!is.null(check_ci)) { return(check_ci) } x_sorted <- unname(sort.int(x, method = "quick")) # removes NA/NaN, but not Inf window_size <- ceiling(ci * length(x_sorted)) # See https://github.com/easystats/bayestestR/issues/39 if (window_size < 2) { if (verbose) { insight::format_alert("`ci` is too small or x does not contain enough data points, returning NAs.") } return(data.frame( CI = ci, CI_low = NA, CI_high = NA )) } nCIs <- length(x_sorted) - window_size if (nCIs < 1) { if (verbose) { insight::format_alert("`ci` is too large or x does not contain enough data points, returning NAs.") } return(data.frame( CI = ci, CI_low = NA, CI_high = NA )) } ci.width <- sapply(1:nCIs, function(.x) x_sorted[.x + window_size] - x_sorted[.x]) # find minimum of width differences, check for multiple minima min_i <- which(ci.width == min(ci.width)) n_candies <- length(min_i) if (n_candies > 1) { if (any(diff(sort(min_i)) != 1)) { if (verbose) { insight::format_alert("Identical densities found along different segments of the distribution, choosing rightmost.") } min_i <- max(min_i) } else { min_i <- floor(mean(min_i)) } } data.frame( CI = ci, CI_low = x_sorted[min_i], CI_high = x_sorted[min_i + window_size] ) } bayestestR/R/overlap.R0000644000176200001440000000437014461433341014402 0ustar liggesusers#' Overlap Coefficient #' #' A method to calculate the overlap coefficient between two empirical distributions (that can be used as a measure of similarity between two samples). #' #' @param x Vector of x values. #' @param y Vector of x values. #' @param method_auc Area Under the Curve (AUC) estimation method. See [area_under_curve()]. #' @param method_density Density estimation method. See [estimate_density()]. #' @inheritParams estimate_density #' #' @examples #' library(bayestestR) #' #' x <- distribution_normal(1000, 2, 0.5) #' y <- distribution_normal(1000, 0, 1) #' #' overlap(x, y) #' plot(overlap(x, y)) #' @export overlap <- function(x, y, method_density = "kernel", method_auc = "trapezoid", precision = 2^10, extend = TRUE, extend_scale = 0.1, ...) { # Generate densities dx <- estimate_density(x, method = method_density, precision = precision, extend = extend, extend_scale = extend_scale, ...) dy <- estimate_density(y, method = method_density, precision = precision, extend = extend, extend_scale = extend_scale, ...) # Create density estimation functions fx <- stats::approxfun(dx$x, dx$y, method = "linear", rule = 2) fy <- stats::approxfun(dy$x, dy$y, method = "linear", rule = 2) x_axis <- seq(min(c(dx$x, dy$x)), max(c(dx$x, dy$x)), length.out = precision) data <- data.frame(x = x_axis, y1 = fx(x_axis), y2 = fy(x_axis)) # calculate intersection densities data$intersection <- pmin(data$y1, data$y2) data$exclusion <- pmax(data$y1, data$y2) # integrate areas under curves area_intersection <- area_under_curve(data$x, data$intersection, method = method_auc) # area_exclusion <- area_under_curve(data$x, data$exclusion, method = method_auc) # compute overlap coefficient overlap <- area_intersection attr(overlap, "data") <- data class(overlap) <- c("overlap", class(overlap)) overlap } #' @export print.overlap <- function(x, ...) { insight::print_color("# Overlap\n\n", "blue") cat(sprintf("%.1f%%\n", 100 * as.numeric(x))) } #' @export plot.overlap <- function(x, ...) { # Can be improved through see data <- attributes(x)$data graphics::plot(data$x, data$exclusion, type = "l") graphics::polygon(data$x, data$intersection, col = "red") } bayestestR/R/simulate_data.R0000644000176200001440000001116414650172354015551 0ustar liggesusers#' Data Simulation #' #' Simulate data with specific characteristics. #' #' @param n The number of observations to be generated. #' @param r A value or vector corresponding to the desired correlation #' coefficients. #' @param d A value or vector corresponding to the desired difference between #' the groups. #' @param mean A value or vector corresponding to the mean of the variables. #' @param sd A value or vector corresponding to the SD of the variables. #' @param names A character vector of desired variable names. #' @param ... Arguments passed to or from other methods. #' @examplesIf requireNamespace("MASS", quietly = TRUE) #' #' # Correlation -------------------------------- #' data <- simulate_correlation(r = 0.5) #' plot(data$V1, data$V2) #' cor.test(data$V1, data$V2) #' summary(lm(V2 ~ V1, data = data)) #' #' # Specify mean and SD #' data <- simulate_correlation(r = 0.5, n = 50, mean = c(0, 1), sd = c(0.7, 1.7)) #' cor.test(data$V1, data$V2) #' round(c(mean(data$V1), sd(data$V1)), 1) #' round(c(mean(data$V2), sd(data$V2)), 1) #' summary(lm(V2 ~ V1, data = data)) #' #' # Generate multiple variables #' 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, names = c("y", "x1", "x2")) #' cor(data) #' summary(lm(y ~ x1, data = data)) #' #' # t-test -------------------------------- #' data <- simulate_ttest(n = 30, d = 0.3) #' plot(data$V1, data$V0) #' round(c(mean(data$V1), sd(data$V1)), 1) #' diff(t.test(data$V1 ~ data$V0)$estimate) #' summary(lm(V1 ~ V0, data = data)) #' summary(glm(V0 ~ V1, data = data, family = "binomial")) #' #' # Difference -------------------------------- #' data <- simulate_difference(n = 30, d = 0.3) #' plot(data$V1, data$V0) #' round(c(mean(data$V1), sd(data$V1)), 1) #' diff(t.test(data$V1 ~ data$V0)$estimate) #' summary(lm(V1 ~ V0, data = data)) #' summary(glm(V0 ~ V1, data = data, family = "binomial")) #' @export simulate_correlation <- function(n = 100, r = 0.5, mean = 0, sd = 1, names = NULL, ...) { insight::check_if_installed("MASS") # Define matrix if (is.matrix(r)) { if (isSymmetric(r)) { if (any(r > 1)) { insight::format_error("`r` should only contain values between -1 and 1.") } else { dispersion <- r } } else { insight::format_error("`r` should be a symetric matrix (relative to the diagonal).") } } else if (length(r) == 1L) { if (abs(r) > 1) { insight::format_error("`r` should only contain values between -1 and 1.") } else { dispersion <- matrix(c(1, r, r, 1), nrow = 2) } } else { insight::format_error("`r` should be a value (e.g., r = 0.5) or a square matrix.") } # Get data out <- MASS::mvrnorm( n = n, mu = rep_len(0, ncol(dispersion)), # Means of variables Sigma = dispersion, empirical = TRUE ) # Adjust scale if (any(sd != 1)) { out <- t(t(out) * rep_len(sd, ncol(dispersion))) } # Adjust mean if (any(mean != 0)) { out <- t(t(out) + rep_len(mean, ncol(dispersion))) } out <- as.data.frame(out) # Rename if (!is.null(names) && length(names) == ncol(out)) { names(out) <- names } out } #' @rdname simulate_correlation #' @export simulate_ttest <- function(n = 100, d = 0.5, names = NULL, ...) { x <- distribution_normal(n, 0, 1) # Continuous variables z <- 0 + d * x # Linear combination pr <- 1 / (1 + exp(-z)) # Pass it through an inverse logit function y <- distribution_binomial(n, 1, pr, random = 3) # Bernoulli response variable out <- data.frame(y = as.factor(y), x = x) names(out) <- paste0("V", 0:(ncol(out) - 1)) if (!is.null(names) && length(names) == ncol(out)) { names(out) <- names } out } #' @rdname simulate_correlation #' @export simulate_difference <- function(n = 100, d = 0.5, names = NULL, ...) { x <- distribution_normal(round(n / 2), -d / 2, 1) y <- distribution_normal(round(n / 2), d / 2, 1) out <- data.frame( y = as.factor(rep(c(0, 1), each = round(n / 2))), x = c(x, y) ) names(out) <- paste0("V", 0:(ncol(out) - 1)) if (!is.null(names) && length(names) == ncol(out)) { names(out) <- names } out } # Simulate regression: see https://stats.stackexchange.com/questions/363623/simulate-regression-with-specified-standardized-coefficients/508107#508107 bayestestR/R/sexit.R0000644000176200001440000003324314650172354014073 0ustar liggesusers#' Sequential Effect eXistence and sIgnificance Testing (SEXIT) #' #' @description #' #' The SEXIT is a new framework to describe Bayesian effects, guiding which #' indices to use. Accordingly, the `sexit()` function returns the minimal (and #' optimal) required information to describe models' parameters under a Bayesian #' framework. It includes the following indices: #' #' - Centrality: the median of the posterior distribution. In #' probabilistic terms, there is `50%` of probability that the effect is higher #' and lower. See [`point_estimate()`][point_estimate]. #' #' - Uncertainty: the `95%` Highest Density Interval (HDI). In #' probabilistic terms, there is `95%` of probability that the effect is #' within this confidence interval. See [`ci()`][ci]. #' #' - Existence: The probability of direction allows to quantify the #' certainty by which an effect is positive or negative. It is a critical #' index to show that an effect of some manipulation is not harmful (for #' instance in clinical studies) or to assess the direction of a link. See #' [`p_direction()`][p_direction]. #' #' - Significance: Once existence is demonstrated with high certainty, we #' can assess whether the effect is of sufficient size to be considered as #' significant (i.e., not negligible). This is a useful index to determine #' which effects are actually important and worthy of discussion in a given #' process. See [`p_significance()`][p_significance]. #' #' - Size: Finally, this index gives an idea about the strength of an #' effect. However, beware, as studies have shown that a big effect size can #' be also suggestive of low statistical power (see details section). #' #' @inheritParams p_direction #' @inheritParams hdi #' @param significant,large The threshold values to use for significant and #' large probabilities. If left to 'default', will be selected through #' [`sexit_thresholds()`][sexit_thresholds]. See the details section below. #' #' @details #' #' \subsection{Rationale}{ #' The assessment of "significance" (in its broadest meaning) is a pervasive #' issue in science, and its historical index, the p-value, has been strongly #' criticized and deemed to have played an important role in the replicability #' crisis. In reaction, more and more scientists have tuned to Bayesian methods, #' offering an alternative set of tools to answer their questions. However, the #' Bayesian framework offers a wide variety of possible indices related to #' "significance", and the debate has been raging about which index is the best, #' and which one to report. #' #' This situation can lead to the mindless reporting of all possible indices #' (with the hopes that with that the reader will be satisfied), but often #' without having the writer understanding and interpreting them. It is indeed #' complicated to juggle between many indices with complicated definitions and #' subtle differences. #' #' SEXIT aims at offering a practical framework for Bayesian effects reporting, #' in which the focus is put on intuitiveness, explicitness and usefulness of #' the indices' interpretation. To that end, we suggest a system of description #' of parameters that would be intuitive, easy to learn and apply, #' mathematically accurate and useful for taking decision. #' #' Once the thresholds for significance (i.e., the ROPE) and the one for a #' "large" effect are explicitly defined, the SEXIT framework does not make any #' interpretation, i.e., it does not label the effects, but just sequentially #' gives 3 probabilities (of direction, of significance and of being large, #' respectively) as-is on top of the characteristics of the posterior (using the #' median and HDI for centrality and uncertainty description). Thus, it provides #' a lot of information about the posterior distribution (through the mass of #' different 'sections' of the posterior) in a clear and meaningful way. #' } #' #' \subsection{Threshold selection}{ #' One of the most important thing about the SEXIT framework is that it relies #' on two "arbitrary" thresholds (i.e., that have no absolute meaning). They #' are the ones related to effect size (an inherently subjective notion), #' namely the thresholds for significant and large effects. They are set, by #' default, to `0.05` and `0.3` of the standard deviation of the outcome #' variable (tiny and large effect sizes for correlations according to Funder #' and Ozer, 2019). However, these defaults were chosen by lack of a better #' option, and might not be adapted to your case. Thus, they are to be handled #' with care, and the chosen thresholds should always be explicitly reported #' and justified. #' #' - For **linear models (lm)**, this can be generalised to \ifelse{html}{\out{0.05 * SDy}}{\eqn{[0.05*SD_{y}]}} and \ifelse{html}{\out{0.3 * SDy}}{\eqn{[0.3*SD_{y}]}} for significant and large effects, respectively. #' - 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 a threshold of `0.09` and `0.54`. #' - 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.05` and `0.3`, 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` and `0.3` are used. #' - For all other models, `0.05` and `0.3` are used, but it is strongly advised to specify it manually. #' } #' #' \subsection{Examples}{ #' The three values for existence, significance and size provide a useful #' description of the posterior distribution of the effects. Some possible #' scenarios include: #' #' - The probability of existence is low, but the probability of being large is high: it suggests that the posterior is very wide (covering large territories on both side of 0). The statistical power might be too low, which should warrant any confident conclusion. #' - The probability of existence and significance is high, but the probability of being large is very small: it suggests that the effect is, with high confidence, not large (the posterior is mostly contained between the significance and the large thresholds). #' - The 3 indices are very low: this suggests that the effect is null with high confidence (the posterior is closely centred around 0). #' } #' #' @return A dataframe and text as attribute. #' #' @references #' #' - Makowski, D., Ben-Shachar, M. S., & Lüdecke, D. (2019). bayestestR: #' Describing Effects and their Uncertainty, Existence and Significance within #' the Bayesian Framework. Journal of Open Source Software, 4(40), 1541. \doi{10.21105/joss.01541} #' #' - 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} #' #' @examples #' \donttest{ #' library(bayestestR) #' #' s <- sexit(rnorm(1000, -1, 1)) #' s #' print(s, summary = TRUE) #' #' s <- sexit(iris) #' s #' print(s, summary = TRUE) #' #' if (require("rstanarm")) { #' model <- suppressWarnings(rstanarm::stan_glm(mpg ~ wt * cyl, #' data = mtcars, #' iter = 400, refresh = 0 #' )) #' s <- sexit(model) #' s #' print(s, summary = TRUE) #' } #' } #' @export sexit <- function(x, significant = "default", large = "default", ci = 0.95, ...) { thresholds <- .sexit_preprocess(x, significant, large, ...) significant <- thresholds$significant large <- thresholds$large thresholds_text <- thresholds$text # Description centrality <- point_estimate(x, "median") centrality$Effects <- centrality$Component <- NULL centrality_text <- paste0("Median = ", insight::format_value(centrality$Median)) direction <- ifelse(centrality$Median < 0, "negative", "positive") uncertainty <- ci(x, ci = ci, method = "ETI", ...)[c("CI", "CI_low", "CI_high")] uncertainty_text <- insight::format_ci(uncertainty$CI_low, uncertainty$CI_high, uncertainty$CI) # Indices existence_rez <- as.numeric(p_direction(x, ...)) existence_value <- insight::format_value(existence_rez, as_percent = TRUE) existence_threshold <- ifelse(direction == "negative", "< 0", "> 0") sig_rez <- as.numeric(p_significance(x, threshold = significant, ...)) sig_value <- insight::format_value(sig_rez, as_percent = TRUE) sig_threshold <- ifelse(direction == "negative", -1 * significant, significant) sig_threshold <- paste0(ifelse(direction == "negative", "< ", "> "), insight::format_value(sig_threshold)) large_rez <- as.numeric(p_significance(x, threshold = large, ...)) large_value <- insight::format_value(large_rez, as_percent = TRUE) large_threshold <- ifelse(direction == "negative", -1 * large, large) large_threshold <- paste0(ifelse(direction == "negative", "< ", "> "), insight::format_value(large_threshold)) if ("Parameter" %in% names(centrality)) { parameters <- centrality$Parameter } else { parameters <- "The effect" } text_full <- paste0( parameters, " (", centrality_text, ", ", uncertainty_text, ") has a ", existence_value, " probability of being ", direction, " (", existence_threshold, "), ", sig_value, " of being significant (", sig_threshold, "), and ", large_value, " of being large (", large_threshold, ")" ) text_short <- paste0( parameters, " (", centrality_text, ", ", uncertainty_text, ") has ", existence_value, ", ", sig_value, " and ", large_value, " probability of being ", direction, " (", existence_threshold, "), significant (", sig_threshold, ") and large (", large_threshold, ")" ) out <- cbind( centrality, as.data.frame(uncertainty), data.frame(Direction = existence_rez), data.frame(Significance = sig_rez), data.frame(Large = large_rez) ) # Prepare output attr(out, "sexit_info") <- "Following the Sequential Effect eXistence and sIgnificance Testing (SEXIT) framework, we report the median of the posterior distribution and its 95% CI (Highest Density Interval), along the probability of direction (pd), the probability of significance and the probability of being large." attr(out, "sexit_ci_method") <- "ETI" attr(out, "sexit_significance") <- significant attr(out, "sexit_large") <- large attr(out, "sexit_textlong") <- text_full attr(out, "sexit_textshort") <- text_short attr(out, "sexit_thresholds") <- thresholds_text pretty_cols <- c( "Median", paste0(insight::format_value(ci * 100, protect_integers = TRUE), "% CI"), "Direction", paste0("Significance (> |", insight::format_value(significant), "|)"), paste0("Large (> |", insight::format_value(large), "|)") ) if ("Parameter" %in% names(out)) pretty_cols <- c("Parameter", pretty_cols) attr(out, "pretty_cols") <- pretty_cols attr(out, "data") <- x class(out) <- unique(c("sexit", "see_sexit", class(out))) out } #' @keywords internal .sexit_preprocess <- function(x, significant = "default", large = "default", ...) { thresholds <- sexit_thresholds(x) if (significant == "default") significant <- thresholds[1] if (large == "default") large <- thresholds[2] suppressWarnings({ resp <- .safe(insight::get_response(x, type = "mf")) }) suppressWarnings({ info <- .safe(insight::model_info(x, verbose = FALSE)) }) if (!is.null(resp) && !is.null(info) && info$is_linear) { sd1 <- significant / stats::sd(resp, na.rm = TRUE) sd2 <- large / stats::sd(resp, na.rm = TRUE) text_sd <- paste0( " (corresponding respectively to ", insight::format_value(sd1), " and ", insight::format_value(sd2), " of the outcome's SD)" ) } else { text_sd <- "" } thresholds <- paste0( "The thresholds beyond which the effect is considered ", "as significant (i.e., non-negligible) and large are |", insight::format_value(significant), "| and |", insight::format_value(large), "|", text_sd, "." ) list(significant = significant, large = large, text = thresholds) } #' @export print.sexit <- function(x, summary = FALSE, digits = 2, ...) { orig_x <- x # Long if (isFALSE(summary)) { insight::print_color(paste0("# ", attributes(x)$sexit_info, " ", attributes(x)$sexit_thresholds, "\n\n"), "blue") text <- attributes(x)$sexit_textlong if (length(text) > 1) text <- paste0(paste0("- ", text), collapse = "\n") insight::print_color(text, "yellow") cat("\n\n") df <- data.frame(Median = x$Median, CI = insight::format_ci(x$CI_low, x$CI_high, NULL)) if ("Parameter" %in% names(x)) { df <- cbind(data.frame(Parameter = x$Parameter), df, x[c("Direction", "Significance", "Large")]) } else { df <- cbind(df, x[c("Direction", "Significance", "Large")]) } names(df) <- attributes(x)$pretty_cols .print_data_frame(df, digits = digits, ...) # Short } else { insight::print_color(paste0("# ", attributes(x)$sexit_thresholds, "\n\n"), "blue") text <- attributes(x)$sexit_textshort if (length(text) > 1) text <- paste0(paste0("- ", text), collapse = "\n") cat(text) } invisible(orig_x) } bayestestR/R/describe_posterior.R0000644000176200001440000012706614650172354016634 0ustar liggesusers#' Describe Posterior Distributions #' #' Compute indices relevant to describe and characterize the posterior distributions. #' #' @param posterior A vector, data frame or model of posterior draws. #' **bayestestR** supports a wide range of models (see `methods("describe_posterior")`) #' and not all of those are documented in the 'Usage' section, because methods #' for other classes mostly resemble the arguments of the `.numeric` method. #' @param ci_method The type of index used for Credible Interval. Can be #' `"ETI"` (default, see [bayestestR::eti()]), `"HDI"` #' (see [bayestestR::hdi()]), `"BCI"` (see #' [bayestestR::bci()]), `"SPI"` (see [bayestestR::spi()]), or #' `"SI"` (see [bayestestR::si()]). #' @param test The indices of effect existence to compute. Character (vector) or #' list with one or more of these options: `"p_direction"` (or `"pd"`), #' `"rope"`, `"p_map"`, `"equivalence_test"` (or `"equitest"`), #' `"bayesfactor"` (or `"bf"`) or `"all"` to compute all tests. #' For each "test", the corresponding \pkg{bayestestR} function is called #' (e.g. [bayestestR::rope()] or [bayestestR::p_direction()]) and its results #' included in the summary output. #' @param rope_range ROPE's lower and higher bounds. Should be a list of two #' values (e.g., `c(-0.1, 0.1)`) or `"default"`. If `"default"`, #' the bounds are set to `x +- 0.1*SD(response)`. #' @param rope_ci The Credible Interval (CI) probability, corresponding to the #' proportion of HDI, to use for the percentage in ROPE. #' @param keep_iterations If `TRUE`, will keep all iterations (draws) of #' bootstrapped or Bayesian models. They will be added as additional columns #' named `iter_1, iter_2, ...`. You can reshape them to a long format by #' running [bayestestR::reshape_iterations()]. #' @param bf_prior Distribution representing a prior for the computation of #' Bayes factors / SI. Used if the input is a posterior, otherwise (in the #' case of models) ignored. #' @param priors Add the prior used for each parameter. #' #' @inheritParams point_estimate #' @inheritParams ci #' @inheritParams si #' @inheritParams hdi #' #' @details #' One or more components of point estimates (like posterior mean or median), #' intervals and tests can be omitted from the summary output by setting the #' related argument to `NULL`. For example, `test = NULL` and `centrality = #' NULL` would only return the HDI (or CI). #' #' @references #' - Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and 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} #' - [Region of Practical Equivalence (ROPE)](https://easystats.github.io/bayestestR/articles/region_of_practical_equivalence.html) #' - [Bayes factors](https://easystats.github.io/bayestestR/articles/bayes_factors.html) #' #' @examples #' library(bayestestR) #' #' if (require("logspline")) { #' x <- rnorm(1000) #' describe_posterior(x, verbose = FALSE) #' describe_posterior(x, #' centrality = "all", #' dispersion = TRUE, #' test = "all", #' verbose = FALSE #' ) #' describe_posterior(x, ci = c(0.80, 0.90), verbose = FALSE) #' #' df <- data.frame(replicate(4, rnorm(100))) #' describe_posterior(df, verbose = FALSE) #' describe_posterior( #' df, #' centrality = "all", #' dispersion = TRUE, #' test = "all", #' verbose = FALSE #' ) #' describe_posterior(df, ci = c(0.80, 0.90), verbose = FALSE) #' #' df <- data.frame(replicate(4, rnorm(20))) #' head(reshape_iterations( #' describe_posterior(df, keep_iterations = TRUE, verbose = FALSE) #' )) #' } #' \donttest{ #' # rstanarm models #' # ----------------------------------------------- #' if (require("rstanarm") && require("emmeans")) { #' model <- suppressWarnings( #' stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) #' ) #' describe_posterior(model) #' describe_posterior(model, centrality = "all", dispersion = TRUE, test = "all") #' describe_posterior(model, ci = c(0.80, 0.90)) #' #' # emmeans estimates #' # ----------------------------------------------- #' describe_posterior(emtrends(model, ~1, "wt")) #' } #' #' # BayesFactor objects #' # ----------------------------------------------- #' if (require("BayesFactor")) { #' bf <- ttestBF(x = rnorm(100, 1, 1)) #' describe_posterior(bf) #' describe_posterior(bf, centrality = "all", dispersion = TRUE, test = "all") #' describe_posterior(bf, ci = c(0.80, 0.90)) #' } #' } #' @export describe_posterior <- function(posterior, ...) { UseMethod("describe_posterior") } #' @export describe_posterior.default <- function(posterior, ...) { insight::format_error( paste0("`describe_posterior()` is not yet implemented for objects of class `", class(posterior)[1], "`.") ) } #' @keywords internal .describe_posterior <- function(x, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, BF = 1, verbose = TRUE, ...) { if (is.null(x)) { if (verbose) { insight::format_warning("Could not extract posterior samples.") } return(NULL) } # we need this information from the original object if (all(rope_range == "default")) { rope_range <- rope_range(x, verbose = verbose, ...) } if (!is.data.frame(x) && !is.numeric(x)) { is_stanmvreg <- inherits(x, "stanmvreg") cleaned_parameters <- insight::clean_parameters(x) # rename to use `x` in bayes factor later x_df <- insight::get_parameters(x, ...) } else { cleaned_parameters <- NULL x_df <- x } # Arguments fixes if (!is.null(centrality) && length(centrality) == 1 && (centrality == "none" || isFALSE(centrality))) { centrality <- NULL } if (!is.null(ci) && length(ci) == 1 && (is.na(ci) || isFALSE(ci))) { ci <- NULL } if (!is.null(test) && length(test) == 1 && (test == "none" || isFALSE(test))) { test <- NULL } # Point-estimates if (is.null(centrality)) { estimates <- data.frame(Parameter = NA) } else { estimates <- .prepare_output( point_estimate(x_df, centrality = centrality, dispersion = dispersion, ...), cleaned_parameters, is_stanmvreg ) if (!"Parameter" %in% names(estimates)) { estimates <- cbind( data.frame(Parameter = "Posterior", stringsAsFactors = FALSE), estimates ) } } # Uncertainty if (is.null(ci)) { uncertainty <- data.frame(Parameter = NA) } else { ci_method <- match.arg(tolower(ci_method), c("hdi", "spi", "quantile", "ci", "eti", "si", "bci", "bcai")) # not sure why "si" requires the model object if (ci_method == "si") { uncertainty <- ci(x, BF = BF, method = ci_method, prior = bf_prior, verbose = verbose, ...) } else { uncertainty <- ci(x_df, ci = ci, method = ci_method, verbose = verbose, ...) } uncertainty <- .prepare_output( uncertainty, cleaned_parameters, is_stanmvreg ) if (!"Parameter" %in% names(uncertainty)) { uncertainty <- cbind( data.frame(Parameter = "Posterior", stringsAsFactors = FALSE), uncertainty ) } } # Effect Existence if (is.null(test)) { test_pd <- data.frame( Parameter = NA, Effects = NA, Component = NA, Response = NA ) test_rope <- data.frame( Parameter = NA, Effects = NA, Component = NA, Response = NA ) test_prope <- data.frame( Parameter = NA, Effects = NA, Component = NA, Response = NA ) test_psig <- data.frame( Parameter = NA, Effects = NA, Component = NA, Response = NA ) test_bf <- data.frame( Parameter = NA, Effects = NA, Component = NA, Response = NA ) test_pmap <- data.frame( Parameter = NA, Effects = NA, Component = NA, Response = NA ) } else { test <- .check_test_values(test) if ("all" %in% test) { test <- c("pd", "p_map", "p_rope", "p_significance", "rope", "equivalence", "bf") } ## TODO no BF for arm::sim if (inherits(x, c("sim", "sim.merMod", "mcmc", "stanfit"))) { test <- setdiff(test, "bf") } ## TODO enable once "rope()" works for multi-response models # no ROPE for multi-response models if (insight::is_multivariate(x)) { test <- setdiff(test, c("rope", "p_rope")) if (verbose) { insight::format_warning( "Multivariate response models are not yet supported for tests `rope` and `p_rope`." ) } } # MAP-based p-value if (any(c("p_map", "p_pointnull") %in% test)) { test_pmap <- .prepare_output( p_map(x_df, ...), cleaned_parameters, is_stanmvreg ) if (!is.data.frame(test_pmap)) { test_pmap <- data.frame( Parameter = "Posterior", p_MAP = test_pmap, stringsAsFactors = FALSE ) } } else { test_pmap <- data.frame(Parameter = NA) } # Probability of direction if (any(c("pd", "p_direction", "pdir", "mpe") %in% test)) { test_pd <- .prepare_output( p_direction(x_df, ...), cleaned_parameters, is_stanmvreg ) if (!is.data.frame(test_pd)) { test_pd <- data.frame( Parameter = "Posterior", pd = test_pd, stringsAsFactors = FALSE ) } } else { test_pd <- data.frame(Parameter = NA) } # Probability of rope if ("p_rope" %in% test) { test_prope <- .prepare_output( p_rope(x_df, range = rope_range, verbose = verbose, ...), cleaned_parameters, is_stanmvreg ) if (!"Parameter" %in% names(test_prope)) { test_prope <- cbind( data.frame(Parameter = "Posterior", stringsAsFactors = FALSE), test_prope ) } } else { test_prope <- data.frame(Parameter = NA) } # Probability of significance if (any(c("ps", "p_sig", "p_significance") %in% test)) { test_psig <- .prepare_output( p_significance(x_df, threshold = rope_range, ...), cleaned_parameters, is_stanmvreg ) if (!is.data.frame(test_psig)) { test_psig <- data.frame( Parameter = "Posterior", ps = test_psig, stringsAsFactors = FALSE ) } } else { test_psig <- data.frame(Parameter = NA) } # ROPE if ("rope" %in% test) { test_rope <- .prepare_output( rope(x_df, range = rope_range, ci = rope_ci, ...), cleaned_parameters, is_stanmvreg ) if (!"Parameter" %in% names(test_rope)) { test_rope <- cbind( data.frame(Parameter = "Posterior", stringsAsFactors = FALSE), test_rope ) } names(test_rope)[names(test_rope) == "CI"] <- "ROPE_CI" } else { test_rope <- data.frame(Parameter = NA) } # Equivalence test if (any(c("equivalence", "equivalence_test", "equitest") %in% test)) { dot_args <- list(...) dot_args$verbose <- !"rope" %in% test test_equi <- .prepare_output( equivalence_test(x_df, range = rope_range, ci = rope_ci, dot_args ), cleaned_parameters, is_stanmvreg ) test_equi$Cleaned_Parameter <- NULL if (!"Parameter" %in% names(test_equi)) { test_equi <- cbind( data.frame(Parameter = "Posterior", stringsAsFactors = FALSE), test_equi ) } names(test_equi)[names(test_equi) == "CI"] <- "ROPE_CI" test_rope <- merge(test_rope, test_equi, all = TRUE) test_rope <- test_rope[!names(test_rope) %in% c("HDI_low", "HDI_high")] } # Bayes Factors if (any(c("bf", "bayesfactor", "bayes_factor") %in% test)) { test_bf <- tryCatch( .prepare_output( bayesfactor_parameters(x, prior = bf_prior, verbose = verbose, ...), cleaned_parameters, is_stanmvreg ), error = function(e) data.frame(Parameter = NA) ) if (!"Parameter" %in% names(test_bf)) { test_bf <- cbind( data.frame(Parameter = "Posterior", stringsAsFactors = FALSE), test_bf ) } } else { test_bf <- data.frame(Parameter = NA) } } # for data frames or numeric, and even for some models, we don't # have the "Effects" or "Component" column for all data frames. # To make "merge()" work, we add those columns to all data frames, # filled with NA, and remove the columns later if necessary estimates <- .add_effects_component_column(estimates) uncertainty <- .add_effects_component_column(uncertainty) test_pmap <- .add_effects_component_column(test_pmap) test_pd <- .add_effects_component_column(test_pd) test_prope <- .add_effects_component_column(test_prope) test_psig <- .add_effects_component_column(test_psig) test_rope <- .add_effects_component_column(test_rope) test_bf <- .add_effects_component_column(test_bf) # at least one "valid" data frame needs a row id, to restore # row-order after merging if (!all(is.na(estimates$Parameter))) { estimates$.rowid <- seq_len(nrow(estimates)) } else if (!all(is.na(test_pmap$Parameter))) { test_pmap$.rowid <- seq_len(nrow(test_pmap)) } else if (!all(is.na(test_pd$Parameter))) { test_pd$.rowid <- seq_len(nrow(test_pd)) } else if (!all(is.na(test_prope$Parameter))) { test_prope$.rowid <- seq_len(nrow(test_prope)) } else if (!all(is.na(test_psig$Parameter))) { test_psig$.rowid <- seq_len(nrow(test_psig)) } else if (!all(is.na(test_rope$Parameter))) { test_rope$.rowid <- seq_len(nrow(test_rope)) } else if (!all(is.na(test_bf$Parameter))) { test_bf$.rowid <- seq_len(nrow(test_bf)) } else { estimates$.rowid <- seq_len(nrow(estimates)) } # remove duplicated columns if (all(c("rope", "p_rope") %in% test)) { test_prope$ROPE_low <- NULL test_prope$ROPE_high <- NULL } # merge all data frames merge_by <- c("Parameter", "Effects", "Component", "Response") # merge_by <- intersect(merge_by, colnames(estimates)) out <- merge(estimates, uncertainty, by = merge_by, all = TRUE) out <- merge(out, test_pmap, by = merge_by, all = TRUE) out <- merge(out, test_pd, by = merge_by, all = TRUE) out <- merge(out, test_prope, by = merge_by, all = TRUE) out <- merge(out, test_psig, by = merge_by, all = TRUE) out <- merge(out, test_rope, by = merge_by, all = TRUE) out <- merge(out, test_bf, by = merge_by, all = TRUE) out <- out[!is.na(out$Parameter), ] # check which columns can be removed at the end. In any case, we don't # need .rowid in the returned data frame, and when the Effects or Component # column consist only of missing values, we remove those columns as well remove_columns <- ".rowid" if (insight::n_unique(out$Effects, na.rm = TRUE) < 2) remove_columns <- c(remove_columns, "Effects") if (insight::n_unique(out$Component, na.rm = TRUE) < 2) remove_columns <- c(remove_columns, "Component") if (insight::n_unique(out$Response, na.rm = TRUE) < 2) remove_columns <- c(remove_columns, "Response") # Restore columns order out <- datawizard::data_remove(out[order(out$.rowid), ], remove_columns, verbose = FALSE) # Add iterations if (keep_iterations) { row_order <- out$Parameter iter <- as.data.frame(t(as.data.frame(x_df, ...))) names(iter) <- paste0("iter_", seq_len(ncol(iter))) iter$Parameter <- row.names(iter) out <- merge(out, iter, all.x = TRUE, by = "Parameter") out <- out[match(row_order, out$Parameter), ] row.names(out) <- NULL } # Prepare output attr(out, "ci_method") <- ci_method out } #' @keywords internal .add_effects_component_column <- function(x) { if (!"Effects" %in% names(x)) x <- cbind(x, data.frame(Effects = NA)) if (!"Component" %in% names(x)) x <- cbind(x, data.frame(Component = NA)) if (!"Response" %in% names(x)) x <- cbind(x, data.frame(Response = NA)) x } # Models based on simple data frame of posterior --------------------- #' @rdname describe_posterior #' @export describe_posterior.numeric <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, BF = 1, verbose = TRUE, ...) { out <- .describe_posterior( posterior, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, bf_prior = bf_prior, BF = BF, verbose = verbose, ... ) class(out) <- unique(c("describe_posterior", "see_describe_posterior", class(out))) out } #' @export describe_posterior.double <- describe_posterior.numeric #' @export describe_posterior.data.frame <- describe_posterior.numeric #' @export describe_posterior.sim.merMod <- describe_posterior.numeric #' @export describe_posterior.sim <- describe_posterior.numeric #' @export describe_posterior.bayesQR <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, parameters = NULL, verbose = TRUE, ...) { out <- .describe_posterior( insight::get_parameters(posterior), centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, effects = "fixed", parameters = parameters, verbose = verbose, ... ) attr(out, "ci_method") <- ci_method attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) out } #' @export describe_posterior.blrm <- describe_posterior.bayesQR #' @export describe_posterior.mcmc <- describe_posterior.bayesQR #' @export describe_posterior.mcmc.list <- describe_posterior.bayesQR #' @export describe_posterior.BGGM <- describe_posterior.bayesQR #' @export describe_posterior.draws <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, BF = 1, verbose = TRUE, ...) { out <- .describe_posterior( .posterior_draws_to_df(posterior), centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, bf_prior = bf_prior, BF = BF, verbose = verbose, ... ) class(out) <- unique(c("describe_posterior", "see_describe_posterior", class(out))) out } #' @export describe_posterior.rvar <- describe_posterior.draws # easystats methods ------------------------ #' @export describe_posterior.effectsize_std_params <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, BF = 1, verbose = TRUE, ...) { class(posterior) <- "data.frame" no_unique <- vapply(posterior, function(col) { length(unique(col)) == 1 }, FUN.VALUE = TRUE) if (any(no_unique)) { no_unique <- which(no_unique) out <- describe_posterior.data.frame( posterior[, -no_unique], centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, bf_prior = bf_prior, BF = BF, verbose = verbose, ... ) out_int <- data.frame(Parameter = colnames(posterior)[no_unique]) col_diff <- setdiff(colnames(out), colnames(out_int)) out_int[, col_diff] <- NA out <- rbind(out_int, out) out <- out[order(match(out$Parameter, colnames(posterior))), ] return(out) } describe_posterior.data.frame( posterior, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, bf_prior = bf_prior, BF = BF, verbose = verbose, ... ) } #' @export describe_posterior.get_predicted <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = NULL, verbose = TRUE, ...) { if ("iterations" %in% names(attributes(posterior))) { describe_posterior( as.data.frame(t(attributes(posterior)$iterations)), centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, verbose = verbose, ... ) } else { insight::format_error("No iterations present in the output.") } } # emmeans --------------------------- #' @export describe_posterior.emmGrid <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, BF = 1, verbose = TRUE, ...) { if (any(c("all", "bf", "bayesfactor", "bayes_factor") %in% tolower(test)) || "si" %in% tolower(ci_method)) { samps <- .clean_priors_and_posteriors(posterior, bf_prior, verbose = verbose) bf_prior <- samps$prior posterior_samples <- samps$posterior } else { posterior_samples <- insight::get_parameters(posterior) } out <- .describe_posterior( posterior_samples, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, bf_prior = bf_prior, BF = BF, verbose = verbose, ... ) row.names(out) <- NULL # Reset row names class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) attr(out, "ci_method") <- ci_method attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) out } #' @export describe_posterior.emm_list <- describe_posterior.emmGrid # Stan ------------------------------ #' @inheritParams insight::get_parameters #' @inheritParams diagnostic_posterior #' @rdname describe_posterior #' @export describe_posterior.stanreg <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, diagnostic = c("ESS", "Rhat"), priors = FALSE, effects = c("fixed", "random", "all"), component = c( "location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary" ), parameters = NULL, BF = 1, verbose = TRUE, ...) { if ((any(c("all", "bf", "bayesfactor", "bayes_factor") %in% tolower(test)) || "si" %in% tolower(ci_method)) && is.null(bf_prior)) { bf_prior <- suppressMessages(unupdate(posterior)) } effects <- match.arg(effects) component <- match.arg(component) out <- .describe_posterior( posterior, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, bf_prior = bf_prior, BF = BF, effects = effects, component = component, parameters = parameters, verbose = verbose, ... ) diagnostic <- diagnostic_posterior( posterior, diagnostic, effects = effects, component = component, parameters = parameters, ... ) out <- .merge_and_sort(out, diagnostic, by = "Parameter", all = TRUE) if (isTRUE(priors)) { priors_data <- describe_prior(posterior, parameters = out$Parameter, ...) out <- .merge_and_sort(out, priors_data, by = "Parameter", all = TRUE) } out <- .add_clean_parameters_attribute(out, posterior) attr(out, "ci_method") <- ci_method attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) out } #' @inheritParams insight::get_parameters #' @inheritParams diagnostic_posterior #' @export describe_posterior.stanmvreg <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = "p_direction", rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, diagnostic = c("ESS", "Rhat"), priors = FALSE, 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 <- .describe_posterior( posterior, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, bf_prior = bf_prior, effects = effects, parameters = parameters, verbose = verbose, ... ) if (is.null(out$Response)) { out$Response <- gsub("(b\\[)*(.*)\\|(.*)", "\\2", out$Parameter) } diagnostic <- diagnostic_posterior( posterior, diagnostic, effects = effects, parameters = parameters, ... ) out <- .merge_and_sort(out, diagnostic, by = c("Parameter", "Response"), all = TRUE) if (isTRUE(priors)) { priors_data <- describe_prior(posterior, parameters = NULL, ...) priors_data$Parameter <- gsub("^(.*)\\|(.*)", replacement = "\\2", priors_data$Parameter) out <- .merge_and_sort(out, priors_data, by = c("Parameter", "Response"), all = TRUE) } out <- .add_clean_parameters_attribute(out, posterior) attr(out, "ci_method") <- ci_method attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) out } #' @inheritParams insight::get_parameters #' @inheritParams diagnostic_posterior #' @export describe_posterior.stanfit <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, diagnostic = c("ESS", "Rhat"), effects = c("fixed", "random", "all"), parameters = NULL, priors = FALSE, verbose = TRUE, ...) { effects <- match.arg(effects) out <- .describe_posterior( posterior, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, effects = effects, parameters = parameters, verbose = verbose, ... ) diagnostic <- diagnostic_posterior( posterior, diagnostic, effects = effects, parameters = parameters, ... ) out <- .merge_and_sort(out, diagnostic, by = "Parameter", all = TRUE) if (isTRUE(priors)) { priors_data <- describe_prior(posterior, parameters = out$Parameter, ...) out <- .merge_and_sort(out, priors_data, by = "Parameter", all = TRUE) } attr(out, "ci_method") <- ci_method class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) out } #' @inheritParams describe_posterior.stanreg #' @rdname describe_posterior #' @export describe_posterior.brmsfit <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, diagnostic = c("ESS", "Rhat"), effects = c("fixed", "random", "all"), component = c( "conditional", "zi", "zero_inflated", "all", "location", "distributional", "auxiliary" ), parameters = NULL, BF = 1, priors = FALSE, verbose = TRUE, ...) { effects <- match.arg(effects) component <- match.arg(component) if ((any(c("all", "bf", "bayesfactor", "bayes_factor") %in% tolower(test)) || "si" %in% tolower(ci_method)) && is.null(bf_prior)) { bf_prior <- suppressMessages(unupdate(posterior)) } out <- .describe_posterior( posterior, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, bf_prior = bf_prior, BF = BF, effects = effects, component = component, parameters = parameters, verbose = verbose, ... ) if (!is.null(diagnostic)) { diagnostic <- diagnostic_posterior( posterior, diagnostic, effects = effects, component = component, parameters = parameters, ... ) out <- .merge_and_sort(out, diagnostic, by = "Parameter", all = TRUE) } if (isTRUE(priors)) { priors_data <- describe_prior(posterior, parameters = out$Parameter, ...) out <- .merge_and_sort(out, priors_data, by = "Parameter", all = TRUE) } out <- .add_clean_parameters_attribute(out, posterior) attr(out, "ci_method") <- ci_method attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) out } #' @export describe_posterior.blavaan <- describe_posterior.stanfit # other models -------------------------------- #' @inheritParams describe_posterior.stanreg #' @export describe_posterior.MCMCglmm <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, diagnostic = "ESS", parameters = NULL, verbose = TRUE, ...) { out <- .describe_posterior( posterior, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, effects = "fixed", parameters = parameters, verbose = verbose, ... ) if (!is.null(diagnostic) && diagnostic == "ESS") { diagnostic <- effective_sample(posterior, effects = "fixed", parameters = parameters, ...) out <- .merge_and_sort(out, diagnostic, by = "Parameter", all = TRUE) } out } #' @export describe_posterior.bcplm <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, priors = TRUE, parameters = NULL, verbose = TRUE, ...) { out <- .describe_posterior( insight::get_parameters(posterior), centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, effects = "fixed", parameters = parameters, verbose = verbose, ... ) if (isTRUE(priors)) { priors_data <- describe_prior(posterior, parameters = out$Parameter, ...) out <- .merge_and_sort(out, priors_data, by = "Parameter", all = TRUE) } attr(out, "ci_method") <- ci_method attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) out } #' @export describe_posterior.bamlss <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, component = c("all", "conditional", "location"), parameters = NULL, verbose = TRUE, ...) { component <- match.arg(component) out <- .describe_posterior( posterior, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, component = component, parameters = parameters, verbose = verbose, ... ) attr(out, "ci_method") <- ci_method attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) out } # BayesFactor -------------------- #' @export describe_posterior.BFBayesFactor <- function(posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope", "bf"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, priors = TRUE, verbose = TRUE, ...) { # Match test args to catch BFs if (!is.null(test)) { test <- .check_test_values(test) if ("all" %in% test) { test <- c("pd", "p_map", "p_rope", "p_significance", "rope", "equivalence", "bf") } } # Remove BF from list if (any(c("bf", "bayesfactor", "bayes_factor") %in% test)) { test <- test[!test %in% c("bf", "bayesfactor", "bayes_factor")] if (length(test) == 0L) test <- NULL compute_bf <- TRUE } else { compute_bf <- FALSE } draws <- insight::get_parameters(posterior) if (all(rope_range == "default")) { rope_range <- rope_range(posterior, verbose = verbose) } # Describe posterior out <- .describe_posterior( draws, centrality = centrality, dispersion = dispersion, ci = ci, ci_method = ci_method, test = test, rope_range = rope_range, rope_ci = rope_ci, keep_iterations = keep_iterations, verbose = verbose, ... ) if (is.null(out)) { return(NULL) } # Compute and read BF a posteriori if (compute_bf) { tryCatch( { out$log_BF <- as.data.frame(bayesfactor_models(posterior[1], ...))[-1, ]$log_BF out$BF <- exp(out$log_BF) }, error = function(e) { NULL } ) } # Add priors if (priors) { priors_data <- describe_prior(posterior, ...) out <- .merge_and_sort(out, priors_data, by = intersect(names(out), names(priors_data)), all = TRUE) } attr(out, "ci_method") <- ci_method attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) class(out) <- c("describe_posterior", "see_describe_posterior", class(out)) out } # Helpers ----------------------------------------------------------------- #' @keywords internal .check_test_values <- function(test) { match.arg(tolower(test), c( "pd", "p_direction", "pdir", "mpe", "ps", "psig", "p_significance", "p_rope", "rope", "equivalence", "equivalence_test", "equitest", "bf", "bayesfactor", "bayes_factor", "p_map", "all" ), several.ok = TRUE) } bayestestR/R/convert_pd_to_p.R0000644000176200001440000000424214462256711016121 0ustar liggesusers#' Convert between Probability of Direction (pd) and p-value. #' #' Enables a conversion between Probability of Direction (pd) and p-value. #' #' @param pd A Probability of Direction (pd) value (between 0 and 1). #' @param p A p-value. #' @param direction What type of p-value is requested or provided. Can be #' `"two-sided"` (default, two tailed) or `"one-sided"` (one tailed). #' @param verbose Toggle off warnings. #' @param ... Arguments passed to or from other methods. #' #' @details #' Conversion is done using the following equation (see Makowski et al., 2019): #' \cr\cr #' When `direction = "two-sided"` - #' \cr\cr #' \deqn{p = 2 \times (1 - p_d)}{p = 2 * (1 - pd)} #' When `direction = "one-sided"` - #' \cr\cr #' \deqn{p = 1 - p_d}{p = 1 - pd} #' \cr\cr #' Note that this conversion is only valid when the lowest possible values of pd #' is 0.5 - i.e., when the posterior represents continuous parameter space (see #' [p_direction]). If any pd < 0.5 are detected, they are converted to a p of 1, #' and a warning is given. #' #' @references #' Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and 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} #' #' @examples #' pd_to_p(pd = 0.95) #' pd_to_p(pd = 0.95, direction = "one-sided") #' #' @export pd_to_p <- function(pd, direction = "two-sided", verbose = TRUE, ...) { p <- 1 - pd if (.get_direction(direction) == 0) { p <- 2 * p } less_than_0.5 <- pd < 0.5 if (any(less_than_0.5)) { if (verbose) { insight::format_warning(paste( "pd values smaller than 0.5 detected.", "pd-to-p conversion assumes a continious parameter space;", "see help('p_direction') for more info." )) } p[less_than_0.5] <- 1 } p } #' @rdname pd_to_p #' @export p_to_pd <- function(p, direction = "two-sided", ...) { if (.get_direction(direction) == 0) { p <- p / 2 } (1 - p) } #' @rdname pd_to_p #' @export convert_p_to_pd <- p_to_pd #' @rdname pd_to_p #' @export convert_pd_to_p <- pd_to_p bayestestR/vignettes/0000755000176200001440000000000014650200252014403 5ustar liggesusersbayestestR/vignettes/overview_of_vignettes.Rmd0000644000176200001440000000410014276606714021505 0ustar liggesusers--- title: "Overview of Vignettes" output: rmarkdown::html_vignette: vignette: > %\VignetteIndexEntry{Overview of Vignettes} \usepackage[utf8]{inputenc} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r message=FALSE, warning=FALSE, include=FALSE} library(knitr) knitr::opts_chunk$set( echo = TRUE, collapse = TRUE, warning = FALSE, message = FALSE, comment = "#>", eval = TRUE ) ``` All package vignettes are available at [https://easystats.github.io/bayestestR/](https://easystats.github.io/bayestestR/). ## Function Overview * [Function Reference](https://easystats.github.io/bayestestR/reference/index.html) ## Get Started * [Get Started with Bayesian Analysis](https://easystats.github.io/bayestestR/articles/bayestestR.html) ## Examples 1. [Initiation to Bayesian models](https://easystats.github.io/bayestestR/articles/example1.html) 2. [Confirmation of Bayesian skills](https://easystats.github.io/bayestestR/articles/example2.html) 3. [Become a Bayesian master](https://easystats.github.io/bayestestR/articles/example3.html) ## Articles * [Credible Intervals (CI))](https://easystats.github.io/bayestestR/articles/credible_interval.html) * [Region of Practical Equivalence (ROPE)](https://easystats.github.io/bayestestR/articles/region_of_practical_equivalence.html) * [Probability of Direction (pd)](https://easystats.github.io/bayestestR/articles/probability_of_direction.html) * [Bayes Factors](https://easystats.github.io/bayestestR/articles/bayes_factors.html) ## In-Depths * [Comparison of Point-Estimates](https://easystats.github.io/bayestestR/articles/web_only/indicesEstimationComparison.html) * [Indices of Effect Existence and Significance in the Bayesian Framework](https://www.frontiersin.org/articles/10.3389/fpsyg.2019.02767/full) * [Mediation Analysis using Bayesian Regression Models](https://easystats.github.io/bayestestR/articles/mediation.html) ## Guidelines * [Reporting Guidelines](https://easystats.github.io/bayestestR/articles/guidelines.html) bayestestR/data/0000755000176200001440000000000014560756747013335 5ustar liggesusersbayestestR/data/disgust.rdata0000644000176200001440000000062414357655465016035 0ustar liggesusersTN@)Z BKh7nM%< BT~[Ӟ1'8̽wΜ9wA(1 &2yȨBIXS/wYN.|Q' aBƈ w%a 4>Dzu}pn:KG&k{hs+6au {O]h #@C} -|8oM/KYɷдO =r}M{Y |㮝9VWA?IܯFMЬ zv~ !GM= 3.4. ## Changes to functions * All `.stanreg` methods gain a `component` argument, to also include auxiliary parameters. ## Bug fixes * `bayesfactor_parameters()` no longer errors for no reason when computing extremely un/likely direction hypotheses. * `bayesfactor_pointull()` / `bf_pointull()` are now `bayesfactor_pointnull()` / `bf_pointnull()` (can *you* spot the difference? #363 ). # bayestestR 0.8.0 ## New functions * `sexit()`, a function for sequential effect existence and significance testing (SEXIT). ## General * Added startup-message to warn users that default ci-width might change in a future update. * Added support for *mcmc.list* objects. ## Bug fixes * `unupdate()` gains a `newdata` argument to work with `brmsfit_multiple` models. * Fixed issue in Bayes factor vignette (don't evaluate code chunks if packages not available). # bayestestR 0.7.5 ## New functions * Added `as.matrix()` function for `bayesfactor_model` arrays. * `unupdate()`, a utility function to get Bayesian models un-fitted from the data, representing the priors only. ## Changes to functions * `ci()` supports `emmeans` - both Bayesian and frequentist ( #312 - cross fix with `parameters`) ## Bug fixes * Fixed issue with *default* rope range for `BayesFactor` models. * Fixed issue in collinearity-check for `rope()` for models with less than two parameters. * Fixed issue in print-method for `mediation()` with `stanmvreg`-models, which displays the wrong name for the response-value. * Fixed issue in `effective_sample()` for models with only one parameter. * `rope_range()` for `BayesFactor` models returns non-`NA` values ( #343 ) # bayestestR 0.7.2 ## New functions - `mediation()`, to compute average direct and average causal mediation effects of multivariate response models (`brmsfit`, `stanmvreg`). ## Bug fixes - `bayesfactor_parameters()` works with `R<3.6.0`. # bayestestR 0.7.0 ## General - Preliminary support for *stanfit* objects. - Added support for *bayesQR* objects. ## Changes to functions - `weighted_posteriors()` can now be used with data frames. - Revised `print()` for `describe_posterior()`. - Improved value formatting for Bayesfactor functions. ## Bug fixes - Link transformation are now taken into account for `emmeans` objets. E.g., in `describe_posterior()`. - Fix `diagnostic_posterior()` when algorithm is not "sampling". - Minor revisions to some documentations. - Fix CRAN check issues for win-old-release. # bayestestR 0.6.0 ## Changes to functions - `describe_posterior()` now also works on `effectsize::standardize_posteriors()`. - `p_significance()` now also works on `parameters::simulate_model()`. - `rope_range()` supports more (frequentis) models. ## Bug fixes - Fixed issue with `plot()` `data.frame`-methods of `p_direction()` and `equivalence_test()`. - Fix check issues for forthcoming insight-update. # bayestestR 0.5.3 ## General - Support for *bcplm* objects (package **cplm**) ## Changes to functions - `estimate_density()` now also works on grouped data frames. ## Bug fixes - Fixed bug in `weighted_posteriors()` to properly weight Intercept-only `BFBayesFactor` models. - Fixed bug in `weighted_posteriors()` when models have very low posterior probability ( #286 ). - Fixed bug in `describe_posterior()`, `rope()` and `equivalence_test()` for *brmsfit* models with monotonic effect. - Fixed issues related to latest changes in `as.data.frame.brmsfit()` from the *brms* package. # bayestestR 0.5.0 ## General - Added `p_pointnull()` as an alias to `p_MAP()`. - Added `si()` function to compute support intervals. - Added `weighted_posteriors()` for generating posterior samples averaged across models. - Added `plot()`-method for `p_significance()`. - `p_significance()` now also works for *brmsfit*-objects. - `estimate_density()` now also works for *MCMCglmm*-objects. - `equivalence_test()` gets `effects` and `component` arguments for *stanreg* and *brmsfit* models, to print specific model components. - Support for *mcmc* objects (package **coda**) - Provide more distributions via `distribution()`. - Added `distribution_tweedie()`. - Better handling of `stanmvreg` models for `describe_posterior()`, `diagnostic_posterior()` and `describe_prior()`. ## Breaking changes - `point_estimate()`: argument `centrality` default value changed from 'median' to 'all'. - `p_rope()`, previously as exploratory index, was renamed as `mhdior()` (for *Max HDI inside/outside ROPE*), as `p_rope()` will refer to `rope(..., ci = 1)` ( #258 ) ## Bug fixes - Fixed mistake in description of `p_significance()`. - Fixed error when computing BFs with `emmGrid` based on some non-linear models ( #260 ). - Fixed wrong output for percentage-values in `print.equivalence_test()`. - Fixed issue in `describe_posterior()` for `BFBayesFactor`-objects with more than one model. # bayestestR 0.4.0 ## New functions / features - `convert_bayesian_to_frequentist()` Convert (refit) Bayesian model as frequentist - `distribution_binomial()` for perfect binomial distributions - `simulate_ttest()` Simulate data with a mean difference - `simulate_correlation()` Simulate correlated datasets - `p_significance()` Compute the probability of Practical Significance (ps) - `overlap()` Compute overlap between two empirical distributions - `estimate_density()`: `method = "mixture"` argument added for mixture density estimation ## Bug fixes - Fixed bug in `simulate_prior()` for stanreg-models when `autoscale` was set to `FALSE` # bayestestR 0.3.0 ## General - revised `print()`-methods for functions like `rope()`, `p_direction()`, `describe_posterior()` etc., in particular for model objects with random effects and/or zero-inflation component ## New functions / features - `check_prior()` to check if prior is informative - `simulate_prior()` to simulate model's priors as distributions - `distribution_gamma()` to generate a (near-perfect or random) Gamma distribution - `contr.bayes` function for orthogonal factor coding (implementation from Singmann & Gronau's [`bfrms`](https://github.com/bayesstuff/bfrms/), used for proper prior estimation when factor have 3 levels or more. See Bayes factor vignette ## Changes to functions - Added support for `sim`, `sim.merMod` (from `arm::sim()`) and `MCMCglmm`-objects to many functions (like `hdi()`, `ci()`, `eti()`, `rope()`, `p_direction()`, `point_estimate()`, ...) - `describe_posterior()` gets an `effects` and `component` argument, to include the description of posterior samples from random effects and/or zero-inflation component. - More user-friendly warning for non-supported models in `bayesfactor()`-methods ## Bug fixes - Fixed bug in `bayesfactor_inclusion()` where the same interaction sometimes appeared more than once (#223) - Fixed bug in `describe_posterior()` for *stanreg* models fitted with fullrank-algorithm # bayestestR 0.2.5 ## Breaking changes - `rope_range()` for binomial model has now a different default (-.18; .18 ; instead of -.055; .055) - `rope()`: returns a proportion (between 0 and 1) instead of a value between 0 and 100 - `p_direction()`: returns a proportion (between 0.5 and 1) instead of a value between 50 and 100 ([#168](https://github.com/easystats/bayestestR/issues/168)) - `bayesfactor_savagedickey()`: `hypothesis` argument replaced by `null` as part of the new `bayesfactor_parameters()` function ## New functions / features - `density_at()`, `p_map()` and `map_estimate()`: `method` argument added - `rope()`: `ci_method` argument added - `eti()`: Computes equal-tailed intervals - `reshape_ci()`: Reshape CIs between wide/long - `bayesfactor_parameters()`: New function, replacing `bayesfactor_savagedickey()`, allows for computing Bayes factors against a *point-null* or an *interval-null* - `bayesfactor_restricted()`: Function for computing Bayes factors for order restricted models ## Minor changes ## Bug fixes - `bayesfactor_inclusion()` now works with `R < 3.6`. # bayestestR 0.2.2 ## Breaking changes - `equivalence_test()`: returns capitalized output (e.g., `Rejected` instead of `rejected`) - `describe_posterior.numeric()`: `dispersion` defaults to `FALSE` for consistency with the other methods ## New functions / features - `pd_to_p()` and `p_to_pd()`: Functions to convert between probability of direction (pd) and p-value - Support of `emmGrid` objects: `ci()`, `rope()`, `bayesfactor_savagedickey()`, `describe_posterior()`, ... ## Minor changes - Improved tutorial 2 ## Bug fixes - `describe_posterior()`: Fixed column order restoration - `bayesfactor_inclusion()`: Inclusion BFs for matched models are more inline with JASP results. # bayestestR 0.2.0 ## Breaking changes - plotting functions now require the installation of the `see` package - `estimate` argument name in `describe_posterior()` and `point_estimate()` changed to `centrality` - `hdi()`, `ci()`, `rope()` and `equivalence_test()` default `ci` to `0.89` - `rnorm_perfect()` deprecated in favour of `distribution_normal()` - `map_estimate()` now returns a single value instead of a dataframe and the `density` parameter has been removed. The MAP density value is now accessible via `attributes(map_output)$MAP_density` ## New functions / features - `describe_posterior()`, `describe_prior()`, `diagnostic_posterior()`: added wrapper function - `point_estimate()` added function to compute point estimates - `p_direction()`: new argument `method` to compute pd based on AUC - `area_under_curve()`: compute AUC - `distribution()` functions have been added - `bayesfactor_savagedickey()`, `bayesfactor_models()` and `bayesfactor_inclusion()` functions has been added - Started adding plotting methods (currently in the [`see`](https://github.com/easystats/see) package) for `p_direction()` and `hdi()` - `probability_at()` as alias for `density_at()` - `effective_sample()` to return the effective sample size of Stan-models - `mcse()` to return the Monte Carlo standard error of Stan-models ## Minor changes - Improved documentation - Improved testing - `p_direction()`: improved printing - `rope()` for model-objects now returns the HDI values for all parameters as attribute in a consistent way - Changes legend-labels in `plot.equivalence_test()` to align plots with the output of the `print()`-method (#78) ## Bug fixes - `hdi()` returned multiple class attributes (#72) - Printing results from `hdi()` failed when `ci`-argument had fractional parts for percentage values (e.g. `ci = 0.995`). - `plot.equivalence_test()` did not work properly for *brms*-models (#76). # bayestestR 0.1.0 - CRAN initial publication and [0.1.0 release](https://github.com/easystats/bayestestR/releases/tag/v0.1.0) - Added a `NEWS.md` file to track changes to the package bayestestR/inst/0000755000176200001440000000000014650200252013350 5ustar liggesusersbayestestR/inst/CITATION0000644000176200001440000000142214276606712014523 0ustar liggesusersbibentry( bibtype="Article", title="bayestestR: Describing Effects and their Uncertainty, Existence and Significance within the Bayesian Framework.", author=c(person("Dominique", "Makowski"), person("Mattan S.", "Ben-Shachar"), person("Daniel", "Lüdecke")), journal="Journal of Open Source Software", doi="10.21105/joss.01541", year="2019", number = "40", volume = "4", pages = "1541", url="https://joss.theoj.org/papers/10.21105/joss.01541", textVersion = "Makowski, D., Ben-Shachar, M., & Lüdecke, D. (2019). bayestestR: Describing Effects and their Uncertainty, Existence and Significance within the Bayesian Framework. Journal of Open Source Software, 4(40), 1541. doi:10.21105/joss.01541", mheader = "To cite bayestestR in publications use:" ) bayestestR/inst/doc/0000755000176200001440000000000014650200252014115 5ustar liggesusersbayestestR/inst/doc/overview_of_vignettes.Rmd0000644000176200001440000000410014276606714021217 0ustar liggesusers--- title: "Overview of Vignettes" output: rmarkdown::html_vignette: vignette: > %\VignetteIndexEntry{Overview of Vignettes} \usepackage[utf8]{inputenc} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r message=FALSE, warning=FALSE, include=FALSE} library(knitr) knitr::opts_chunk$set( echo = TRUE, collapse = TRUE, warning = FALSE, message = FALSE, comment = "#>", eval = TRUE ) ``` All package vignettes are available at [https://easystats.github.io/bayestestR/](https://easystats.github.io/bayestestR/). ## Function Overview * [Function Reference](https://easystats.github.io/bayestestR/reference/index.html) ## Get Started * [Get Started with Bayesian Analysis](https://easystats.github.io/bayestestR/articles/bayestestR.html) ## Examples 1. [Initiation to Bayesian models](https://easystats.github.io/bayestestR/articles/example1.html) 2. [Confirmation of Bayesian skills](https://easystats.github.io/bayestestR/articles/example2.html) 3. [Become a Bayesian master](https://easystats.github.io/bayestestR/articles/example3.html) ## Articles * [Credible Intervals (CI))](https://easystats.github.io/bayestestR/articles/credible_interval.html) * [Region of Practical Equivalence (ROPE)](https://easystats.github.io/bayestestR/articles/region_of_practical_equivalence.html) * [Probability of Direction (pd)](https://easystats.github.io/bayestestR/articles/probability_of_direction.html) * [Bayes Factors](https://easystats.github.io/bayestestR/articles/bayes_factors.html) ## In-Depths * [Comparison of Point-Estimates](https://easystats.github.io/bayestestR/articles/web_only/indicesEstimationComparison.html) * [Indices of Effect Existence and Significance in the Bayesian Framework](https://www.frontiersin.org/articles/10.3389/fpsyg.2019.02767/full) * [Mediation Analysis using Bayesian Regression Models](https://easystats.github.io/bayestestR/articles/mediation.html) ## Guidelines * [Reporting Guidelines](https://easystats.github.io/bayestestR/articles/guidelines.html) bayestestR/inst/doc/overview_of_vignettes.R0000644000176200001440000000035514650200251020664 0ustar liggesusers## ----message=FALSE, warning=FALSE, include=FALSE------------------------------ library(knitr) knitr::opts_chunk$set( echo = TRUE, collapse = TRUE, warning = FALSE, message = FALSE, comment = "#>", eval = TRUE ) bayestestR/inst/doc/overview_of_vignettes.html0000644000176200001440000001622014650200252021426 0ustar liggesusers Overview of Vignettes

Overview of Vignettes

All package vignettes are available at https://easystats.github.io/bayestestR/.

Function Overview

bayestestR/inst/WORDLIST0000644000176200001440000000351414650200216014545 0ustar liggesusersADE Altough ArXiv BCa BFs BGGM BICs BMA BMJ Baws BayesFactor Bayesfactor Bergh Betancourt Bridgesampling CMD CRC CWI Curvewise DOI DV Dablander DescTools Desimone DiCiccio Dom Driing ESS ETI Efron Etz Fernández Funder Gelman Ghosh Grasman Gronau's HDI HDInterval Haaf Hinne Hirose IRR Imai Iverson JASP JASP's Jeffreys Kass Keele Kruschke Kuriyal Kurz's Ley Liao Liddell Lindley Littman Liu Lodewyckx Ly MCMCglmm MCSE MPE Mathot Mattan Matzke McElreath Midya Modelling Morey Multicollinearity ORCID Ozer Parmigiani Piironen Posteriori Preprint Psychonomic ROPE's ROPEs ROPE’s Raftery Rhat Rouder SEM SEXIT SHA SPI SPIn Shachar Speckman Tada Tingley Un Vandekerckhove Vehtari Versicolor Visualise Wagenmakers Wether Wetzels Wickham Wookies Yamamoto Ying Zheng al altough arXiv autocorrelated avaible bayesQR bayesian bcplm behavioural bmj bmwiernik bootsrapped brms brmsfit centred characterisation characterises ci compte containe cplm curvewise doi driiiing eXistence easystats effectsize egydq emmeans et favour favouring fpsyg frac frequentis frequentist's fullrank generalised ggdist ggdistribute grano higer https infty ing interpretability interpretable iteratively jmp joss lavaan lentiful lifecycle lm maths mattansb mcmc modelling nbinom neq notin objets operationlizing orthonormal osterior patilindrajeets pre preprint priori ps psyarxiv rOpenSci reconceptualisation replicability reproducibility richarddmorey riors rmsb rstanarm sIgnificance salis setosa setosas splinefun ss stanfit stanreg strengejacke summarise summarised th treedepth tweedie un underbrace versicolor versicolors virginica virgnica visualisation visualise warmup wil xy bayestestR/README.md0000644000176200001440000005253614560763455013710 0ustar liggesusers # bayestestR [![DOI](https://joss.theoj.org/papers/10.21105/joss.01541/status.svg)](https://doi.org/10.21105/joss.01541) [![status](https://tinyverse.netlify.com/badge/bayestestR)](https://CRAN.R-project.org/package=bayestestR) [![lifecycle](https://img.shields.io/badge/lifecycle-maturing-blue.svg)](https://lifecycle.r-lib.org/articles/stages.html) ***Become a Bayesian master you will*** ------------------------------------------------------------------------ :warning: We changed the default the CI width! Please make an [informed decision](https://easystats.github.io/bayestestR/articles/credible_interval.html) and set it explicitly (`ci = 0.89`, `ci = 0.95` or anything else that you decide) :warning: ------------------------------------------------------------------------ Existing R packages allow users to easily fit a large variety of models and extract and visualize the posterior draws. However, most of these packages only return a limited set of indices (e.g., point-estimates and CIs). **bayestestR** provides a comprehensive and consistent set of functions to analyze and describe posterior distributions generated by a variety of models objects, including popular modeling packages such as **rstanarm**, **brms** or **BayesFactor**. You can reference the package and its documentation as follows: - Makowski, D., Ben-Shachar, M. S., & Lüdecke, D. (2019). *bayestestR: Describing Effects and their Uncertainty, Existence and Significance within the Bayesian Framework*. Journal of Open Source Software, 4(40), 1541. [10.21105/joss.01541](https://doi.org/10.21105/joss.01541) - Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., & Lüdecke, D. (2019). *Indices of Effect Existence and Significance in the Bayesian Framework*. Frontiers in Psychology 2019;10:2767. [10.3389/fpsyg.2019.02767](https://doi.org/10.3389/fpsyg.2019.02767) ## Installation [![CRAN](http://www.r-pkg.org/badges/version/bayestestR)](https://cran.r-project.org/package=bayestestR) [![insight status badge](https://easystats.r-universe.dev/badges/bayestestR)](https://easystats.r-universe.dev) [![R-CMD-check](https://github.com/easystats/bayestestR/workflows/R-CMD-check/badge.svg?branch=main)](https://github.com/easystats/bayestestR/actions) The *bayestestR* package is available on CRAN, while its latest development version is available on R-universe (from *rOpenSci*). | Type | Source | Command | |-------------|------------|------------------------------------------------------------------------------| | Release | CRAN | `install.packages("bayestestR")` | | Development | R-universe | `install.packages("bayestestR", repos = "https://easystats.r-universe.dev")` | Once you have downloaded the package, you can then load it using: ``` r library("bayestestR") ``` > **Tip** > > **Instead of `library(bayestestR)`, use `library(easystats)`.** **This > will make all features of the easystats-ecosystem available.** > > **To stay updated, use `easystats::install_latest()`.** ## Documentation Access the package [documentation](https://easystats.github.io/bayestestR/) and check-out these vignettes: ### Tutorials - [Get Started with Bayesian Analysis](https://easystats.github.io/bayestestR/articles/bayestestR.html) - [Example 1: Initiation to Bayesian models](https://easystats.github.io/bayestestR/articles/example1.html) - [Example 2: Confirmation of Bayesian skills](https://easystats.github.io/bayestestR/articles/example2.html) - [Example 3: Become a Bayesian master](https://easystats.github.io/bayestestR/articles/example3.html) ### Articles - [Credible Intervals (CI)](https://easystats.github.io/bayestestR/articles/credible_interval.html) - [Probability of Direction (pd)](https://easystats.github.io/bayestestR/articles/probability_of_direction.html) - [Region of Practical Equivalence (ROPE)](https://easystats.github.io/bayestestR/articles/region_of_practical_equivalence.html) - [Bayes Factors (BF)](https://easystats.github.io/bayestestR/articles/bayes_factors.html) - [Comparison of Point-Estimates](https://easystats.github.io/bayestestR/articles/web_only/indicesEstimationComparison.html) - [Comparison of Indices of Effect Existence](https://doi.org/10.3389/fpsyg.2019.02767) - [Reporting Guidelines](https://easystats.github.io/bayestestR/articles/guidelines.html) # Features In the Bayesian framework, parameters are estimated in a probabilistic fashion as *distributions*. These distributions can be summarised and described by reporting four types of indices: - [**Centrality**](https://easystats.github.io/bayestestR/articles/web_only/indicesEstimationComparison.html) - `mean()`, `median()` or [`map_estimate()`](https://easystats.github.io/bayestestR/reference/map_estimate.html) for an estimation of the mode. - [`point_estimate()`](https://easystats.github.io/bayestestR/reference/point_estimate.html) can be used to get them at once and can be run directly on models. - [**Uncertainty**](https://easystats.github.io/bayestestR/articles/credible_interval.html) - [`hdi()`](https://easystats.github.io/bayestestR/reference/hdi.html) for *Highest Density Intervals (HDI)*, [`spi()`](https://easystats.github.io/bayestestR/reference/spi.html) for *Shortest Probability Intervals (SPI)* or [`eti()`](https://easystats.github.io/bayestestR/reference/eti.html) for *Equal-Tailed Intervals (ETI)*. - [`ci()`](https://easystats.github.io/bayestestR/reference/ci.html) can be used as a general method for Confidence and Credible Intervals (CI). - [**Effect Existence**](https://easystats.github.io/bayestestR/articles/indicesExistenceComparison.html): whether an effect is different from 0. - [`p_direction()`](https://easystats.github.io/bayestestR/reference/p_direction.html) for a Bayesian equivalent of the frequentist *p*-value (see [Makowski et al., 2019](https://doi.org/10.3389/fpsyg.2019.02767)) - [`p_pointnull()`](https://easystats.github.io/bayestestR/reference/p_map.html) represents the odds of null hypothesis (*h0 = 0*) compared to the most likely hypothesis (the MAP). - [`bf_pointnull()`](https://easystats.github.io/bayestestR/reference/bayesfactor_parameters.html) for a classic *Bayes Factor (BF)* assessing the likelihood of effect presence against its absence (*h0 = 0*). - [**Effect Significance**](https://easystats.github.io/bayestestR/articles/indicesExistenceComparison.html): whether the effect size can be considered as non-negligible. - [`p_rope()`](https://easystats.github.io/bayestestR/reference/p_rope.html) is the probability of the effect falling inside a [*Region of Practical Equivalence (ROPE)*](https://easystats.github.io/bayestestR/articles/region_of_practical_equivalence.html). - [`bf_rope()`](https://easystats.github.io/bayestestR/reference/bayesfactor_parameters.html) computes a Bayes factor against the null as defined by a region (the ROPE). - [`p_significance()`](https://easystats.github.io/bayestestR/reference/p_significance.html) that combines a region of equivalence with the probability of direction. [`describe_posterior()`](https://easystats.github.io/bayestestR/reference/describe_posterior.html) is the master function with which you can compute all of the indices cited below at once. ``` r describe_posterior( rnorm(10000), centrality = "median", test = c("p_direction", "p_significance"), verbose = FALSE ) ## Summary of Posterior Distribution ## ## Parameter | Median | 95% CI | pd | ps ## -------------------------------------------------- ## Posterior | -0.01 | [-1.98, 1.93] | 50.52% | 0.46 ``` `describe_posterior()` works for many objects, including more complex *brmsfit*-models. For better readability, the output is separated by model components: ``` r zinb <- read.csv("http://stats.idre.ucla.edu/stat/data/fish.csv") set.seed(123) model <- brm( bf( count ~ child + camper + (1 | persons), zi ~ child + camper + (1 | persons) ), data = zinb, family = zero_inflated_poisson(), chains = 1, iter = 500 ) describe_posterior( model, effects = "all", component = "all", test = c("p_direction", "p_significance"), centrality = "all" ) ``` ## Summary of Posterior Distribution ## ## Parameter | Median | Mean | MAP | 95% CI | pd | ps | Rhat | ESS ## -------------------------------------------------------------------------------------- ## (Intercept) | 0.96 | 0.96 | 0.96 | [-0.81, 2.51] | 90.00% | 0.88 | 1.011 | 110.00 ## child | -1.16 | -1.16 | -1.16 | [-1.36, -0.94] | 100% | 1.00 | 0.996 | 278.00 ## camper | 0.73 | 0.72 | 0.73 | [ 0.54, 0.91] | 100% | 1.00 | 0.996 | 271.00 ## ## # Fixed effects (zero-inflated) ## ## Parameter | Median | Mean | MAP | 95% CI | pd | ps | Rhat | ESS ## -------------------------------------------------------------------------------------- ## (Intercept) | -0.48 | -0.51 | -0.22 | [-2.03, 0.89] | 78.00% | 0.73 | 0.997 | 138.00 ## child | 1.85 | 1.86 | 1.81 | [ 1.19, 2.54] | 100% | 1.00 | 0.996 | 303.00 ## camper | -0.88 | -0.86 | -0.99 | [-1.61, -0.07] | 98.40% | 0.96 | 0.996 | 292.00 ## ## # Random effects (conditional) Intercept: persons ## ## Parameter | Median | Mean | MAP | 95% CI | pd | ps | Rhat | ESS ## --------------------------------------------------------------------------------------- ## persons.1 | -0.99 | -1.01 | -0.84 | [-2.68, 0.80] | 92.00% | 0.90 | 1.007 | 106.00 ## persons.2 | -4.65e-03 | -0.04 | 0.03 | [-1.63, 1.66] | 50.00% | 0.45 | 1.013 | 109.00 ## persons.3 | 0.69 | 0.66 | 0.69 | [-0.95, 2.34] | 79.60% | 0.78 | 1.010 | 114.00 ## persons.4 | 1.57 | 1.56 | 1.56 | [-0.05, 3.29] | 96.80% | 0.96 | 1.009 | 114.00 ## ## # Random effects (zero-inflated) Intercept: persons ## ## Parameter | Median | Mean | MAP | 95% CI | pd | ps | Rhat | ESS ## ------------------------------------------------------------------------------------ ## persons.1 | 1.10 | 1.11 | 1.08 | [-0.23, 2.72] | 94.80% | 0.93 | 0.997 | 166.00 ## persons.2 | 0.18 | 0.18 | 0.22 | [-0.94, 1.58] | 63.20% | 0.54 | 0.996 | 154.00 ## persons.3 | -0.30 | -0.31 | -0.54 | [-1.79, 1.02] | 64.00% | 0.59 | 0.997 | 154.00 ## persons.4 | -1.45 | -1.46 | -1.44 | [-2.90, -0.10] | 98.00% | 0.97 | 1.000 | 189.00 ## ## # Random effects (conditional) SD/Cor: persons ## ## Parameter | Median | Mean | MAP | 95% CI | pd | ps | Rhat | ESS ## ---------------------------------------------------------------------------------- ## (Intercept) | 1.42 | 1.58 | 1.07 | [ 0.71, 3.58] | 100% | 1.00 | 1.010 | 126.00 ## ## # Random effects (zero-inflated) SD/Cor: persons ## ## Parameter | Median | Mean | MAP | 95% CI | pd | ps | Rhat | ESS ## ---------------------------------------------------------------------------------- ## (Intercept) | 1.30 | 1.49 | 0.99 | [ 0.63, 3.41] | 100% | 1.00 | 0.996 | 129.00 *bayestestR* also includes [**many other features**](https://easystats.github.io/bayestestR/reference/index.html) useful for your Bayesian analyses. Here are some more examples: ## Point-estimates ``` r library(bayestestR) posterior <- distribution_gamma(10000, 1.5) # Generate a skewed distribution centrality <- point_estimate(posterior) # Get indices of centrality centrality ## Point Estimate ## ## Median | Mean | MAP ## -------------------- ## 1.18 | 1.50 | 0.51 ``` As for other [**easystats**](https://github.com/easystats) packages, `plot()` methods are available from the [**see**](https://easystats.github.io/see/) package for many functions: ![](man/figures/unnamed-chunk-8-1.png) While the **median** and the **mean** are available through base R functions, [`map_estimate()`](https://easystats.github.io/bayestestR/reference/map_estimate.html) in *bayestestR* can be used to directly find the **Highest Maximum A Posteriori (MAP)** estimate 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. ## Uncertainty (CI) [`hdi()`](https://easystats.github.io/bayestestR/reference/hdi.html) computes the **Highest Density Interval (HDI)** of a posterior distribution, i.e., the interval which contains all points within the interval have a higher probability density than points outside the interval. The HDI can be used in the context of Bayesian posterior characterization as **Credible Interval (CI)**. Unlike equal-tailed intervals (see [`eti()`](https://easystats.github.io/bayestestR/reference/eti.html)) that typically exclude 2.5% from each tail of the distribution, the HDI is *not* equal-tailed and therefore always includes the mode(s) of posterior distributions. ``` r posterior <- distribution_chisquared(10000, 4) hdi(posterior, ci = 0.89) ## 89% HDI: [0.18, 7.63] eti(posterior, ci = 0.89) ## 89% ETI: [0.75, 9.25] ``` ![](man/figures/unnamed-chunk-10-1.png) ## Existence and Significance Testing ### Probability of Direction (*pd*) [`p_direction()`](https://easystats.github.io/bayestestR/reference/p_direction.html) computes the *Probability of Direction* (*p*d, also known as the Maximum Probability of Effect - *MPE*). It varies between 50% and 100% (*i.e.*, `0.5` and `1`) and can be interpreted as the probability (expressed in percentage) that a parameter (described by its posterior distribution) is strictly positive or negative (whichever is the most probable). It is mathematically defined as the proportion of the posterior distribution that is of the median’s sign. Although differently expressed, this index is fairly similar (*i.e.*, is strongly correlated) to the frequentist *p*-value. **Relationship with the p-value**: In most cases, it seems that the *pd* corresponds to the frequentist one-sided *p*-value through the formula `p-value = (1-pd/100)` and to the two-sided *p*-value (the most commonly reported) through the formula `p-value = 2*(1-pd/100)`. Thus, a `pd` of `95%`, `97.5%` `99.5%` and `99.95%` corresponds approximately to a two-sided *p*-value of respectively `.1`, `.05`, `.01` and `.001`. See the [*reporting guidelines*](https://easystats.github.io/bayestestR/articles/guidelines.html). ``` r posterior <- distribution_normal(10000, 0.4, 0.2) p_direction(posterior) ## Probability of Direction ## ## Parameter | pd ## ------------------ ## Posterior | 97.72% ``` ![](man/figures/unnamed-chunk-12-1.png) ### ROPE [`rope()`](https://easystats.github.io/bayestestR/reference/rope.html) computes the proportion (in percentage) of the HDI (default to the 89% HDI) of a posterior distribution that lies within a region of practical equivalence. Statistically, the probability of a posterior distribution of being different from 0 does not make much sense (the probability of it being different from a single point being infinite). 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 (2018). Kruschke 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](https://easystats.github.io/bayestestR/reference/rope_range.html) function. Kruschke suggests using the proportion of the 95% (or 90%, considered more stable) HDI that falls within the ROPE as an index for “null-hypothesis” testing (as understood under the Bayesian framework, see [equivalence_test](https://easystats.github.io/bayestestR/reference/equivalence_test.html)). ``` r posterior <- distribution_normal(10000, 0.4, 0.2) rope(posterior, range = c(-0.1, 0.1)) ## # Proportion of samples inside the ROPE [-0.10, 0.10]: ## ## inside ROPE ## ----------- ## 4.40 % ``` ![](man/figures/unnamed-chunk-14-1.png) ### Bayes Factor [`bayesfactor_parameters()`](https://easystats.github.io/bayestestR/reference/bayesfactor_parameters.html) computes Bayes factors against the null (either a point or an interval), bases on prior and posterior samples of a single parameter. This Bayes factor indicates the degree by which the mass of the posterior distribution has shifted further away from or closer to the null value(s) (relative to the prior distribution), thus indicating if the null value has become less or more likely given the observed data. When the null is an interval, the Bayes factor is computed by comparing the prior and posterior odds of the parameter falling within or outside the null; When the null is a point, a Savage-Dickey density ratio is computed, which is also an approximation of a Bayes factor comparing the marginal likelihoods of the model against a model in which the tested parameter has been restricted to the point null (Wagenmakers, Lodewyckx, Kuriyal, & Grasman, 2010). ``` r prior <- distribution_normal(10000, mean = 0, sd = 1) posterior <- distribution_normal(10000, mean = 1, sd = 0.7) bayesfactor_parameters(posterior, prior, direction = "two-sided", null = 0, verbose = FALSE) ## Bayes Factor (Savage-Dickey density ratio) ## ## BF ## ---- ## 1.94 ## ## * Evidence Against The Null: 0 ``` ![](man/figures/unnamed-chunk-16-1.png) *The lollipops represent the density of a point-null on the prior distribution (the blue lollipop on the dotted distribution) and on the posterior distribution (the red lollipop on the yellow distribution). The ratio between the two - the Savage-Dickey ratio - indicates the degree by which the mass of the parameter distribution has shifted away from or closer to the null.* For more info, see [the Bayes factors vignette](https://easystats.github.io/bayestestR/articles/bayes_factors.html). ## Utilities ### Find ROPE’s appropriate range [`rope_range()`](https://easystats.github.io/bayestestR/reference/rope_range.html): This function attempts at automatically finding suitable “default” values for the Region Of Practical Equivalence (ROPE). Kruschke (2018) suggests that such null value 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), which can be generalised for linear models to `-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 `sqrt(3)/pi`, resulting in a range of `-0.05` to `0.05`. ``` r rope_range(model) ``` ### Density Estimation [`estimate_density()`](https://easystats.github.io/bayestestR/reference/estimate_density.html): This function is a wrapper over different methods of density estimation. By default, it uses the base R `density` with by default uses a different smoothing bandwidth (`"SJ"`) from the legacy default implemented the base R `density` function (`"nrd0"`). However, Deng & Wickham suggest that `method = "KernSmooth"` is the fastest and the most accurate. ### Perfect Distributions [`distribution()`](https://easystats.github.io/bayestestR/reference/distribution.html): Generate a sample of size n with near-perfect distributions. ``` r distribution(n = 10) ## [1] -1.55 -1.00 -0.66 -0.38 -0.12 0.12 0.38 0.66 1.00 1.55 ``` ### Probability of a Value [`density_at()`](https://easystats.github.io/bayestestR/reference/density_at.html): Compute the density of a given point of a distribution. ``` r density_at(rnorm(1000, 1, 1), 1) ## [1] 0.41 ``` ## Code of Conduct Please note that the bayestestR project is released with a [Contributor Code of Conduct](https://contributor-covenant.org/version/2/1/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. # 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.
Kruschke, J. K., & Liddell, T. M. (2018). The bayesian new statistics: Hypothesis testing, estimation, meta-analysis, and power analysis from a bayesian perspective. *Psychonomic Bulletin & Review*, *25*(1), 178–206.
Wagenmakers, E.-J., Lodewyckx, T., Kuriyal, H., & Grasman, R. (2010). Bayesian hypothesis testing for psychologists: A tutorial on the savage–dickey method. *Cognitive Psychology*, *60*(3), 158–189.
bayestestR/build/0000755000176200001440000000000014650200252013472 5ustar liggesusersbayestestR/build/vignette.rds0000644000176200001440000000033114650200252016026 0ustar liggesusersb```b`afb`b2 1# '/K-*L-O/LK-)I- MAS(USH i%9h*q t0XD90!icKŰ% 5/$~hZ8S+`zP԰Aհe ,s\ܠL t7`~΢r=xA$Gs=ʕXVr7nBbayestestR/build/partial.rdb0000644000176200001440000000007514650200241015617 0ustar liggesusersb```b`afb`b1 H020piּb C"%!7bayestestR/man/0000755000176200001440000000000014650172354013161 5ustar liggesusersbayestestR/man/distribution.Rd0000644000176200001440000000707514561246722016202 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distribution.R \name{distribution} \alias{distribution} \alias{distribution_custom} \alias{distribution_beta} \alias{distribution_binomial} \alias{distribution_binom} \alias{distribution_cauchy} \alias{distribution_chisquared} \alias{distribution_chisq} \alias{distribution_gamma} \alias{distribution_mixture_normal} \alias{distribution_normal} \alias{distribution_gaussian} \alias{distribution_nbinom} \alias{distribution_poisson} \alias{distribution_student} \alias{distribution_t} \alias{distribution_student_t} \alias{distribution_tweedie} \alias{distribution_uniform} \alias{rnorm_perfect} \title{Empirical Distributions} \usage{ distribution(type = "normal", ...) distribution_custom(n, type = "norm", ..., random = FALSE) distribution_beta(n, shape1, shape2, ncp = 0, random = FALSE, ...) distribution_binomial(n, size = 1, prob = 0.5, random = FALSE, ...) distribution_binom(n, size = 1, prob = 0.5, random = FALSE, ...) distribution_cauchy(n, location = 0, scale = 1, random = FALSE, ...) distribution_chisquared(n, df, ncp = 0, random = FALSE, ...) distribution_chisq(n, df, ncp = 0, random = FALSE, ...) distribution_gamma(n, shape, scale = 1, random = FALSE, ...) distribution_mixture_normal(n, mean = c(-3, 3), sd = 1, random = FALSE, ...) distribution_normal(n, mean = 0, sd = 1, random = FALSE, ...) distribution_gaussian(n, mean = 0, sd = 1, random = FALSE, ...) distribution_nbinom(n, size, prob, mu, phi, random = FALSE, ...) distribution_poisson(n, lambda = 1, random = FALSE, ...) distribution_student(n, df, ncp, random = FALSE, ...) distribution_t(n, df, ncp, random = FALSE, ...) distribution_student_t(n, df, ncp, random = FALSE, ...) distribution_tweedie(n, xi = NULL, mu, phi, power = NULL, random = FALSE, ...) distribution_uniform(n, min = 0, max = 1, random = FALSE, ...) rnorm_perfect(n, mean = 0, sd = 1) } \arguments{ \item{type}{Can be any of the names from base R's \link[stats:Distributions]{Distributions}, like \code{"cauchy"}, \code{"pois"} or \code{"beta"}.} \item{...}{Arguments passed to or from other methods.} \item{n}{the number of observations} \item{random}{Generate near-perfect or random (simple wrappers for the base R \verb{r*} functions) distributions.} \item{shape1, shape2}{non-negative parameters of the Beta distribution.} \item{ncp}{non-centrality parameter.} \item{size}{number of trials (zero or more).} \item{prob}{probability of success on each trial.} \item{location, scale}{location and scale parameters.} \item{df}{degrees of freedom (non-negative, but can be non-integer).} \item{shape}{Shape parameter.} \item{mean}{vector of means.} \item{sd}{vector of standard deviations.} \item{mu}{the mean} \item{phi}{Corresponding to \code{glmmTMB}'s implementation of nbinom distribution, where \code{size=mu/phi}.} \item{lambda}{vector of (non-negative) means.} \item{xi}{For tweedie distributions, the value of \code{xi} such that the variance is \code{var(Y) = phi * mu^xi}.} \item{power}{Alias for \code{xi}.} \item{min, max}{lower and upper limits of the distribution. Must be finite.} } \description{ Generate a sequence of n-quantiles, i.e., a sample of size \code{n} with a near-perfect distribution. } \details{ When \code{random = FALSE}, these function return \verb{q*(ppoints(n), ...)}. } \examples{ library(bayestestR) x <- distribution(n = 10) plot(density(x)) x <- distribution(type = "gamma", n = 100, shape = 2) plot(density(x)) } bayestestR/man/mcse.Rd0000644000176200001440000000411614560763455014411 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mcse.R \name{mcse} \alias{mcse} \alias{mcse.stanreg} \title{Monte-Carlo Standard Error (MCSE)} \usage{ mcse(model, ...) \method{mcse}{stanreg}( model, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, ... ) } \arguments{ \item{model}{A \code{stanreg}, \code{stanfit}, \code{brmsfit}, \code{blavaan}, or \code{MCMCglmm} object.} \item{...}{Currently not used.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \description{ This function returns the Monte Carlo Standard Error (MCSE). } \details{ \strong{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 \code{mcse()} is from Kruschke 2015, p. 187). The MCSE \dQuote{provides a quantitative suggestion of how big the estimation noise is}. } \examples{ \dontshow{if (require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ library(bayestestR) model <- suppressWarnings( rstanarm::stan_glm(mpg ~ wt + am, data = mtcars, chains = 1, refresh = 0) ) mcse(model) } \dontshow{\}) # examplesIf} } \references{ Kruschke, J. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press. } bayestestR/man/equivalence_test.Rd0000644000176200001440000001766314650172354017025 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/equivalence_test.R \name{equivalence_test} \alias{equivalence_test} \alias{equivalence_test.default} \alias{equivalence_test.data.frame} \alias{equivalence_test.stanreg} \alias{equivalence_test.brmsfit} \title{Test for Practical Equivalence} \usage{ equivalence_test(x, ...) \method{equivalence_test}{default}(x, ...) \method{equivalence_test}{data.frame}(x, range = "default", ci = 0.95, verbose = TRUE, ...) \method{equivalence_test}{stanreg}( 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, ... ) \method{equivalence_test}{brmsfit}( x, range = "default", ci = 0.95, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution. Can also be a \code{stanreg} or \code{brmsfit} model.} \item{...}{Currently not used.} \item{range}{ROPE's lower and higher bounds. Should be \code{"default"} or depending on the number of outcome variables a vector or a list. In models with one response, \code{range} should be a vector of length two (e.g., \code{c(-0.1, 0.1)}). In multivariate models, \code{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 \code{"default"} and input is a vector, the range is set to \code{c(-0.1, 0.1)}. If \code{"default"} and input is a Bayesian model, \code{\link[=rope_range]{rope_range()}} is used.} \item{ci}{The Credible Interval (CI) probability, corresponding to the proportion of HDI, to use for the percentage in ROPE.} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \value{ A data frame with following columns: \itemize{ \item \code{Parameter} The model parameter(s), if \code{x} is a model-object. If \code{x} is a vector, this column is missing. \item \code{CI} The probability of the HDI. \item \code{ROPE_low}, \code{ROPE_high} The limits of the ROPE. These values are identical for all parameters. \item \code{ROPE_Percentage} The proportion of the HDI that lies inside the ROPE. \item \code{ROPE_Equivalence} The "test result", as character. Either "rejected", "accepted" or "undecided". \item \code{HDI_low} , \code{HDI_high} The lower and upper HDI limits for the parameters. } } \description{ Perform a \strong{Test for Practical Equivalence} for Bayesian and frequentist models. } \details{ Documentation is accessible for: \itemize{ \item \href{https://easystats.github.io/bayestestR/reference/equivalence_test.html}{Bayesian models} \item \href{https://easystats.github.io/parameters/reference/equivalence_test.lm.html}{Frequentist models} } For Bayesian models, the \strong{Test for Practical Equivalence} is based on the \emph{"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 \verb{89\%} \link[=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. Using the \link[=rope]{ROPE} and the \link[=hdi]{HDI}, \cite{Kruschke (2018)} suggests using the percentage of the \verb{95\%} (or \verb{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., \verb{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 \verb{2.5\%} or greater than \verb{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 \code{range}). See 'Details' in \code{\link[=rope_range]{rope_range()}} for further information. \cr \cr \strong{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 \code{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}). } \note{ There is a \code{print()}-method with a \code{digits}-argument to control the amount of digits in the output, and there is a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} to visualize the results from the equivalence-test (for models only). } \examples{ \dontshow{if (require("rstanarm") && require("brms") && require("emmeans") && require("BayesFactor")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} 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) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item 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} \item Kruschke, J. K. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press \item 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} } } bayestestR/man/bayesfactor_parameters.Rd0000644000176200001440000003111114650172354020172 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bayesfactor_parameters.R \name{bayesfactor_parameters} \alias{bayesfactor_parameters} \alias{bayesfactor_pointnull} \alias{bayesfactor_rope} \alias{bf_parameters} \alias{bf_pointnull} \alias{bf_rope} \alias{bayesfactor_parameters.numeric} \alias{bayesfactor_parameters.stanreg} \alias{bayesfactor_parameters.brmsfit} \alias{bayesfactor_parameters.blavaan} \alias{bayesfactor_parameters.data.frame} \title{Bayes Factors (BF) for a Single Parameter} \usage{ bayesfactor_parameters( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ... ) bayesfactor_pointnull( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ... ) bayesfactor_rope( posterior, prior = NULL, direction = "two-sided", null = rope_range(posterior, verbose = FALSE), verbose = TRUE, ... ) bf_parameters( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ... ) bf_pointnull( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ... ) bf_rope( posterior, prior = NULL, direction = "two-sided", null = rope_range(posterior, verbose = FALSE), verbose = TRUE, ... ) \method{bayesfactor_parameters}{numeric}( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ... ) \method{bayesfactor_parameters}{stanreg}( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("conditional", "location", "smooth_terms", "sigma", "zi", "zero_inflated", "all"), parameters = NULL, ... ) \method{bayesfactor_parameters}{brmsfit}( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("conditional", "location", "smooth_terms", "sigma", "zi", "zero_inflated", "all"), parameters = NULL, ... ) \method{bayesfactor_parameters}{blavaan}( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ... ) \method{bayesfactor_parameters}{data.frame}( posterior, prior = NULL, direction = "two-sided", null = 0, verbose = TRUE, ... ) } \arguments{ \item{posterior}{A numerical vector, \code{stanreg} / \code{brmsfit} object, \code{emmGrid} or a data frame - representing a posterior distribution(s) from (see 'Details').} \item{prior}{An object representing a prior distribution (see 'Details').} \item{direction}{Test type (see 'Details'). One of \code{0}, \code{"two-sided"} (default, two tailed), \code{-1}, \code{"left"} (left tailed) or \code{1}, \code{"right"} (right tailed).} \item{null}{Value of the null, either a scalar (for point-null) or a range (for a interval-null).} \item{verbose}{Toggle off warnings.} \item{...}{Arguments passed to and from other methods. (Can be used to pass arguments to internal \code{\link[logspline:logspline]{logspline::logspline()}}.)} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \value{ A data frame containing the (log) Bayes factor representing evidence \emph{against} the null (Use \code{as.numeric()} to extract the non-log Bayes factors; see examples). } \description{ This method computes Bayes factors against the null (either a point or an interval), based on prior and posterior samples of a single parameter. This Bayes factor indicates the degree by which the mass of the posterior distribution has shifted further away from or closer to the null value(s) (relative to the prior distribution), thus indicating if the null value has become less or more likely given the observed data. \cr \cr When the null is an interval, the Bayes factor is computed by comparing the prior and posterior odds of the parameter falling within or outside the null interval (Morey & Rouder, 2011; Liao et al., 2020); When the null is a point, a Savage-Dickey density ratio is computed, which is also an approximation of a Bayes factor comparing the marginal likelihoods of the model against a model in which the tested parameter has been restricted to the point null (Wagenmakers et al., 2010; Heck, 2019). \cr \cr Note that the \code{logspline} package is used for estimating densities and probabilities, and must be installed for the function to work. \cr \cr \code{bayesfactor_pointnull()} and \code{bayesfactor_rope()} are wrappers around \code{bayesfactor_parameters} with different defaults for the null to be tested against (a point and a range, respectively). Aliases of the main functions are prefixed with \verb{bf_*}, like \code{bf_parameters()} or \code{bf_pointnull()}. \cr \cr \strong{For more info, in particular on specifying correct priors for factors with more than 2 levels, see \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}.} } \details{ This method is used to compute Bayes factors based on prior and posterior distributions. \subsection{One-sided & Dividing Tests (setting an order restriction)}{ One sided tests (controlled by \code{direction}) are conducted by restricting the prior and posterior of the non-null values (the "alternative") to one side of the null only (\cite{Morey & Wagenmakers, 2014}). For example, if we have a prior hypothesis that the parameter should be positive, the alternative will be restricted to the region to the right of the null (point or interval). For example, for a Bayes factor comparing the "null" of \code{0-0.1} to the alternative \verb{>0.1}, we would set \code{bayesfactor_parameters(null = c(0, 0.1), direction = ">")}. \cr\cr It is also possible to compute a Bayes factor for \strong{dividing} hypotheses - that is, for a null and alternative that are complementary, opposing one-sided hypotheses (\cite{Morey & Wagenmakers, 2014}). For example, for a Bayes factor comparing the "null" of \verb{<0} to the alternative \verb{>0}, we would set \code{bayesfactor_parameters(null = c(-Inf, 0))}. } } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \section{Setting the correct \code{prior}}{ For the computation of Bayes factors, the model priors must be proper priors (at the very least they should be \emph{not flat}, and it is preferable that they be \emph{informative}); As the priors for the alternative get wider, the likelihood of the null value(s) increases, to the extreme that for completely flat priors the null is infinitely more favorable than the alternative (this is called \emph{the Jeffreys-Lindley-Bartlett paradox}). Thus, you should only ever try (or want) to compute a Bayes factor when you have an informed prior. \cr\cr (Note that by default, \code{brms::brm()} uses flat priors for fixed-effects; See example below.) \cr\cr It is important to provide the correct \code{prior} for meaningful results. \itemize{ \item When \code{posterior} is a numerical vector, \code{prior} should also be a numerical vector. \item When \code{posterior} is a \code{data.frame}, \code{prior} should also be a \code{data.frame}, with matching column order. \item When \code{posterior} is a \code{stanreg}, \code{brmsfit} or other supported Bayesian model: \itemize{ \item \code{prior} can be set to \code{NULL}, in which case prior samples are drawn internally. \item \code{prior} can also be a model equivalent to \code{posterior} but with samples from the priors \emph{only}. See \code{\link[=unupdate]{unupdate()}}. \item \strong{Note:} When \code{posterior} is a \code{brmsfit_multiple} model, \code{prior} \strong{must} be provided. } \item When \code{posterior} is an \code{emmGrid} / \code{emm_list} object: \itemize{ \item \code{prior} should also be an \code{emmGrid} / \code{emm_list} object equivalent to \code{posterior} but created with a model of priors samples \emph{only}. See \code{\link[=unupdate]{unupdate()}}. \item \code{prior} can also be the original (posterior) \emph{model}. If so, the function will try to update the \code{emmGrid} / \code{emm_list} to use the \code{\link[=unupdate]{unupdate()}}d prior-model. (\emph{This cannot be done for \code{brmsfit} models.}) \item \strong{Note}: When the \code{emmGrid} has undergone any transformations (\code{"log"}, \code{"response"}, etc.), or \code{regrid}ing, then \code{prior} must be an \code{emmGrid} object, as stated above. } } } \section{Interpreting Bayes Factors}{ A Bayes factor greater than 1 can be interpreted as evidence against the null, at which one convention is that a Bayes factor greater than 3 can be considered as "substantial" evidence against the null (and vice versa, a Bayes factor smaller than 1/3 indicates substantial evidence in favor of the null-model) (\cite{Wetzels et al. 2011}). } \examples{ \dontshow{if (require("logspline")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(bayestestR) prior <- distribution_normal(1000, mean = 0, sd = 1) posterior <- distribution_normal(1000, mean = .5, sd = .3) (BF_pars <- bayesfactor_parameters(posterior, prior, verbose = FALSE)) as.numeric(BF_pars) \dontshow{\}) # examplesIf} \dontshow{if (require("rstanarm") && require("emmeans") && require("logspline")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ # rstanarm models # --------------- contrasts(sleep$group) <- contr.equalprior_pairs # see vingette stan_model <- suppressWarnings(stan_lmer( extra ~ group + (1 | ID), data = sleep, refresh = 0 )) bayesfactor_parameters(stan_model, verbose = FALSE) bayesfactor_parameters(stan_model, null = rope_range(stan_model)) # emmGrid objects # --------------- group_diff <- pairs(emmeans(stan_model, ~group, data = sleep)) bayesfactor_parameters(group_diff, prior = stan_model, verbose = FALSE) # Or # group_diff_prior <- pairs(emmeans(unupdate(stan_model), ~group)) # bayesfactor_parameters(group_diff, prior = group_diff_prior, verbose = FALSE) } \dontshow{\}) # examplesIf} \dontshow{if (require("brms") && require("logspline")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # brms models # ----------- \dontrun{ 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 )) bayesfactor_parameters(brms_model, verbose = FALSE) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item Wagenmakers, E. J., Lodewyckx, T., Kuriyal, H., and Grasman, R. (2010). Bayesian hypothesis testing for psychologists: A tutorial on the Savage-Dickey method. Cognitive psychology, 60(3), 158-189. \item Heck, D. W. (2019). A caveat on the Savage–Dickey density ratio: The case of computing Bayes factors for regression parameters. British Journal of Mathematical and Statistical Psychology, 72(2), 316-333. \item Morey, R. D., & Wagenmakers, E. J. (2014). Simple relation between Bayesian order-restricted and point-null hypothesis tests. Statistics & Probability Letters, 92, 121-124. \item Morey, R. D., & Rouder, J. N. (2011). Bayes factor approaches for testing interval null hypotheses. Psychological methods, 16(4), 406. \item Liao, J. G., Midya, V., & Berg, A. (2020). Connecting and contrasting the Bayes factor and a modified ROPE procedure for testing interval null hypotheses. The American Statistician, 1-19. \item 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} } } \author{ Mattan S. Ben-Shachar } bayestestR/man/sexit.Rd0000644000176200001440000001766314650172354014621 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sexit.R \name{sexit} \alias{sexit} \title{Sequential Effect eXistence and sIgnificance Testing (SEXIT)} \usage{ sexit(x, significant = "default", large = "default", ci = 0.95, ...) } \arguments{ \item{x}{A vector representing a posterior distribution, a data frame of posterior draws (samples be parameter). Can also be a Bayesian model.} \item{significant, large}{The threshold values to use for significant and large probabilities. If left to 'default', will be selected through \code{\link[=sexit_thresholds]{sexit_thresholds()}}. See the details section below.} \item{ci}{Value or vector of probability of the (credible) interval - CI (between 0 and 1) to be estimated. Default to \code{.95} (\verb{95\%}).} \item{...}{Currently not used.} } \value{ A dataframe and text as attribute. } \description{ The SEXIT is a new framework to describe Bayesian effects, guiding which indices to use. Accordingly, the \code{sexit()} function returns the minimal (and optimal) required information to describe models' parameters under a Bayesian framework. It includes the following indices: \itemize{ \item Centrality: the median of the posterior distribution. In probabilistic terms, there is \verb{50\%} of probability that the effect is higher and lower. See \code{\link[=point_estimate]{point_estimate()}}. \item Uncertainty: the \verb{95\%} Highest Density Interval (HDI). In probabilistic terms, there is \verb{95\%} of probability that the effect is within this confidence interval. See \code{\link[=ci]{ci()}}. \item Existence: The probability of direction allows to quantify the certainty by which an effect is positive or negative. It is a critical index to show that an effect of some manipulation is not harmful (for instance in clinical studies) or to assess the direction of a link. See \code{\link[=p_direction]{p_direction()}}. \item Significance: Once existence is demonstrated with high certainty, we can assess whether the effect is of sufficient size to be considered as significant (i.e., not negligible). This is a useful index to determine which effects are actually important and worthy of discussion in a given process. See \code{\link[=p_significance]{p_significance()}}. \item Size: Finally, this index gives an idea about the strength of an effect. However, beware, as studies have shown that a big effect size can be also suggestive of low statistical power (see details section). } } \details{ \subsection{Rationale}{ The assessment of "significance" (in its broadest meaning) is a pervasive issue in science, and its historical index, the p-value, has been strongly criticized and deemed to have played an important role in the replicability crisis. In reaction, more and more scientists have tuned to Bayesian methods, offering an alternative set of tools to answer their questions. However, the Bayesian framework offers a wide variety of possible indices related to "significance", and the debate has been raging about which index is the best, and which one to report. This situation can lead to the mindless reporting of all possible indices (with the hopes that with that the reader will be satisfied), but often without having the writer understanding and interpreting them. It is indeed complicated to juggle between many indices with complicated definitions and subtle differences. SEXIT aims at offering a practical framework for Bayesian effects reporting, in which the focus is put on intuitiveness, explicitness and usefulness of the indices' interpretation. To that end, we suggest a system of description of parameters that would be intuitive, easy to learn and apply, mathematically accurate and useful for taking decision. Once the thresholds for significance (i.e., the ROPE) and the one for a "large" effect are explicitly defined, the SEXIT framework does not make any interpretation, i.e., it does not label the effects, but just sequentially gives 3 probabilities (of direction, of significance and of being large, respectively) as-is on top of the characteristics of the posterior (using the median and HDI for centrality and uncertainty description). Thus, it provides a lot of information about the posterior distribution (through the mass of different 'sections' of the posterior) in a clear and meaningful way. } \subsection{Threshold selection}{ One of the most important thing about the SEXIT framework is that it relies on two "arbitrary" thresholds (i.e., that have no absolute meaning). They are the ones related to effect size (an inherently subjective notion), namely the thresholds for significant and large effects. They are set, by default, to \code{0.05} and \code{0.3} of the standard deviation of the outcome variable (tiny and large effect sizes for correlations according to Funder and Ozer, 2019). However, these defaults were chosen by lack of a better option, and might not be adapted to your case. Thus, they are to be handled with care, and the chosen thresholds should always be explicitly reported and justified. \itemize{ \item For \strong{linear models (lm)}, this can be generalised to \ifelse{html}{\out{0.05 * SDy}}{\eqn{[0.05*SD_{y}]}} and \ifelse{html}{\out{0.3 * SDy}}{\eqn{[0.3*SD_{y}]}} for significant and large effects, respectively. \item For \strong{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 a threshold of \code{0.09} and \code{0.54}. \item For other models with \strong{binary outcome}, it is strongly recommended to manually specify the rope argument. Currently, the same default is applied that for logistic models. \item For models from \strong{count data}, the residual variance is used. This is a rather experimental threshold and is probably often similar to \code{0.05} and \code{0.3}, but should be used with care! \item For \strong{t-tests}, the standard deviation of the response is used, similarly to linear models (see above). \item For \strong{correlations},\code{0.05} and \code{0.3} are used. \item For all other models, \code{0.05} and \code{0.3} are used, but it is strongly advised to specify it manually. } } \subsection{Examples}{ The three values for existence, significance and size provide a useful description of the posterior distribution of the effects. Some possible scenarios include: \itemize{ \item The probability of existence is low, but the probability of being large is high: it suggests that the posterior is very wide (covering large territories on both side of 0). The statistical power might be too low, which should warrant any confident conclusion. \item The probability of existence and significance is high, but the probability of being large is very small: it suggests that the effect is, with high confidence, not large (the posterior is mostly contained between the significance and the large thresholds). \item The 3 indices are very low: this suggests that the effect is null with high confidence (the posterior is closely centred around 0). } } } \examples{ \donttest{ library(bayestestR) s <- sexit(rnorm(1000, -1, 1)) s print(s, summary = TRUE) s <- sexit(iris) s print(s, summary = TRUE) if (require("rstanarm")) { model <- suppressWarnings(rstanarm::stan_glm(mpg ~ wt * cyl, data = mtcars, iter = 400, refresh = 0 )) s <- sexit(model) s print(s, summary = TRUE) } } } \references{ \itemize{ \item Makowski, D., Ben-Shachar, M. S., & Lüdecke, D. (2019). bayestestR: Describing Effects and their Uncertainty, Existence and Significance within the Bayesian Framework. Journal of Open Source Software, 4(40), 1541. \doi{10.21105/joss.01541} \item 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} } } bayestestR/man/p_to_bf.Rd0000644000176200001440000000463614560763455015101 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/p_to_bf.R \name{p_to_bf} \alias{p_to_bf} \alias{p_to_bf.numeric} \alias{p_to_bf.default} \title{Convert p-values to (pseudo) Bayes Factors} \usage{ p_to_bf(x, ...) \method{p_to_bf}{numeric}(x, log = FALSE, n_obs = NULL, ...) \method{p_to_bf}{default}(x, log = FALSE, ...) } \arguments{ \item{x}{A (frequentist) model object, or a (numeric) vector of p-values.} \item{...}{Other arguments to be passed (not used for now).} \item{log}{Wether to return log Bayes Factors. \strong{Note:} The \code{print()} method always shows \code{BF} - the \code{"log_BF"} column is only accessible from the returned data frame.} \item{n_obs}{Number of observations. Either length 1, or same length as \code{p}.} } \value{ A data frame with the p-values and pseudo-Bayes factors (against the null). } \description{ Convert p-values to (pseudo) Bayes Factors. This transformation has been suggested by Wagenmakers (2022), but is based on a vast amount of assumptions. It might therefore be not reliable. Use at your own risks. For more accurate approximate Bayes factors, use \code{\link[=bic_to_bf]{bic_to_bf()}} instead. } \examples{ \dontshow{if (require("parameters")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} data(iris) model <- lm(Petal.Length ~ Sepal.Length + Species, data = iris) p_to_bf(model) # Examples that demonstrate comparison between # BIC-approximated and pseudo BF # -------------------------------------------- m0 <- lm(mpg ~ 1, mtcars) m1 <- lm(mpg ~ am, mtcars) m2 <- lm(mpg ~ factor(cyl), mtcars) # In this first example, BIC-approximated BF and # pseudo-BF based on p-values are close... # BIC-approximated BF, m1 against null model bic_to_bf(BIC(m1), denominator = BIC(m0)) # pseudo-BF based on p-values - dropping intercept p_to_bf(m1)[-1, ] # The second example shows that results from pseudo-BF are less accurate # and should be handled wit caution! bic_to_bf(BIC(m2), denominator = BIC(m0)) p_to_bf(anova(m2), n_obs = nrow(mtcars)) \dontshow{\}) # examplesIf} } \references{ \itemize{ \item Wagenmakers, E.J. (2022). Approximate objective Bayes factors from p-values and sample size: The 3p(sqrt(n)) rule. Preprint available on ArXiv: https://psyarxiv.com/egydq } } \seealso{ \code{\link[=bic_to_bf]{bic_to_bf()}} for more accurate approximate Bayes factors. } bayestestR/man/effective_sample.Rd0000644000176200001440000000533614650172354016760 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/effective_sample.R \name{effective_sample} \alias{effective_sample} \alias{effective_sample.brmsfit} \alias{effective_sample.stanreg} \title{Effective Sample Size (ESS)} \usage{ effective_sample(model, ...) \method{effective_sample}{brmsfit}( model, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, ... ) \method{effective_sample}{stanreg}( model, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, ... ) } \arguments{ \item{model}{A \code{stanreg}, \code{stanfit}, \code{brmsfit}, \code{blavaan}, or \code{MCMCglmm} object.} \item{...}{Currently not used.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \value{ A data frame with two columns: Parameter name and effective sample size (ESS). } \description{ This function returns the effective sample size (ESS). } \details{ \strong{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} (\emph{Kruschke 2015, p182-3}). } \examples{ \dontshow{if (require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ library(rstanarm) model <- suppressWarnings( stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) ) effective_sample(model) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item Kruschke, J. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press. \item Bürkner, P. C. (2017). brms: An R package for Bayesian multilevel models using Stan. Journal of Statistical Software, 80(1), 1-28 } } bayestestR/man/overlap.Rd0000644000176200001440000000250414461433341015115 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/overlap.R \name{overlap} \alias{overlap} \title{Overlap Coefficient} \usage{ overlap( x, y, method_density = "kernel", method_auc = "trapezoid", precision = 2^10, extend = TRUE, extend_scale = 0.1, ... ) } \arguments{ \item{x}{Vector of x values.} \item{y}{Vector of x values.} \item{method_density}{Density estimation method. See \code{\link[=estimate_density]{estimate_density()}}.} \item{method_auc}{Area Under the Curve (AUC) estimation method. See \code{\link[=area_under_curve]{area_under_curve()}}.} \item{precision}{Number of points of density data. See the \code{n} parameter in \code{density}.} \item{extend}{Extend the range of the x axis by a factor of \code{extend_scale}.} \item{extend_scale}{Ratio of range by which to extend the x axis. A value of \code{0.1} means that the x axis will be extended by \code{1/10} of the range of the data.} \item{...}{Currently not used.} } \description{ A method to calculate the overlap coefficient between two empirical distributions (that can be used as a measure of similarity between two samples). } \examples{ library(bayestestR) x <- distribution_normal(1000, 2, 0.5) y <- distribution_normal(1000, 0, 1) overlap(x, y) plot(overlap(x, y)) } bayestestR/man/p_significance.Rd0000644000176200001440000001103714560763455016423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/p_significance.R \name{p_significance} \alias{p_significance} \alias{p_significance.numeric} \alias{p_significance.get_predicted} \alias{p_significance.stanreg} \alias{p_significance.brmsfit} \title{Practical Significance (ps)} \usage{ p_significance(x, ...) \method{p_significance}{numeric}(x, threshold = "default", ...) \method{p_significance}{get_predicted}( x, threshold = "default", use_iterations = FALSE, verbose = TRUE, ... ) \method{p_significance}{stanreg}( x, threshold = "default", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = TRUE, ... ) \method{p_significance}{brmsfit}( x, threshold = "default", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution. Can also be a \code{stanreg} or \code{brmsfit} model.} \item{...}{Currently not used.} \item{threshold}{The threshold value that separates significant from negligible effect. If \code{"default"}, the range is set to \code{0.1} if input is a vector, and based on \code{\link[=rope_range]{rope_range()}} if a Bayesian model is provided.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \value{ Values between 0 and 1 corresponding to the probability of practical significance (ps). } \description{ Compute the probability of \strong{Practical Significance} (\emph{\strong{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. } \details{ \code{p_significance()} returns the proportion of a probability distribution (\code{x}) that is outside a certain range (the negligible effect, or ROPE, see argument \code{threshold}). If there are values of the distribution both below and above the ROPE, \code{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 \code{x}, \code{p_significance()} will be less than 0.5, which indicates no clear practical significance. } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \examples{ \dontshow{if (require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} 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) } \dontshow{\}) # examplesIf} } bayestestR/man/bayesfactor_restricted.Rd0000644000176200001440000002176514650172354020215 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bayesfactor_restricted.R \name{bayesfactor_restricted} \alias{bayesfactor_restricted} \alias{bf_restricted} \alias{bayesfactor_restricted.stanreg} \alias{bayesfactor_restricted.brmsfit} \alias{bayesfactor_restricted.blavaan} \alias{bayesfactor_restricted.emmGrid} \alias{as.logical.bayesfactor_restricted} \title{Bayes Factors (BF) for Order Restricted Models} \usage{ bayesfactor_restricted( posterior, hypothesis, prior = NULL, verbose = TRUE, ... ) bf_restricted(posterior, hypothesis, prior = NULL, verbose = TRUE, ...) \method{bayesfactor_restricted}{stanreg}( posterior, hypothesis, prior = NULL, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), ... ) \method{bayesfactor_restricted}{brmsfit}( posterior, hypothesis, prior = NULL, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), ... ) \method{bayesfactor_restricted}{blavaan}( posterior, hypothesis, prior = NULL, verbose = TRUE, ... ) \method{bayesfactor_restricted}{emmGrid}( posterior, hypothesis, prior = NULL, verbose = TRUE, ... ) \method{as.logical}{bayesfactor_restricted}(x, which = c("posterior", "prior"), ...) } \arguments{ \item{posterior}{A \code{stanreg} / \code{brmsfit} object, \code{emmGrid} or a data frame - representing a posterior distribution(s) from (see Details).} \item{hypothesis}{A character vector specifying the restrictions as logical conditions (see examples below).} \item{prior}{An object representing a prior distribution (see Details).} \item{verbose}{Toggle off warnings.} \item{...}{Currently not used.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{x}{An object of class \code{bayesfactor_restricted}} \item{which}{Should the logical matrix be of the posterior or prior distribution(s)?} } \value{ A data frame containing the (log) Bayes factor representing evidence \emph{against} the un-restricted model (Use \code{as.numeric()} to extract the non-log Bayes factors; see examples). (A \code{bool_results} attribute contains the results for each sample, indicating if they are included or not in the hypothesized restriction.) } \description{ This method computes Bayes factors for comparing a model with an order restrictions on its parameters with the fully unrestricted model. \emph{Note that this method should only be used for confirmatory analyses}. \cr \cr The \verb{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 \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}.} } \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 \code{bayesfactor_restricted()} to test interval restrictions, it is more suitable for testing order restrictions; see examples). } \section{Setting the correct \code{prior}}{ For the computation of Bayes factors, the model priors must be proper priors (at the very least they should be \emph{not flat}, and it is preferable that they be \emph{informative}); As the priors for the alternative get wider, the likelihood of the null value(s) increases, to the extreme that for completely flat priors the null is infinitely more favorable than the alternative (this is called \emph{the Jeffreys-Lindley-Bartlett paradox}). Thus, you should only ever try (or want) to compute a Bayes factor when you have an informed prior. \cr\cr (Note that by default, \code{brms::brm()} uses flat priors for fixed-effects; See example below.) \cr\cr It is important to provide the correct \code{prior} for meaningful results. \itemize{ \item When \code{posterior} is a numerical vector, \code{prior} should also be a numerical vector. \item When \code{posterior} is a \code{data.frame}, \code{prior} should also be a \code{data.frame}, with matching column order. \item When \code{posterior} is a \code{stanreg}, \code{brmsfit} or other supported Bayesian model: \itemize{ \item \code{prior} can be set to \code{NULL}, in which case prior samples are drawn internally. \item \code{prior} can also be a model equivalent to \code{posterior} but with samples from the priors \emph{only}. See \code{\link[=unupdate]{unupdate()}}. \item \strong{Note:} When \code{posterior} is a \code{brmsfit_multiple} model, \code{prior} \strong{must} be provided. } \item When \code{posterior} is an \code{emmGrid} / \code{emm_list} object: \itemize{ \item \code{prior} should also be an \code{emmGrid} / \code{emm_list} object equivalent to \code{posterior} but created with a model of priors samples \emph{only}. See \code{\link[=unupdate]{unupdate()}}. \item \code{prior} can also be the original (posterior) \emph{model}. If so, the function will try to update the \code{emmGrid} / \code{emm_list} to use the \code{\link[=unupdate]{unupdate()}}d prior-model. (\emph{This cannot be done for \code{brmsfit} models.}) \item \strong{Note}: When the \code{emmGrid} has undergone any transformations (\code{"log"}, \code{"response"}, etc.), or \code{regrid}ing, then \code{prior} must be an \code{emmGrid} object, as stated above. } } } \section{Interpreting Bayes Factors}{ A Bayes factor greater than 1 can be interpreted as evidence against the null, at which one convention is that a Bayes factor greater than 3 can be considered as "substantial" evidence against the null (and vice versa, a Bayes factor smaller than 1/3 indicates substantial evidence in favor of the null-model) (\cite{Wetzels et al. 2011}). } \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) \dontshow{if (require("see") && require("patchwork")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} 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" ) \dontshow{\}) # examplesIf} \dontshow{if (require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \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) } \dontshow{\}) # examplesIf} \dontshow{if (require("rstanarm") && require("emmeans")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \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. } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item Morey, R. D., & Wagenmakers, E. J. (2014). Simple relation between Bayesian order-restricted and point-null hypothesis tests. Statistics & Probability Letters, 92, 121-124. \item Morey, R. D., & Rouder, J. N. (2011). Bayes factor approaches for testing interval null hypotheses. Psychological methods, 16(4), 406. \item Morey, R. D. (Jan, 2015). Multiple Comparisons with BayesFactor, Part 2 – order restrictions. Retrieved from https://richarddmorey.org/category/order-restrictions/. } } bayestestR/man/point_estimate.Rd0000644000176200001440000001300614560763455016504 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/point_estimate.R \name{point_estimate} \alias{point_estimate} \alias{point_estimate.numeric} \alias{point_estimate.stanreg} \alias{point_estimate.brmsfit} \alias{point_estimate.BFBayesFactor} \alias{point_estimate.get_predicted} \title{Point-estimates of posterior distributions} \usage{ point_estimate(x, ...) \method{point_estimate}{numeric}(x, centrality = "all", dispersion = FALSE, threshold = 0.1, ...) \method{point_estimate}{stanreg}( x, centrality = "all", dispersion = FALSE, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, ... ) \method{point_estimate}{brmsfit}( x, centrality = "all", dispersion = FALSE, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, ... ) \method{point_estimate}{BFBayesFactor}(x, centrality = "all", dispersion = FALSE, ...) \method{point_estimate}{get_predicted}( x, centrality = "all", dispersion = FALSE, use_iterations = FALSE, verbose = TRUE, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Additional arguments to be passed to or from methods.} \item{centrality}{The point-estimates (centrality indices) to compute. Character (vector) or list with one or more of these options: \code{"median"}, \code{"mean"}, \code{"MAP"} (see \code{\link[=map_estimate]{map_estimate()}}), \code{"trimmed"} (which is just \code{mean(x, trim = threshold)}), \code{"mode"} or \code{"all"}.} \item{dispersion}{Logical, if \code{TRUE}, computes indices of dispersion related to the estimate(s) (\code{SD} and \code{MAD} for \code{mean} and \code{median}, respectively). Dispersion is not available for \code{"MAP"} or \code{"mode"} centrality indices.} \item{threshold}{For \code{centrality = "trimmed"} (i.e. trimmed mean), indicates the fraction (0 to 0.5) of observations to be trimmed from each end of the vector before the mean is computed.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} \item{verbose}{Toggle off warnings.} } \description{ Compute various point-estimates, such as the mean, the median or the MAP, to describe posterior distributions. } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \examples{ \dontshow{if (require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(bayestestR) point_estimate(rnorm(1000)) point_estimate(rnorm(1000), centrality = "all", dispersion = TRUE) point_estimate(rnorm(1000), centrality = c("median", "MAP")) df <- data.frame(replicate(4, rnorm(100))) point_estimate(df, centrality = "all", dispersion = TRUE) point_estimate(df, centrality = c("median", "MAP")) \donttest{ # rstanarm models # ----------------------------------------------- model <- rstanarm::stan_glm(mpg ~ wt + cyl, data = mtcars) point_estimate(model, centrality = "all", dispersion = TRUE) point_estimate(model, centrality = c("median", "MAP")) # emmeans estimates # ----------------------------------------------- point_estimate( emmeans::emtrends(model, ~1, "wt", data = mtcars), centrality = c("median", "MAP") ) # brms models # ----------------------------------------------- model <- brms::brm(mpg ~ wt + cyl, data = mtcars) point_estimate(model, centrality = "all", dispersion = TRUE) point_estimate(model, centrality = c("median", "MAP")) # BayesFactor objects # ----------------------------------------------- bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) point_estimate(bf, centrality = "all", dispersion = TRUE) point_estimate(bf, centrality = c("median", "MAP")) } \dontshow{\}) # examplesIf} } \references{ Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and Lüdecke, D. (2019). \emph{Indices of Effect Existence and Significance in the Bayesian Framework}. Frontiers in Psychology 2019;10:2767. \doi{10.3389/fpsyg.2019.02767} } bayestestR/man/disgust.Rd0000644000176200001440000000173014357655465015150 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/datasets.R \docType{data} \name{disgust} \alias{disgust} \title{Moral Disgust Judgment} \format{ A data frame with 500 rows and 5 variables: \describe{ \item{score}{Score on the questionnaire, which ranges from 0 to 50 with higher scores representing harsher moral judgment} \item{condition}{one of three conditions, differing by the odor present in the room: a pleasant scent associated with cleanliness (lemon), a disgusting scent (sulfur), and a control condition in which no unusual odor is present} } \if{html}{\out{
}}\preformatted{data("disgust") head(disgust, n = 5) #> score condition #> 1 13 control #> 2 26 control #> 3 30 control #> 4 23 control #> 5 34 control }\if{html}{\out{
}} } \description{ A sample (simulated) dataset, used in tests and some examples. } \author{ Richard D. Morey } \keyword{data} bayestestR/man/bic_to_bf.Rd0000644000176200001440000000232114461433341015350 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bic_to_bf.R \name{bic_to_bf} \alias{bic_to_bf} \title{Convert BIC indices to Bayes Factors via the BIC-approximation method.} \usage{ bic_to_bf(bic, denominator, log = FALSE) } \arguments{ \item{bic}{A vector of BIC values.} \item{denominator}{The BIC value to use as a denominator (to test against).} \item{log}{If \code{TRUE}, return the \code{log(BF)}.} } \value{ The Bayes Factors corresponding to the BIC values against the denominator. } \description{ 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)} } \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) } \references{ Wagenmakers, E. J. (2007). A practical solution to the pervasive problems of p values. Psychonomic bulletin & review, 14(5), 779-804 } bayestestR/man/rope_range.Rd0000644000176200001440000000575114560763455015611 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rope_range.R \name{rope_range} \alias{rope_range} \alias{rope_range.default} \title{Find Default Equivalence (ROPE) Region Bounds} \usage{ rope_range(x, ...) \method{rope_range}{default}(x, verbose = TRUE, ...) } \arguments{ \item{x}{A \code{stanreg}, \code{brmsfit} or \code{BFBayesFactor} object.} \item{...}{Currently not used.} \item{verbose}{Toggle warnings.} } \description{ This function attempts at automatically finding suitable "default" values for the Region Of Practical Equivalence (ROPE). } \details{ \emph{Kruschke (2018)} suggests that the region of practical equivalence could be set, by default, to a range from \code{-0.1} to \code{0.1} of a standardized parameter (negligible effect size according to \emph{Cohen, 1988}). \itemize{ \item For \strong{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}]}}. \item For \strong{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 \code{-0.18} to \code{0.18}. \item For other models with \strong{binary outcome}, it is strongly recommended to manually specify the rope argument. Currently, the same default is applied that for logistic models. \item For models from \strong{count data}, the residual variance is used. This is a rather experimental threshold and is probably often similar to \verb{-0.1, 0.1}, but should be used with care! \item For \strong{t-tests}, the standard deviation of the response is used, similarly to linear models (see above). \item For \strong{correlations}, \verb{-0.05, 0.05} is used, i.e., half the value of a negligible correlation as suggested by Cohen's (1988) rules of thumb. \item For all other models, \verb{-0.1, 0.1} is used to determine the ROPE limits, but it is strongly advised to specify it manually. } } \examples{ \dontshow{if (require("rstanarm") && require("brms") && require("BayesFactor")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \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) } \dontshow{\}) # examplesIf} } \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}. } bayestestR/man/p_rope.Rd0000644000176200001440000000512014560763455014742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/p_rope.R \name{p_rope} \alias{p_rope} \alias{p_rope.numeric} \alias{p_rope.stanreg} \alias{p_rope.brmsfit} \title{Probability of being in the ROPE} \usage{ p_rope(x, ...) \method{p_rope}{numeric}(x, range = "default", verbose = TRUE, ...) \method{p_rope}{stanreg}( x, range = "default", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = verbose, ... ) \method{p_rope}{brmsfit}( x, range = "default", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = verbose, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution. Can also be a \code{stanreg} or \code{brmsfit} model.} \item{...}{Currently not used.} \item{range}{ROPE's lower and higher bounds. Should be \code{"default"} or depending on the number of outcome variables a vector or a list. In models with one response, \code{range} should be a vector of length two (e.g., \code{c(-0.1, 0.1)}). In multivariate models, \code{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 \code{"default"} and input is a vector, the range is set to \code{c(-0.1, 0.1)}. If \code{"default"} and input is a Bayesian model, \code{\link[=rope_range]{rope_range()}} is used.} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \description{ Compute the proportion of the whole posterior distribution that doesn't lie within a region of practical equivalence (ROPE). It is equivalent to running \code{rope(..., ci = 1)}. } \examples{ library(bayestestR) p_rope(x = rnorm(1000, 0, 0.01), range = c(-0.1, 0.1)) p_rope(x = mtcars, range = c(-0.1, 0.1)) } bayestestR/man/dot-extract_priors_rstanarm.Rd0000644000176200001440000000057014276606713021222 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sensitivity_to_prior.R \name{.extract_priors_rstanarm} \alias{.extract_priors_rstanarm} \title{Extract and Returns the priors formatted for rstanarm} \usage{ .extract_priors_rstanarm(model, ...) } \description{ Extract and Returns the priors formatted for rstanarm } \keyword{internal} bayestestR/man/simulate_correlation.Rd0000644000176200001440000000464214650172354017702 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/simulate_data.R \name{simulate_correlation} \alias{simulate_correlation} \alias{simulate_ttest} \alias{simulate_difference} \title{Data Simulation} \usage{ simulate_correlation(n = 100, r = 0.5, mean = 0, sd = 1, names = NULL, ...) simulate_ttest(n = 100, d = 0.5, names = NULL, ...) simulate_difference(n = 100, d = 0.5, names = NULL, ...) } \arguments{ \item{n}{The number of observations to be generated.} \item{r}{A value or vector corresponding to the desired correlation coefficients.} \item{mean}{A value or vector corresponding to the mean of the variables.} \item{sd}{A value or vector corresponding to the SD of the variables.} \item{names}{A character vector of desired variable names.} \item{...}{Arguments passed to or from other methods.} \item{d}{A value or vector corresponding to the desired difference between the groups.} } \description{ Simulate data with specific characteristics. } \examples{ \dontshow{if (requireNamespace("MASS", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # Correlation -------------------------------- data <- simulate_correlation(r = 0.5) plot(data$V1, data$V2) cor.test(data$V1, data$V2) summary(lm(V2 ~ V1, data = data)) # Specify mean and SD data <- simulate_correlation(r = 0.5, n = 50, mean = c(0, 1), sd = c(0.7, 1.7)) cor.test(data$V1, data$V2) round(c(mean(data$V1), sd(data$V1)), 1) round(c(mean(data$V2), sd(data$V2)), 1) summary(lm(V2 ~ V1, data = data)) # Generate multiple variables 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, names = c("y", "x1", "x2")) cor(data) summary(lm(y ~ x1, data = data)) # t-test -------------------------------- data <- simulate_ttest(n = 30, d = 0.3) plot(data$V1, data$V0) round(c(mean(data$V1), sd(data$V1)), 1) diff(t.test(data$V1 ~ data$V0)$estimate) summary(lm(V1 ~ V0, data = data)) summary(glm(V0 ~ V1, data = data, family = "binomial")) # Difference -------------------------------- data <- simulate_difference(n = 30, d = 0.3) plot(data$V1, data$V0) round(c(mean(data$V1), sd(data$V1)), 1) diff(t.test(data$V1 ~ data$V0)$estimate) summary(lm(V1 ~ V0, data = data)) summary(glm(V0 ~ V1, data = data, family = "binomial")) \dontshow{\}) # examplesIf} } bayestestR/man/spi.Rd0000644000176200001440000001115314560763455014254 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/spi.R \name{spi} \alias{spi} \alias{spi.numeric} \alias{spi.stanreg} \alias{spi.brmsfit} \alias{spi.get_predicted} \title{Shortest Probability Interval (SPI)} \usage{ spi(x, ...) \method{spi}{numeric}(x, ci = 0.95, verbose = TRUE, ...) \method{spi}{stanreg}( x, ci = 0.95, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = TRUE, ... ) \method{spi}{brmsfit}( x, ci = 0.95, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, ... ) \method{spi}{get_predicted}(x, ci = 0.95, use_iterations = FALSE, verbose = TRUE, ...) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Currently not used.} \item{ci}{Value or vector of probability of the (credible) interval - CI (between 0 and 1) to be estimated. Default to \code{.95} (\verb{95\%}).} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} } \value{ A data frame with following columns: \itemize{ \item \code{Parameter} The model parameter(s), if \code{x} is a model-object. If \code{x} is a vector, this column is missing. \item \code{CI} The probability of the credible interval. \item \code{CI_low}, \code{CI_high} The lower and upper credible interval limits for the parameters. } } \description{ Compute the \strong{Shortest Probability Interval (SPI)} of posterior distributions. The SPI is a more computationally stable HDI. The implementation is based on the algorithm from the \strong{SPIn} package. } \details{ The SPI is an alternative method to the HDI (\code{\link[=hdi]{hdi()}}) to quantify uncertainty of (posterior) distributions. The SPI is said to be more stable than the HDI, because, the \emph{"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. } \note{ The code to compute the SPI was adapted from the \strong{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. } \examples{ \dontshow{if (require("quadprog") && require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} 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) } \dontshow{\}) # examplesIf} } \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 } \seealso{ Other ci: \code{\link{bci}()}, \code{\link{ci}()}, \code{\link{cwi}()}, \code{\link{eti}()}, \code{\link{hdi}()}, \code{\link{si}()} } \concept{ci} bayestestR/man/bayesfactor_inclusion.Rd0000644000176200001440000000774714506247453020057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bayesfactor_inclusion.R \name{bayesfactor_inclusion} \alias{bayesfactor_inclusion} \alias{bf_inclusion} \title{Inclusion Bayes Factors for testing predictors across Bayesian models} \usage{ bayesfactor_inclusion(models, match_models = FALSE, prior_odds = NULL, ...) bf_inclusion(models, match_models = FALSE, prior_odds = NULL, ...) } \arguments{ \item{models}{An object of class \code{\link[=bayesfactor_models]{bayesfactor_models()}} or \code{BFBayesFactor}.} \item{match_models}{See details.} \item{prior_odds}{Optional vector of prior odds for the models. See \verb{BayesFactor::priorOdds<-}.} \item{...}{Arguments passed to or from other methods.} } \value{ a data frame containing the prior and posterior probabilities, and log(BF) for each effect (Use \code{as.numeric()} to extract the non-log Bayes factors; see examples). } \description{ The \verb{bf_*} function is an alias of the main function. \cr \cr For more info, see \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}. } \details{ Inclusion Bayes factors answer the question: Are the observed data more probable under models with a particular effect, than they are under models without that particular effect? In other words, on average - are models with effect \eqn{X} more likely to have produced the observed data than models without effect \eqn{X}? \subsection{Match Models}{ If \code{match_models=FALSE} (default), Inclusion BFs are computed by comparing all models with a term against all models without that term. If \code{TRUE}, comparison is restricted to models that (1) do not include any interactions with the term of interest; (2) for interaction terms, averaging is done only across models that containe the main effect terms from which the interaction term is comprised. } } \note{ Random effects in the \code{lmer} style are converted to interaction terms: i.e., \code{(X|G)} will become the terms \code{1:G} and \code{X:G}. } \section{Interpreting Bayes Factors}{ A Bayes factor greater than 1 can be interpreted as evidence against the null, at which one convention is that a Bayes factor greater than 3 can be considered as "substantial" evidence against the null (and vice versa, a Bayes factor smaller than 1/3 indicates substantial evidence in favor of the null-model) (\cite{Wetzels et al. 2011}). } \examples{ \dontshow{if (require("BayesFactor")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(bayestestR) # Using bayesfactor_models: # ------------------------------ mo0 <- lm(Sepal.Length ~ 1, data = iris) mo1 <- lm(Sepal.Length ~ Species, data = iris) mo2 <- lm(Sepal.Length ~ Species + Petal.Length, data = iris) mo3 <- lm(Sepal.Length ~ Species * Petal.Length, data = iris) BFmodels <- bayesfactor_models(mo1, mo2, mo3, denominator = mo0) (bf_inc <- bayesfactor_inclusion(BFmodels)) as.numeric(bf_inc) \donttest{ # BayesFactor # ------------------------------- BF <- BayesFactor::generalTestBF(len ~ supp * dose, ToothGrowth, progress = FALSE) bayesfactor_inclusion(BF) # compare only matched models: bayesfactor_inclusion(BF, match_models = TRUE) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item 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} \item Clyde, M. A., Ghosh, J., & Littman, M. L. (2011). Bayesian adaptive sampling for variable selection and model averaging. Journal of Computational and Graphical Statistics, 20(1), 80-101. \item Mathot, S. (2017). Bayes like a Baws: Interpreting Bayesian Repeated Measures in JASP. \href{https://www.cogsci.nl/blog/interpreting-bayesian-repeated-measures-in-jasp}{Blog post}. } } \seealso{ \code{\link[=weighted_posteriors]{weighted_posteriors()}} for Bayesian parameter averaging. } \author{ Mattan S. Ben-Shachar } bayestestR/man/p_map.Rd0000644000176200001440000001272314560763455014561 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/p_map.R \name{p_map} \alias{p_map} \alias{p_pointnull} \alias{p_map.numeric} \alias{p_map.get_predicted} \alias{p_map.stanreg} \alias{p_map.brmsfit} \title{Bayesian p-value based on the density at the Maximum A Posteriori (MAP)} \usage{ p_map(x, ...) p_pointnull(x, ...) \method{p_map}{numeric}(x, null = 0, precision = 2^10, method = "kernel", ...) \method{p_map}{get_predicted}( x, null = 0, precision = 2^10, method = "kernel", use_iterations = FALSE, verbose = TRUE, ... ) \method{p_map}{stanreg}( 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, ... ) \method{p_map}{brmsfit}( x, null = 0, precision = 2^10, method = "kernel", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Currently not used.} \item{null}{The value considered as a "null" effect. Traditionally 0, but could also be 1 in the case of ratios of change (OR, IRR, ...).} \item{precision}{Number of points of density data. See the \code{n} parameter in \code{density}.} \item{method}{Density estimation method. Can be \code{"kernel"} (default), \code{"logspline"} or \code{"KernSmooth"}.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \description{ Compute a Bayesian equivalent of the \emph{p}-value, related to the odds that a parameter (described by its posterior distribution) has against the null hypothesis (\emph{h0}) using Mills' (2014, 2017) \emph{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 \code{method} (see the section in the examples below). \subsection{Strengths and Limitations}{ \strong{Strengths:} Straightforward computation. Objective property of the posterior distribution. \strong{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. } } \examples{ \dontshow{if (require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} 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")]) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item 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} \item Mills, J. A. (2018). Objective Bayesian Precise Hypothesis Testing. University of Cincinnati. } } \seealso{ \href{https://www.youtube.com/watch?v=Ip8Ci5KUVRc}{Jeff Mill's talk} } bayestestR/man/as.numeric.p_direction.Rd0000644000176200001440000000125114276606712020015 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/map_estimate.R, R/p_direction.R, R/p_map.R, % R/p_significance.R \name{as.numeric.map_estimate} \alias{as.numeric.map_estimate} \alias{as.numeric.p_direction} \alias{as.numeric.p_map} \alias{as.numeric.p_significance} \title{Convert to Numeric} \usage{ \method{as.numeric}{map_estimate}(x, ...) \method{as.numeric}{p_direction}(x, ...) \method{as.numeric}{p_map}(x, ...) \method{as.numeric}{p_significance}(x, ...) } \arguments{ \item{x}{object to be coerced or tested.} \item{...}{further arguments passed to or from other methods.} } \description{ Convert to Numeric } bayestestR/man/bayesfactor.Rd0000644000176200001440000000660214560763455015766 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bayesfactor.R \name{bayesfactor} \alias{bayesfactor} \title{Bayes Factors (BF)} \usage{ bayesfactor( ..., prior = NULL, direction = "two-sided", null = 0, hypothesis = NULL, effects = c("fixed", "random", "all"), verbose = TRUE, denominator = 1, match_models = FALSE, prior_odds = NULL ) } \arguments{ \item{...}{A numeric vector, model object(s), or the output from \code{bayesfactor_models}.} \item{prior}{An object representing a prior distribution (see 'Details').} \item{direction}{Test type (see 'Details'). One of \code{0}, \code{"two-sided"} (default, two tailed), \code{-1}, \code{"left"} (left tailed) or \code{1}, \code{"right"} (right tailed).} \item{null}{Value of the null, either a scalar (for point-null) or a range (for a interval-null).} \item{hypothesis}{A character vector specifying the restrictions as logical conditions (see examples below).} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{verbose}{Toggle off warnings.} \item{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 \code{BFBayesFactor}.} \item{match_models}{See details.} \item{prior_odds}{Optional vector of prior odds for the models. See \verb{BayesFactor::priorOdds<-}.} } \value{ Some type of Bayes factor, depending on the input. See \code{\link[=bayesfactor_parameters]{bayesfactor_parameters()}}, \code{\link[=bayesfactor_models]{bayesfactor_models()}} or \code{\link[=bayesfactor_inclusion]{bayesfactor_inclusion()}} } \description{ This function compte the Bayes factors (BFs) that are appropriate to the input. For vectors or single models, it will compute \code{\link[=bayesfactor_parameters]{BFs for single parameters()}}, or is \code{hypothesis} is specified, \code{\link[=bayesfactor_restricted]{BFs for restricted models()}}. For multiple models, it will return the BF corresponding to \code{\link[=bayesfactor_models]{comparison between models()}} and if a model comparison is passed, it will compute the \code{\link[=bayesfactor_inclusion]{inclusion BF()}}. \cr\cr For a complete overview of these functions, read the \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{Bayes factor vignette}. } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \examples{ \dontshow{if (require("rstanarm") && require("logspline")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(bayestestR) prior <- distribution_normal(1000, mean = 0, sd = 1) posterior <- distribution_normal(1000, mean = .5, sd = .3) bayesfactor(posterior, prior = prior, verbose = FALSE) \donttest{ # rstanarm models # --------------- model <- suppressWarnings(rstanarm::stan_lmer(extra ~ group + (1 | ID), data = sleep)) bayesfactor(model, verbose = FALSE) # Frequentist models # --------------- m0 <- lm(extra ~ 1, data = sleep) m1 <- lm(extra ~ group, data = sleep) m2 <- lm(extra ~ group + ID, data = sleep) comparison <- bayesfactor(m0, m1, m2) comparison bayesfactor(comparison) } \dontshow{\}) # examplesIf} } bayestestR/man/diagnostic_posterior.Rd0000644000176200001440000001020514560763455017710 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/diagnostic_posterior.R \name{diagnostic_posterior} \alias{diagnostic_posterior} \alias{diagnostic_posterior.default} \alias{diagnostic_posterior.stanreg} \alias{diagnostic_posterior.brmsfit} \title{Posteriors Sampling Diagnostic} \usage{ diagnostic_posterior(posterior, ...) \method{diagnostic_posterior}{default}(posterior, diagnostic = c("ESS", "Rhat"), ...) \method{diagnostic_posterior}{stanreg}( posterior, diagnostic = "all", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, ... ) \method{diagnostic_posterior}{brmsfit}( posterior, diagnostic = "all", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, ... ) } \arguments{ \item{posterior}{A \code{stanreg}, \code{stanfit}, \code{brmsfit}, or \code{blavaan} object.} \item{...}{Currently not used.} \item{diagnostic}{Diagnostic metrics to compute. Character (vector) or list with one or more of these options: \code{"ESS"}, \code{"Rhat"}, \code{"MCSE"} or \code{"all"}.} \item{effects}{Should parameters for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should all predictor variables, predictor variables for the conditional model, the zero-inflated part of the model, the dispersion term or the instrumental variables be returned? Applies to models with zero-inflated and/or dispersion formula, or to models with instrumental variable (so called fixed-effects regressions). May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned.} } \description{ Extract diagnostic metrics (Effective Sample Size (\code{ESS}), \code{Rhat} and Monte Carlo Standard Error \code{MCSE}). } \details{ \strong{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 (\emph{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" (\emph{Kruschke 2015, p182-3}). \strong{Rhat} should be the closest to 1. It should not be larger than 1.1 (\emph{Gelman and Rubin, 1992}) or 1.01 (\emph{Vehtari et al., 2019}). The split Rhat statistic quantifies the consistency of an ensemble of Markov chains. \strong{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 \code{mcse()} is from Kruschke 2015, p. 187). The MCSE "provides a quantitative suggestion of how big the estimation noise is". } \examples{ \dontshow{if (require("rstanarm") && require("brms")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \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) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item Gelman, A., & Rubin, D. B. (1992). Inference from iterative simulation using multiple sequences. Statistical science, 7(4), 457-472. \item 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. \item Kruschke, J. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press. } } bayestestR/man/map_estimate.Rd0000644000176200001440000001041614560763455016132 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/map_estimate.R \name{map_estimate} \alias{map_estimate} \alias{map_estimate.numeric} \alias{map_estimate.stanreg} \alias{map_estimate.brmsfit} \alias{map_estimate.data.frame} \alias{map_estimate.get_predicted} \title{Maximum A Posteriori probability estimate (MAP)} \usage{ map_estimate(x, ...) \method{map_estimate}{numeric}(x, precision = 2^10, method = "kernel", ...) \method{map_estimate}{stanreg}( x, precision = 2^10, method = "kernel", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, ... ) \method{map_estimate}{brmsfit}( x, precision = 2^10, method = "kernel", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, ... ) \method{map_estimate}{data.frame}(x, precision = 2^10, method = "kernel", ...) \method{map_estimate}{get_predicted}( x, precision = 2^10, method = "kernel", use_iterations = FALSE, verbose = TRUE, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Currently not used.} \item{precision}{Number of points of density data. See the \code{n} parameter in \code{density}.} \item{method}{Density estimation method. Can be \code{"kernel"} (default), \code{"logspline"} or \code{"KernSmooth"}.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} \item{verbose}{Toggle off warnings.} } \value{ A numeric value if \code{x} is a vector. If \code{x} is a model-object, returns a data frame with following columns: \itemize{ \item \code{Parameter}: The model parameter(s), if \code{x} is a model-object. If \code{x} is a vector, this column is missing. \item \code{MAP_Estimate}: The MAP estimate for the posterior or each model parameter. } } \description{ Find the \strong{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 \emph{mode} for continuous parameters. Note that this function relies on \code{\link[=estimate_density]{estimate_density()}}, which by default uses a different smoothing bandwidth (\code{"SJ"}) compared to the legacy default implemented the base R \code{\link[=density]{density()}} function (\code{"nrd0"}). } \examples{ \dontshow{if (require("rstanarm") && require("brms")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \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) } \dontshow{\}) # examplesIf} } bayestestR/man/si.Rd0000644000176200001440000002164414650172354014072 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/si.R \name{si} \alias{si} \alias{si.numeric} \alias{si.stanreg} \alias{si.brmsfit} \alias{si.blavaan} \alias{si.emmGrid} \alias{si.get_predicted} \alias{si.data.frame} \title{Compute Support Intervals} \usage{ si(posterior, ...) \method{si}{numeric}(posterior, prior = NULL, BF = 1, verbose = TRUE, ...) \method{si}{stanreg}( posterior, prior = NULL, BF = 1, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("location", "conditional", "all", "smooth_terms", "sigma", "auxiliary", "distributional"), parameters = NULL, ... ) \method{si}{brmsfit}( posterior, prior = NULL, BF = 1, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("location", "conditional", "all", "smooth_terms", "sigma", "auxiliary", "distributional"), parameters = NULL, ... ) \method{si}{blavaan}( posterior, prior = NULL, BF = 1, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("location", "conditional", "all", "smooth_terms", "sigma", "auxiliary", "distributional"), parameters = NULL, ... ) \method{si}{emmGrid}(posterior, prior = NULL, BF = 1, verbose = TRUE, ...) \method{si}{get_predicted}( posterior, prior = NULL, BF = 1, use_iterations = FALSE, verbose = TRUE, ... ) \method{si}{data.frame}(posterior, prior = NULL, BF = 1, verbose = TRUE, ...) } \arguments{ \item{posterior}{A numerical vector, \code{stanreg} / \code{brmsfit} object, \code{emmGrid} or a data frame - representing a posterior distribution(s) from (see 'Details').} \item{...}{Arguments passed to and from other methods. (Can be used to pass arguments to internal \code{\link[logspline:logspline]{logspline::logspline()}}.)} \item{prior}{An object representing a prior distribution (see 'Details').} \item{BF}{The amount of support required to be included in the support interval.} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} } \value{ 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 \verb{[NA,NA]}. } \description{ A support interval contains only the values of the parameter that predict the observed data better than average, by some degree \emph{k}; these are values of the parameter that are associated with an updating factor greater or equal than \emph{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 \emph{1/k}. } \details{ \strong{For more info, in particular on specifying correct priors for factors with more than 2 levels, see \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}.} 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 \emph{not flat}, and it is preferable that they be \emph{informative} - note that by default, \code{brms::brm()} uses flat priors for fixed-effects; see example below). } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \section{Choosing a value of \code{BF}}{ The choice of \code{BF} (the level of support) depends on what we want our interval to represent: \itemize{ \item A \code{BF} = 1 contains values whose credibility is not decreased by observing the data. \item A \code{BF} > 1 contains values who received more impressive support from the data. \item A \code{BF} < 1 contains values whose credibility has \emph{not} been impressively decreased by observing the data. Testing against values outside this interval will produce a Bayes factor larger than 1/\code{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. } } \section{Setting the correct \code{prior}}{ For the computation of Bayes factors, the model priors must be proper priors (at the very least they should be \emph{not flat}, and it is preferable that they be \emph{informative}); As the priors for the alternative get wider, the likelihood of the null value(s) increases, to the extreme that for completely flat priors the null is infinitely more favorable than the alternative (this is called \emph{the Jeffreys-Lindley-Bartlett paradox}). Thus, you should only ever try (or want) to compute a Bayes factor when you have an informed prior. \cr\cr (Note that by default, \code{brms::brm()} uses flat priors for fixed-effects; See example below.) \cr\cr It is important to provide the correct \code{prior} for meaningful results. \itemize{ \item When \code{posterior} is a numerical vector, \code{prior} should also be a numerical vector. \item When \code{posterior} is a \code{data.frame}, \code{prior} should also be a \code{data.frame}, with matching column order. \item When \code{posterior} is a \code{stanreg}, \code{brmsfit} or other supported Bayesian model: \itemize{ \item \code{prior} can be set to \code{NULL}, in which case prior samples are drawn internally. \item \code{prior} can also be a model equivalent to \code{posterior} but with samples from the priors \emph{only}. See \code{\link[=unupdate]{unupdate()}}. \item \strong{Note:} When \code{posterior} is a \code{brmsfit_multiple} model, \code{prior} \strong{must} be provided. } \item When \code{posterior} is an \code{emmGrid} / \code{emm_list} object: \itemize{ \item \code{prior} should also be an \code{emmGrid} / \code{emm_list} object equivalent to \code{posterior} but created with a model of priors samples \emph{only}. See \code{\link[=unupdate]{unupdate()}}. \item \code{prior} can also be the original (posterior) \emph{model}. If so, the function will try to update the \code{emmGrid} / \code{emm_list} to use the \code{\link[=unupdate]{unupdate()}}d prior-model. (\emph{This cannot be done for \code{brmsfit} models.}) \item \strong{Note}: When the \code{emmGrid} has undergone any transformations (\code{"log"}, \code{"response"}, etc.), or \code{regrid}ing, then \code{prior} must be an \code{emmGrid} object, as stated above. } } } \examples{ \dontshow{if (require("logspline") && require("rstanarm") && require("brms") && require("emmeans")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} 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) } \dontshow{\}) # examplesIf} } \references{ Wagenmakers, E., Gronau, Q. F., Dablander, F., & Etz, A. (2018, November 22). The Support Interval. \doi{10.31234/osf.io/zwnxb} } \seealso{ Other ci: \code{\link{bci}()}, \code{\link{ci}()}, \code{\link{cwi}()}, \code{\link{eti}()}, \code{\link{hdi}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/density_at.Rd0000644000176200001440000000170714461433341015614 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/estimate_density.R \name{density_at} \alias{density_at} \title{Density Probability at a Given Value} \usage{ density_at(posterior, x, precision = 2^10, method = "kernel", ...) } \arguments{ \item{posterior}{Vector representing a posterior distribution.} \item{x}{The value of which to get the approximate probability.} \item{precision}{Number of points of density data. See the \code{n} parameter in \code{density}.} \item{method}{Density estimation method. Can be \code{"kernel"} (default), \code{"logspline"} or \code{"KernSmooth"}.} \item{...}{Currently not used.} } \description{ Compute the density value at a given point of a distribution (i.e., the value of the \code{y} axis of a value \code{x} of a distribution). } \examples{ library(bayestestR) posterior <- distribution_normal(n = 10) density_at(posterior, 0) density_at(posterior, c(0, 1)) } bayestestR/man/reexports.Rd0000644000176200001440000000075114505754740015512 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexports.R \docType{import} \name{reexports} \alias{reexports} \alias{print_html} \alias{print_md} \title{Objects exported from other packages} \keyword{internal} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{insight}{\code{\link[insight:display]{print_html}}, \code{\link[insight:display]{print_md}}} }} bayestestR/man/weighted_posteriors.Rd0000644000176200001440000001474614650172354017555 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/weighted_posteriors.R \name{weighted_posteriors} \alias{weighted_posteriors} \alias{weighted_posteriors.data.frame} \alias{weighted_posteriors.stanreg} \alias{weighted_posteriors.brmsfit} \alias{weighted_posteriors.blavaan} \alias{weighted_posteriors.BFBayesFactor} \title{Generate posterior distributions weighted across models} \usage{ weighted_posteriors(..., prior_odds = NULL, missing = 0, verbose = TRUE) \method{weighted_posteriors}{data.frame}(..., prior_odds = NULL, missing = 0, verbose = TRUE) \method{weighted_posteriors}{stanreg}( ..., prior_odds = NULL, missing = 0, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL ) \method{weighted_posteriors}{brmsfit}( ..., prior_odds = NULL, missing = 0, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL ) \method{weighted_posteriors}{blavaan}( ..., prior_odds = NULL, missing = 0, verbose = TRUE, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL ) \method{weighted_posteriors}{BFBayesFactor}( ..., prior_odds = NULL, missing = 0, verbose = TRUE, iterations = 4000 ) } \arguments{ \item{...}{Fitted models (see details), all fit on the same data, or a single \code{BFBayesFactor} object.} \item{prior_odds}{Optional vector of prior odds for the models compared to the first model (or the denominator, for \code{BFBayesFactor} objects). For \code{data.frame}s, this will be used as the basis of weighting.} \item{missing}{An optional numeric value to use if a model does not contain a parameter that appears in other models. Defaults to 0.} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{iterations}{For \code{BayesFactor} models, how many posterior samples to draw.} } \value{ A data frame with posterior distributions (weighted across models) . } \description{ Extract posterior samples of parameters, weighted across models. Weighting is done by comparing posterior model probabilities, via \code{\link[=bayesfactor_models]{bayesfactor_models()}}. } \details{ Note that across models some parameters might play different roles. For example, the parameter \code{A} plays a different role in the model \code{Y ~ A + B} (where it is a main effect) than it does in the model \code{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 \code{contr.sum} or orthonormal coding via \code{\link{contr.equalprior_pairs}} for factors) can reduce this issue. In any case you should be mindful of this issue. See \code{\link[=bayesfactor_models]{bayesfactor_models()}} details for more info on passed models. Note that for \code{BayesFactor} models, posterior samples cannot be generated from intercept only models. This function is similar in function to \code{brms::posterior_average}. } \note{ For \verb{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. } \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{ \itemize{ \item Clyde, M., Desimone, H., & Parmigiani, G. (1996). Prediction via orthogonalized model mixing. Journal of the American Statistical Association, 91(435), 1197-1208. \item 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} \item 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. \item van den Bergh, D., Haaf, J. M., Ly, A., Rouder, J. N., & Wagenmakers, E. J. (2019). A cautionary note on estimating effect size. } } \seealso{ \code{\link[=bayesfactor_inclusion]{bayesfactor_inclusion()}} for Bayesian model averaging. } bayestestR/man/model_to_priors.Rd0000644000176200001440000000205114505754740016652 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_to_priors.R \name{model_to_priors} \alias{model_to_priors} \title{Convert model's posteriors to priors (EXPERIMENTAL)} \usage{ model_to_priors(model, scale_multiply = 3, ...) } \arguments{ \item{model}{A Bayesian model.} \item{scale_multiply}{The SD of the posterior will be multiplied by this amount before being set as a prior to avoid overly narrow priors.} \item{...}{Other arguments for \code{insight::get_prior()} or \code{\link{describe_posterior}}.} } \description{ Convert model's posteriors to (normal) priors. } \examples{ \donttest{ # brms models # ----------------------------------------------- if (require("brms")) { formula <- brms::brmsformula(mpg ~ wt + cyl, center = FALSE) model <- brms::brm(formula, data = mtcars, refresh = 0) priors <- model_to_priors(model) priors <- brms::validate_prior(priors, formula, data = mtcars) priors model2 <- brms::brm(formula, data = mtcars, prior = priors, refresh = 0) } } } bayestestR/man/cwi.Rd0000644000176200001440000000713114461433341014230 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cwi.R \name{cwi} \alias{cwi} \alias{cwi.data.frame} \title{Curvewise Intervals (CWI)} \usage{ cwi(x, ...) \method{cwi}{data.frame}(x, ci = 0.95, ...) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Currently not used.} \item{ci}{Value or vector of probability of the (credible) interval - CI (between 0 and 1) to be estimated. Default to \code{.95} (\verb{95\%}).} } \value{ A data frame with following columns: \itemize{ \item \code{Parameter} The model parameter(s), if \code{x} is a model-object. If \code{x} is a vector, this column is missing. \item \code{CI} The probability of the credible interval. \item \code{CI_low}, \code{CI_high} The lower and upper credible interval limits for the parameters. } } \description{ Compute the \strong{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 \strong{all} parameters. } \details{ Applied model predictions, pointwise intervals contain xx\% of the predicted response values \strong{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 \strong{prediction lines} from the model. For more details, see the \href{https://mjskay.github.io/ggdist/articles/lineribbon.html#curve-boxplots-aka-lineribbons-with-joint-intervals-or-curvewise-intervals-}{\emph{ggdist} documentation on curvewise intervals}. } \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 ) } } } \seealso{ Other ci: \code{\link{bci}()}, \code{\link{ci}()}, \code{\link{eti}()}, \code{\link{hdi}()}, \code{\link{si}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/pd_to_p.Rd0000644000176200001440000000344314462256711015101 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convert_pd_to_p.R \name{pd_to_p} \alias{pd_to_p} \alias{p_to_pd} \alias{convert_p_to_pd} \alias{convert_pd_to_p} \title{Convert between Probability of Direction (pd) and p-value.} \usage{ pd_to_p(pd, direction = "two-sided", verbose = TRUE, ...) p_to_pd(p, direction = "two-sided", ...) convert_p_to_pd(p, direction = "two-sided", ...) convert_pd_to_p(pd, direction = "two-sided", verbose = TRUE, ...) } \arguments{ \item{pd}{A Probability of Direction (pd) value (between 0 and 1).} \item{direction}{What type of p-value is requested or provided. Can be \code{"two-sided"} (default, two tailed) or \code{"one-sided"} (one tailed).} \item{verbose}{Toggle off warnings.} \item{...}{Arguments passed to or from other methods.} \item{p}{A p-value.} } \description{ Enables a conversion between Probability of Direction (pd) and p-value. } \details{ Conversion is done using the following equation (see Makowski et al., 2019): \cr\cr When \code{direction = "two-sided"} - \cr\cr \deqn{p = 2 \times (1 - p_d)}{p = 2 * (1 - pd)} When \code{direction = "one-sided"} - \cr\cr \deqn{p = 1 - p_d}{p = 1 - pd} \cr\cr Note that this conversion is only valid when the lowest possible values of pd is 0.5 - i.e., when the posterior represents continuous parameter space (see \link{p_direction}). If any pd < 0.5 are detected, they are converted to a p of 1, and a warning is given. } \examples{ pd_to_p(pd = 0.95) pd_to_p(pd = 0.95, direction = "one-sided") } \references{ Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and Lüdecke, D. (2019). \emph{Indices of Effect Existence and Significance in the Bayesian Framework}. Frontiers in Psychology 2019;10:2767. \doi{10.3389/fpsyg.2019.02767} } bayestestR/man/unupdate.Rd0000644000176200001440000000247114461433341015275 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unupdate.R \name{unupdate} \alias{unupdate} \alias{unupdate.stanreg} \alias{unupdate.brmsfit} \alias{unupdate.brmsfit_multiple} \alias{unupdate.blavaan} \title{Un-update Bayesian models to their prior-to-data state} \usage{ unupdate(model, verbose = TRUE, ...) \method{unupdate}{stanreg}(model, verbose = TRUE, ...) \method{unupdate}{brmsfit}(model, verbose = TRUE, ...) \method{unupdate}{brmsfit_multiple}(model, verbose = TRUE, newdata = NULL, ...) \method{unupdate}{blavaan}(model, verbose = TRUE, ...) } \arguments{ \item{model}{A fitted Bayesian model.} \item{verbose}{Toggle warnings.} \item{...}{Not used} \item{newdata}{List of \code{data.frames} to update the model with new data. Required even if the original data should be used.} } \value{ A model un-fitted to the data, representing the prior model. } \description{ 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. } \details{ This function in used internally to compute Bayes factors. } \keyword{internal} bayestestR/man/hdi.Rd0000644000176200001440000002016314560763455014226 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hdi.R \name{hdi} \alias{hdi} \alias{hdi.numeric} \alias{hdi.data.frame} \alias{hdi.stanreg} \alias{hdi.brmsfit} \alias{hdi.get_predicted} \title{Highest Density Interval (HDI)} \usage{ hdi(x, ...) \method{hdi}{numeric}(x, ci = 0.95, verbose = TRUE, ...) \method{hdi}{data.frame}(x, ci = 0.95, verbose = TRUE, ...) \method{hdi}{stanreg}( x, ci = 0.95, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = TRUE, ... ) \method{hdi}{brmsfit}( x, ci = 0.95, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, ... ) \method{hdi}{get_predicted}(x, ci = 0.95, use_iterations = FALSE, verbose = TRUE, ...) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Currently not used.} \item{ci}{Value or vector of probability of the (credible) interval - CI (between 0 and 1) to be estimated. Default to \code{.95} (\verb{95\%}).} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} } \value{ A data frame with following columns: \itemize{ \item \code{Parameter} The model parameter(s), if \code{x} is a model-object. If \code{x} is a vector, this column is missing. \item \code{CI} The probability of the credible interval. \item \code{CI_low}, \code{CI_high} The lower and upper credible interval limits for the parameters. } } \description{ Compute the \strong{Highest Density Interval (HDI)} of posterior distributions. All points within this interval have a higher probability density than points outside the interval. The HDI can be used in the context of uncertainty characterisation of posterior distributions as \strong{Credible Interval (CI)}. } \details{ Unlike equal-tailed intervals (see \code{eti()}) that typically exclude \verb{2.5\%} from each tail of the distribution and always include the median, the HDI is \emph{not} equal-tailed and therefore always includes the mode(s) of posterior distributions. While this can be useful to better represent the credibility mass of a distribution, the HDI also has some limitations. See \code{\link[=spi]{spi()}} for details. The \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{\verb{95\%} or \verb{89\%} Credible Intervals (CI)} are two reasonable ranges to characterize the uncertainty related to the estimation (see \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{here} for a discussion about the differences between these two values). The \verb{89\%} intervals (\code{ci = 0.89}) are deemed to be more stable than, for instance, \verb{95\%} intervals (\emph{Kruschke, 2014}). An effective sample size of at least 10.000 is recommended if one wants to estimate \verb{95\%} intervals with high precision (\emph{Kruschke, 2014, p. 183ff}). Unfortunately, the default number of posterior samples for most Bayes packages (e.g., \code{rstanarm} or \code{brms}) is only 4.000 (thus, you might want to increase it when fitting your model). Moreover, 89 indicates the arbitrariness of interval limits - its only remarkable property is being the highest prime number that does not exceed the already unstable \verb{95\%} threshold (\emph{McElreath, 2015}). However, \verb{95\%} has some \href{https://easystats.github.io/blog/posts/bayestestr_95/}{advantages too}. For instance, it shares (in the case of a normal posterior distribution) an intuitive relationship with the standard deviation and it conveys a more accurate image of the (artificial) bounds of the distribution. Also, because it is wider, it makes analyses more conservative (i.e., the probability of covering 0 is larger for the \verb{95\%} CI than for lower ranges such as \verb{89\%}), which is a good thing in the context of the reproducibility crisis. A \verb{95\%} equal-tailed interval (ETI) has \verb{2.5\%} of the distribution on either side of its limits. It indicates the 2.5th percentile and the 97.5h percentile. In symmetric distributions, the two methods of computing credible intervals, the ETI and the \link[=hdi]{HDI}, return similar results. This is not the case for skewed distributions. Indeed, it is possible that parameter values in the ETI have lower credibility (are less probable) than parameter values outside the ETI. This property seems undesirable as a summary of the credible values in a distribution. On the other hand, the ETI range does change when transformations are applied to the distribution (for instance, for a log odds scale to probabilities): the lower and higher bounds of the transformed distribution will correspond to the transformed lower and higher bounds of the original distribution. On the contrary, applying transformations to the distribution will change the resulting HDI. } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \examples{ \dontshow{if (require("rstanarm") && require("brms") && require("emmeans") && require("BayesFactor")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(bayestestR) posterior <- rnorm(1000) hdi(posterior, ci = 0.89) hdi(posterior, ci = c(0.80, 0.90, 0.95)) bayestestR::hdi(iris[1:4]) bayestestR::hdi(iris[1:4], ci = c(0.80, 0.90, 0.95)) \donttest{ model <- suppressWarnings( rstanarm::stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) ) bayestestR::hdi(model) bayestestR::hdi(model, ci = c(0.80, 0.90, 0.95)) bayestestR::hdi(emmeans::emtrends(model, ~1, "wt", data = mtcars)) model <- brms::brm(mpg ~ wt + cyl, data = mtcars) bayestestR::hdi(model) bayestestR::hdi(model, ci = c(0.80, 0.90, 0.95)) bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) bayestestR::hdi(bf) bayestestR::hdi(bf, ci = c(0.80, 0.90, 0.95)) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item Kruschke, J. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press. \item McElreath, R. (2015). Statistical rethinking: A Bayesian course with examples in R and Stan. Chapman and Hall/CRC. } } \seealso{ Other interval functions, such as \code{\link[=hdi]{hdi()}}, \code{\link[=eti]{eti()}}, \code{\link[=bci]{bci()}}, \code{\link[=spi]{spi()}}, \code{\link[=si]{si()}}, \code{\link[=cwi]{cwi()}}. Other ci: \code{\link{bci}()}, \code{\link{ci}()}, \code{\link{cwi}()}, \code{\link{eti}()}, \code{\link{si}()}, \code{\link{spi}()} } \author{ Credits go to \strong{ggdistribute} and \href{https://github.com/mikemeredith/HDInterval}{\strong{HDInterval}}. } \concept{ci} bayestestR/man/rope.Rd0000644000176200001440000002027314560763455014431 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rope.R \name{rope} \alias{rope} \alias{rope.numeric} \alias{rope.stanreg} \alias{rope.brmsfit} \title{Region of Practical Equivalence (ROPE)} \usage{ rope(x, ...) \method{rope}{numeric}(x, range = "default", ci = 0.95, ci_method = "ETI", verbose = TRUE, ...) \method{rope}{stanreg}( 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, ... ) \method{rope}{brmsfit}( 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, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution. Can also be a \code{stanreg} or \code{brmsfit} model.} \item{...}{Currently not used.} \item{range}{ROPE's lower and higher bounds. Should be \code{"default"} or depending on the number of outcome variables a vector or a list. In models with one response, \code{range} should be a vector of length two (e.g., \code{c(-0.1, 0.1)}). In multivariate models, \code{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 \code{"default"} and input is a vector, the range is set to \code{c(-0.1, 0.1)}. If \code{"default"} and input is a Bayesian model, \code{\link[=rope_range]{rope_range()}} is used.} \item{ci}{The Credible Interval (CI) probability, corresponding to the proportion of HDI, to use for the percentage in ROPE.} \item{ci_method}{The type of interval to use to quantify the percentage in ROPE. Can be 'HDI' (default) or 'ETI'. See \code{\link[=ci]{ci()}}.} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \description{ Compute the proportion of the HDI (default to the \verb{89\%} HDI) of a posterior distribution that lies within a region of practical equivalence. } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \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 \emph{equivalent to the null} value for practical purposes (\emph{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 \verb{0 +/- .1 * sd(y)}. This ROPE range can be automatically computed for models using the \link{rope_range} function. Kruschke (2010, 2011, 2014) suggests using the proportion of the \verb{95\%} (or \verb{89\%}, considered more stable) \link[=hdi]{HDI} that falls within the ROPE as an index for "null-hypothesis" testing (as understood under the Bayesian framework, see \code{\link[=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 \code{rope()} are inappropriate (\emph{Kruschke 2014, 340f}). \code{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 (\emph{Piironen and Vehtari 2017}). } \section{Strengths and Limitations}{ \strong{Strengths:} Provides information related to the practical relevance of the effects. \strong{Limitations:} A ROPE range needs to be arbitrarily defined. Sensitive to the scale (the unit) of the predictors. Not sensitive to highly significant effects. } \examples{ \dontshow{if (require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} 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)) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item Cohen, J. (1988). Statistical power analysis for the behavioural sciences. \item 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}. \item 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}. \item Kruschke, J. K. (2014). Doing Bayesian data analysis: A tutorial with R, JAGS, and Stan. Academic Press. \doi{10.1177/2515245918771304}. \item 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}. \item 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} \item 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} } } bayestestR/man/figures/0000755000176200001440000000000014650200252014612 5ustar liggesusersbayestestR/man/figures/unnamed-chunk-10-1.png0000644000176200001440000012173314560763455020463 0ustar liggesusersPNG  IHDR `gPLTE:f:::f:f!!!!!!!333::::::::::f:f::ff:f:f:::MMMMMnMMMnnMnMnMMMMMMMMMff:f::f:fff:ffffffffffnMMnnMnnnnnnnnnnuuuuuuuuMMnMnnȎ:f:ffffېnMnff:ff:f۶ې۶ȎMȎnȫې:ېf۶f۶۶۶۶nȎȫcKKKscKcKKssscKcKssKcsscssfW57~v^>p΁}rT `n ϯ_"y# l l~?w_>@ o?]Pn?z %?s#@]|a; 0^}w]PW^ګg`/Ό\{ck`/Oa{ =_Y~T5h!ؗnGFv`x=ե3˧ g1om\!q#@-_}t^Y^VpZ }wU= P >A=7/V; 0$iw`}8P{3ΒԱhrGk;/qlu#@=)o0c`//@Ekjs}k9G߭̑{[a=K;y9r`޺`l96}}7' dtnmF3x>7w>u3.Aq~NT5/f5n4 : 稁}{_}3_ius.1-|'i1릍3.3q1{WT5q132$.sw|!Hkϯ~qyl8X?2O~3_קk;9} 03s gw|qEھ囫\WWtTβ03t^nY߮{1o7O/>٩6?ԼQ9x`w R}zwOl~tnVsaf&Ku/s\6k>^ ֋}G7^( :c݊gKA~^˙\gJp&@~{VC+P/xiNxYk/{}gu*I17]f`W eӽ6/}UK9:NQ5O(^w:wyz30K[A]s_\JɏOOO afib{{Wt|esJ忽u?)[̈04{Ӭk|q~ۯ5%~k f`&6׮9l/U߼]u:p4afi .ryt;ZafiB8zƬ_pH804x&_l㭡Vǁ)f`&Ό{)8042^d|5:p afiBeJ|&mףt_q 30K*Ss_o=7ql)z^- d"ML zپC%MLMWOEi;YU4nےJ9R<IwiJu:p(ahReZ[a|_o=y87rxOqD' ML3%+I]>iΓlZ&:fGf`URz팟w|#7:q#30?+f` YXuNGǗ=?y8032}r}3|r~#^(qH%̈G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@H+'?~/Ӈa@$LL鹿O߶Gf`vU?po˯>o[q 30?*oeWɾ8I鳦?|G?泋}Ϧ}980342-NxdSןxWgJ E; `)ţy!߳qgk_k`yNof`{ ތgO3of`&K͛Nboq 30KGN^}&f`&T&kO"޻O@&HYP^wFSW|_q30K*S>k|MYP tafiBe:.oȫ30K*o2~os-  )9_f-:P042^N"w8042%ojoq 30K*Ss3ݫLJ߸nڷ=q 30KS*ӝ@7y^*"qC 30GS*ӽ=#o[(qH$M)MW)i&Ӗ^mK:p(ahJhE8q沙oo;f`&0_|w8Icqcǽ yMR p0afhZeZ/=VW~8032-nUWoۡGf`v&WO~3g.:F۾mEQd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRdE; 3x$q`I<8@0 $t aBdR 0!)S2F)#@HʔLf $eJ32%q`I8@0 Lt aBRd:0!)S2F)#@HʔLf $eJV80!G2F##@HLf $H&32%q`I8@0 Lt aBRdc 00?DhTx:Bڿ0)t '.EaL1Z\%OX0/(S #Z\$Oh_0=!SԎlE 3L1E V00s!SԎ6-l`Bma,SLQ;n`56\260[Ql`̅,SLA;~ྶ  LA W00wTю60_Al`ɂv+h l;;YЎ<-l`2mabv}m`3̇k&NZa6a)?b`[T †i Xbvf,f le*f l`b Xbvf,f le*dǏ60!|̾aZ)79 fWBv,d6LI260g!l`VȎ7-l`B)79 # LaE!b6LH2UG>Ɛ IDAT Z0؀.bǏ60 |a: d;n`16``qa6;]ki l`" t;~) Lq `{k&#Z qa6;n`06`` `{ l a3-lhe ,` l` 츁 [0؀}7y f0} L@06LE2E60sl` 븁 \0E;~ԃ <0 ^06L,^ l`qxa6]Kc`3/6>@60zw_[0 Z܅ 4b)p7 fh*Sh:n`s.6ЈUu †)Uu.\ lL븁 ]0@#VBF.Z3k Tb -Zs l & Tbqha6Pe-Z l`B)? l` d:n`-6``'F-Z l N60{l` v`d60jœg_0~\l`K\60fœi`[0z\l`K\l`K\l`K\l`K\g60bœk`[0v\60bœm_0v]l`)X7*St:m`[x sma*StE;~l` d:n` 3긁 ,6pN6@0ٯ>.CZ|†2l m2}ɓ.c rkm}rr?Ie긁 !C|oH긁 !C^9 #d6 eUGP7~9;0P>c}_@_œ \Lgo__| q@s2 O^^60gc`.ӇU:u`[0oœGށmaØU(d6̞0y_0fuSO[78B@nܓ )o ɛ#)yю60|pX0ׯY>WGqJ? =X{O- &Y2/~8UƐƑ"u2\n`+{}ޜ9y|_h1,9XL>v۬}FP:n` sV62H֯ٽos {6Г0f`+.l{s:~†l kȁ}ί{& 3#6`滟_?6 qG3K }C:n`sv6pi۟@7~9;L# Q06V2}__ q(Cf`x7nyMVp@7~9;4Eo:7Y6Џ0gg` dE;~؃@?œ lR}DǏ~†Y^b`[0Vt?n-pڷnmj>~G>x}m`s/ lg\r?87# s75Ϯ~xE;~80b`kJ. NNj l fA )3-leGn|klq80a`k鸁 $̹;Y@Oœ 1鸁 $̹!GaSZ6̉0gVh`[0NA4q:n`, R1q`!N l`M2A60:a\j_0N7n|v7GuMqXWn`.Qo>j7Ktaꄹb†Q2!n`bn` da:n`bn`늕[^v˯ɏ_9=}C_yk07A lX1^͟tQ=fQuda6ug䑗 \<øgqKs3:NqM{2 W7V[Owݳw_ontެDxmaÜs>% #4H^}޽˙Je}*9}f]Qt2 l`e:Y?~ܧJZwNe7>G鸁 'Y!ʴ<9^{7?s:/mfǛoo3?|(79+0@zn}|agJ^wbf7ǻX6Л0e`(O}pq''ٺԎo.lx/9-l aΫa|(UOD.c;]:n` s^6|WҼ|U5e}c;Ƭ_pȁ:~ l/aNq@ l`Cݼon>rc; o UZ00c 3σ}wo(79 kЁ}{6e:~꛺-HNjk AS?x}ma 9u/Kyե}>V l7a6 s~[<+㻷d l7a6 6}7V1Ioڔ2D|&2 'Yn4Ӝ)Y'9l}Pe#[/۰?'A:n` sV6i[|du߽sX>MWy})fǛW^{X9 /<-laΪal(ȥyYIy8?ҝ 7 9'4Hn:ocyo>x[G?so΍~Fŷu0H l a6 SjrZ)Y8Oro&-=J l a6 T/~ƍ>~r?yNF;_60gc`-_Y︲ٕv>v6̓0P|`[02ʔ'?n./?su<7x}m`M= #Lc6J0eO~p`%F l`,F la6- />zgǯ21/?-l a l e}'- ?=7<9ۃA֊1 l a Q;2G09#2@~֑q? d 9tGFu̮``[0}œ†QL>]60d`[ʗiDLy1:n` sV6|za^.cʋqO2- q]4!DLJ6L04Ⱦ6aT d!:n`sN6m`x. l Nsf`[0&鮗c`9sF6m25 sz&60gd`ۆ(i))f`[0yœ l`yߵ7Ae踁 d! 7_wGn`ysh`[0" ߿Ϋ' nl9kCt|ma s7m ZMB\Kc`9sF6N60gd` d!:n`9sF6m`vË&BLJ6L03ԾaDi<"tX!6z#B l5l`;i<"tX!6z#B l5l`;i<"t|ma#! l Fc27 aM@Vܟ Lg[?9y݁~p>:n`s6c2}{}1O'B l av S7 |pA~t>E;60gzp1Lg?xct|maô sp`[0C ϯ7z_=w^->?;7<9ۃ}?s{_@œ l`{qdˎ/?tQki l av P':f\OE)l6E2-\^>.3 A % :-lej}<:n`Ys>6k}l| l`,@ l avU{Hs| l`Wﺖp60c`ze:[=а†l6P7Y${w060gc`UK;d|dODF踁 !!ʴ8Srǫ7L95HENNyaЯ_/\_^Win`s7]Oox|Q<-l2al Fa~w};c;MCk&Msc}߼ #}65\޾J(_WW>x}m` s lkW/S~st3 6![ѾI|*xmUczF&Ky\SO[78)6UL_'$o36L0! eZf|_ K&KQ{^eb=nwK8 L06!At#/-.S%o k&HW{^րeg͙LJ5f`#}Ԟ65T>|~ͷYS]>-la~†)37mΔ|!~~ l`B L_=w dۛ6_^ן0%œCu Q 9ouD^)j' lj}ϯ\AUxqݨ jF<@{}w ! >C U^{[/C ^{[/}T|1>*/~P v=0൷B=/yƍ;Լ.Qd`C ^{[/} t۩MV/† joj}`;m`dsR>G}DP{Z/U sR>G2[K/\?9[Oz_z_Cs== U/ 0 l=aΨ^(X] l FO3=UJ.6a9\?Эhnw7}z l&@Uݪ6L0gP{Y l&C3U d5;^{X:@^_aR݆(}~Li6L0V{W:@zϭNю_wJpaWhv2S~ d6 +W߸q󽋏660|ڻzVn`.Qo>j7K]بu 9ڻR#t2؍ZG@s=/:@';ݨu 9ڳR#t*Vnz㋏->v2jKɻ$3@ Q dBC^u.v2{!e`/:@;P2j^uv Nf`/: ZRVWqGTWZMs:@7$7T:@œQM1Ɋv|4a7b8^*v ҄98Eo~wM|ڛzCc&P." s sp;YюW{RotvT sIA: s\t0*J``'3U:; sNf`_t*][/}o^wMT{Qot9ڋzK+z l~j/-З0gT{Qotvv2B%^[*P(} sFJGhWV;vߛy^*'aΨV0H2{ab`T: @+;R0l1W*h>x=a8H0;v2{a8R0G0+A b8€_Z%Gu}q%>x=q7>{>@?6zԞӻ /aU8*?W Ku0Q{NsVg-w {z}q2~j]uj2ݾx[n\i Ku0S{NsVC/w_ٓ:F{=[9@s;E~|q]n`s \kEL۞v! IDAT\<9r΁rjuf2n;'?<#{M"}^-M2-{J螊49@&[5ݢ΁ڔ/SJoϯ~:0{]#!̽^m E uu0V{Ls$üDD{=9@[1ݦΑZ tKg"]KtbG0}cM#j۽j `k6Ŏpj[mΓZz; @CxiVțO#oמ `kOvpAY滫^ܐw|GDծ=U9@6K)ݮʡZ+k.4ڷ^|w^{ᛋ֭[/H{CC"Ԟ E25tnWPs6t*ha`'37U9@œM)ݡʱv MUЇ0gS{Iwr,]7tSS^ aΦPX*cv MU:{Sc2؛ u*e`'3T9k -UNf`or0[ `R`1T9OS] ,aNS{Hwr0Cknv^{Hw)v0a^{Hw)v0 3?േtbG0yCSb} ?%vdYɑ0w8@SGlt`i|?=#{W'=^8a#|j}j`09^oGOU{DSx sOG>5e>?;tǵ GUxs?G>5e;9Iώ2~j}j`ej}~zdqҤ=xW%ޫ ?d\{ *ko轊,a7^l8S<-q?*v@׃{; @A^8+<-8irn\ODm0a7^lC~w%~-]EXȱEd!={8 ϯg{GGgc`qD,x7~5a2}t? ⍗4]#"G=qD U4N:^{A_P)̵*`nS\0T8"&;ݦ``pDMv2UCpnU,u㡛/>h V 0JClLgo__#/ cs2[U8$@|* a2zo:<0;T8$@|* a2%C V 0P{@_!6 RO@޼u֍# ݮ1j+U8&!tw}EʯȢ~JŎ P0yJŎ fs;E~|q]n`+vLr׃W*vL4 mO;.|nWsTiطΉ,.yPsVIEwOS.rPs?*`M25{;z3;T8(@?O| XSm`w|:0C#ԞWpP5üDDǏW{>_A~jU8(.r}_LkiԞ *a|NPzݫfݥQ^j pi2-V~<ɸU9GI=S T5CiVțO#o9GK{=S T5i{qCG]?*@o|9GXSLgݺBkzwyo.[n8" NœGd\*VݞݠV{;'x휤a<^{;')vX7tSǯ|9Id%yvNR jCH݊} nŎ p5;ݭqVW3չtN3qx"}?.6qx``3qV dv { 2`[+o݋wc Ǩ= ` CkzQ݋wc&G ` /JRɏ_9=}C_yf`1c^Ή?0atnaOA鹿=fǓc$G ` ّnݺqq??<]?uN7;ma>^h\L/}{/;ߵ7r<]y_x d>9G87Dn7||꙳r/j>ic}GC{=S dsiqdٷ )Y{]<|ȳ}ۃJ ~d>ڻ9G0@ i'z.43<9=}w̿4W<OGC{ ~d vk*z:x1zs ߶P]^{7+vh9A׃ ?˖}1/RBa(+QeMDvx\ DX 3UP% )Q(0XIA_"#DC7M"a&x$rݽvz{}yV5_+q(njASn$O  9.؋9"WX3d9Ny+V' ْ>)l4@~6TcKĻ6}n$O  9.U&{~w߻Jnb:}OrfN+>r6+ԮX)3-޺. kn] pjWgؙϦ??}7~rL'o 3ryLE{:Ɨ[S;(> 6Վ!X*3sνwwSus0Ohpkؘ/U;(>`t{q߂?,ߺ[wŇ\|z3}N׳1V;)>`g=rܽȽ}~fj~fY\|x ٘P*=`Cp.ec\bx2/{by\|=}^1_v0Uz>@`'(= 26J\|ڽ^/QxD@6+ծKλaZ;MؘW;/RxF@h.^cv31_v+_kiv31_v+_io9kv3٘3)<# lgZ^/VvL@*jwʎ N`'ʎ Hec^NX1܅G>Im;Y1l׫+;&>cZMvcR٘W/VvL0w;NWvN@"jw fN`' Hdc^L\9 d;]9l׫ɗ+;'/ :a;]9%ӕ̜Nڙ|A(1+ 8 C`6(N&=@ؠ; lP;ad8@AsI̛N&(;)`e'& !N )=DI d{fJ`QvR0k;준C̚N&);*` eGs& Aʎ '=HQ d{I`RvT0g;쨀y؃̙NV|):*` eGs& a '=LY d{I`SvV0c;Y>~kfV|c@ L`6+5=Lج.L`6,[{a;(lX@a:v2Or谀Y$ǁ K`'0K{Â@E̒`v2=Tis$*;--L`UtZ N fK`'C0G{ӂPȆ`v2=Xq3$+;.+L`Vt\ ʎ J`'؃0C{ス`E̐`v2=\y#+;/),t?v8y,ߘ6B`'+׎ %  % F`_$l`NV48Ǔ/Pv`0O;@Ɂ#/Pv`0O;@Ɂ#/Pv`0O;@Ɂ#/Pv`0O;Dɉ#/Qvb0K;Dɉ#/Qvb0K;Dɉ#/Qvb0K;Dɉ#/Qvb0K;Hɑs#/Rvd0G;Hɑs#/Rvd0G;Hɑs#/Rvd0G;Hɑs#/Rvd0G;Y>~kq.a3(17  d2a3ؗ " ˄ @`_&lfN&/63}+;'9^Ѐy$ ̏N&/Trh ̏NVx037{H" 03B$ 03B$ K0/Rs$ K0/Rs$ K0/Rs$ K0/Rs$ 0+b3$ 0+b3$ 0+b3$w^;s 0s7f ̛\=\܀yؗ  ؗ 0orasxsē/Wpn0?;B3"Ppp0;;B3"Ppp0;;B3"Ppp0;;B3"Ppp0;;F!Qpr07;Y}vVnrݘ l N&Qnrk̎N&Qnrk̎N&Rnt|쫔̍N&Rnt|쫔̍N&Rnt|쫔̍Ny.ltݘ6H`' 0_:auf̗N`v2}%6;;̓SnvlxufF`'W*7<`. E`'W*7<`. E`'W*7<`. E`'W*7<`. E`'*7=`&MfE`'*7=`&MfE`'*7=`&MfE`'*7=`&MfE`'W+7>`ʍD`'W+7>`ʍD`'+NDэ dNaf,T;^y ̙N&6?`s& '} dAI ̈N&3(6@`v3" AŒd;bfA`gPl0#;Ρ99 ̇N&s(6A`v&! MC |d;b@`Pl0;΢Y!̆N&(6B`vF! ,Eld;b#f@`gQl0;Y>38P )1 rva3G`6C+L`6C`~va3v&aCfG`g6D)sij7pRCWrc'T;Τ LJ B`'ؙ">I!\d;RS's)5E L`Rj@v.3! \JMhΥa&v2K)ع"̄N&)5Fu;Rcyv6N`gSj0;Φ lJA`'ٔ#:M1<d;Rs')5G,t߻-lܘ6L`'Oav2Q Y fH`' Q av2Or̨ ycF s J hΨ av2SIM9$̀N&s*5Ii;R 뷀BVpc'd;Ϊ( f@`'Y%4UQ d;B&*4JL`gUh@vVF 3 hΫ,};Ϋ, ' hΫ,};Y>޽[F0(1"6d" † ̆,l03;,ll† 3# † ̆,l03;'9Vh@<1Bӄ d;B%s+4MhN&s+4M];Bӄ d;B%+4NhN&+4NY;B d;B%+4NhN&+4NY;B d;BZ%+4OhNVn唙'Ьr= v~e 4K`Wf8L`(3PU;@Bv2@V e mɅf IDATBΝ׮ނ BY`d;@@Y 3" a@`G(̇N&#M!l0;'9F(3QQDi;Qf@v2# d;Dm!ʌZ& eF I`(3RhN&C)&He;Qf@v23 d;FM1& ef 4I`(3ShN&*"P];Rf@v2Cv d;H-A % (e 4H`G)3UhNy-.l@m60N&Mh6UL` +8&l0 ;6Vq;LXavbϥ+Рbv"c$+4K`'qhSd*L`)2W=;NBv2\8E v"#,4J`'؁ hTd(L`*2X9;PBv2dHE& mv"Z##,I`'ؑLhTd&L`*2Z1;TBv}|knaVlc;6Za;Thy;6Za;Thy;6[];Vlu;YZJhLv#c-4I`'J hVb"L`+1\-;XBv2p`% -v".4H`'JLhVb L`G+1]);ZBv2xp% vZ"Õ/G`'JhWbL`+1_!;^Bsv}|kGnMaTjc ;6_M;^|e;. l@va dM &yc% Ó (1`hN&K(1ad!K(1ahN&K(1adڅ[[(1ߛw`+lL`'k)musw3rùZ|rso^|j{o<7~~^5؟y/:̿_vO=}ѳ|o fC`'S`7Bwn{p7wq]`-FOow/8g~o/^}7vP "'_s;ǿ4[ﶚ_ ۏ^4YWt^IOןKn #"$]`I lo&o9?oo589]`- /oxz۫3WhN6^/n_ fp{3yyoyW.FO|'>@n:/7ΟwL=-5/xޝ;|ˇ'_rg'0t]?A]??puGB5E ޷.<voD]vz˞޹byZ@9mM=]vM^;ie\<-J ۛԝ,O|†a 3ΈezN~﹊L=lzQ]Q,}}|A`9)'=WqyI'/aԋP޴ҢY`CMnw?>r瀻{ot2lWW˄힇>^1B:~;S`4h`__ǫ +uvOWL窐N`PIS-{ GyקID;=^.v~] Ƽr}Ow>z9]j2 lu/6=7{vo>G7q-~o:8ثԿ/W`3yO^A죟]~t}^{Oyӿ[/z^E٧}[a x_Ep: v% zێOy^t{rv~64yq}ȿZ/Zo'}w uB`/yĽ6ޜޞ^>q{: +=<%摃},Jܹs}ى>̾=~HB!:_NN`g EW`Cs٘}Mo~2R%"W^=ۃ{q l 4;{{t?rۗz}|U={IWY'[N e{5 { b Fy}ȿ} '9^Ed_|9%ۃ\'sP`]w4=tߏwQb-Ҟ=zo^mVo}ޤv lj64y}ǝ7YkO}R߷Y{M?}=v 眿>~ۅ?o|`¾=gnYdOm~+ZvZƼwJWa>w k?|}E~Zo?~eu_[ث {}#~Y>{.^YFowz6oW~6'wM7mq;Z76޽U w>o[v6oW~6'wMxq_T,}¬}"+3{'.Zyﶟn}˷vm o?q|H|{?9zmw-;9}ۏmos{?O;:uE:4TҼ[ܞy[So۔?~7mvO{ax_:UD[aCؘoN}7y'C6ukd??܋S߷ډ0 lC`9|}ӟG^%<ݗ9=ݻ=qyȓ6y"GW ϼyceFw=|  Ku f^PؿxOG e~_^)y_[`CؘOv{<ܻ e>mz҇-v u4ؗj' # ˤ2SOȩ^%qs-wE"yfJ |m{2a S/r:Je\[h(Kp P{ ׽wާWtYK=7}Wo||a`?I>ϊ\Z=5͟v6P`/6`bpS7'u{YMLc}sO.ys}ýў+41_OzS,5n닰{rٛ/[v>h);[u}t`L=>`oO`/gSo9q]w{ߜ{6y>3{"2rSx ~6r?uh);79q۝{apsx{y3ާ{{{zY}ag lν lhOm`L`x=uT`oO`wOZ/÷/6R`/Nry,ow>y^/"ػ/"ۃ+;Vz4r7^[n [О&6>xv_Ddy2ʎUō'F`øط^ XqG{Γ"WTnTٽistrl`eukp-l̷xV'. ݨ>^dz{M l{y"dc}`߻#] ҹw#> rq&K^~|3 A:ruzG8~s30vM򲽃xg?~@gw=d~O/evEw6]Mv~cmps*W/!kp ln_FSx_ xl碗ב|MWoM\<) /~Ђ/]9߱=߱=y.'?&W=IUȞ?]UD^߯;Фon/¾N`|cç+~.6JN 욯""!Ic}s,/~;_G{~P`߾zZ>۷uoVw|v"~5~` ۷B{Yg7}^`|_;{UHz}h.O&Bo5$?vwOnzeDtwr{믻9iͦwˋQv{vyz|3?<{ݽ*1/zfO|'ݏ''{xGpbM}ә~&![^_ N޸/- *c`\`^$ڌuv|[_piO|۳a_+ d{bw^@?g~k~h);L(sz( 죅o0D{bO?Z'~>1$6$9^Y?Apuv=~pu@$K`~^ l`}@Ox^ݓ'9=ĉK6! ?l8~=-#A_/xћs?}m`;h`of}/:K?8_?oZ_> 7Z`C-;Y>ܗ}pv>r߼YI/㌰-ݘw {77_h)}x? _ɫ*?C;v"'JjOgUz'' *GL"|0y;"| *G' *GL"|0y;#|t :gS' :gL#|0u;$|d J‡' J‡L$|0q;$|d J‡' Z§L%|0m;%|T Z§& jL&|0i;Y>~{KvL\>&lL`W6v`v5ac&d& ;@`'6]Oܡ;Yъ<0M%6f#z0e;(z4 슢S& 슢L(z0e;)z$ 욢'& 욢'L)z0a;*z 쪢G% 쪢GL*z0];*z 쪢G% 캢gL+z0Y;+z ʢS% ʢL,z0U;,zڢ%w^aG-ldؘ)aӇivmaJ`W6~4>^`G.lTؘ & L/l0e;Yر ?096f}Fav2]]I`'= $ LI/01{ WH`'#1^"L`A "G!x `v2=+L% (/0){G`'أq^L`B"!x `zv2=kLEB՝nI[`z l;E"D d{$=a$ [`rXLN.ש[`j7{;M2$ dϥS o;Q2d{4b=# ш]`:xĮLN&G#v01;u&C`HBd{:)aKLH,[ L`KZ!G&l1`bv2=.akLŀȄ-0==Ljd82LA, ] L`Mj G't9`2v2=6L.0~{|BB`'أ ] L`Oz'G(tA`"v2=>.0v{BWA`'# 1 ]L`Q#'G)tI`v2=F+%I(. 0n{B@`' Ǘw^U')lI ߘEB`'& [L`Sؚ'G*lQ`"v2=RaUiډ:qaV,80r;FK`\ d{V+=va& [`؅N\{xF)zc$ǫ.N&/p}1>0^;H`_x d{!= % \ `.N& pSB0V;G`OA X d{= K#% i\#`l4N&!pF0N;EFF`OD"( d{" =$;][%`l7fI*8 d{*V =a$ [&`dd-N&#lqN0F;YsiycFqJIĭN&'$n1P0>;FD`OIJd{JV =%q+# I[*`<-N&%nV02;FC`OKZd{b  =1q" 쉉[,`,-N&&nSZ0*;FB`OMjd= lޘvva";ݣ [/`7f]zd{z ==ac" [0`-o)W IDATN&(lŀ1Sb0;'9NQ؊cISb0;%F@`ORؒhd{ O`OSؚXd{ O`OSؚXd{ N`OTآHd{V M`OUت8d{– L`OVز(d{ K`OWغd=*j݀ʢ7f'j`v2=aQ %',j` v2=eQ+T%,j`v2=eQ+T%,j`v}|y#iQK1 HQK d{ڢH`O[Au;*vPN&'.jzE-&yEP'9N]Ae;SzPN&'/jZE-% Z?=}QU d=]HDov2݂-ZAI`'-ZA݂v2݂MZBH`'-ZA݆5zv2݂ZD݈Ejv2݂ŰV(O`"hL`@`CSv+VjB׎9XG3h7f]J2B%;n]3&v#! lZ PN&[2h%vKVj];>@`CS7fOr,)f% L``_͘MYJA`'-W3f-v[b*v v@I11 dՌYM ݚՄv2݂5c(G`7'f94L`_͘YO(L`'-ݞv2݂j,(PnP̂BY;n5cV(D`(fE(L`࿚1K !PNo9 YSY`PN/v|l,*PD,YT(H`'-8v^*dUvBVv 7dYvBv _Y@<ݮuRv2OrlASBI YX(D`'--`vBVv Ngݴ"v2݂l*l"ݶv2݂V0Aq! dQv߮sp"6LO,kX](@`'-8 &G`7/by!N&[p26Ln_B8L`t`+l= v2݂3aZD0v †IسK`'-8 D`CC(,t_y󁭰aB7f= v2݂V0{."V dA=]RJ`KlY`F:CL` -6L0;Y>~ϓH l 1n +sVda,5v [ay Xk! Ć sA`'- FO`NrCL``P`+l;=? d[a  XpN`'w9[aøEo{8d'  l &)Cf;nV0b{/:% \ K`UUv2݂K[bh ʿN/v|ea7f=^v . l $,C6;n-a_{D`' [ao{ܲ/>d"<ɱ+[aDȯ@+C;n5-ate_}C`'-.%6rev2݂kF"n\p5L`Ø[-W\K`'->0"{˕Q"];> G`a47f=v8dyF#!ngr?;nA8]܏N&[+0 {C #!  l;9h d9N ;\܏N/v|ACeczG\@`' Ƿہ.$w`ɡY`M=cv *s׳g~P`;nA@`ȡ=w}zG %<ɱC5{2?.`L` &PS CdQm'*ܝ{YED`'˿sNDȯ?浃+Udm'ܝ>> N&[vr(L`]ʦIv2݂CQ{6H  s};Y}gv|AC!vkȦ dNEg});nAC{nY-O`'-(vr'M=zdk l9 ߘ~k%]mY2pN{ BJBo?ε78$ l9swŦv2݂:m# {s>tK`' yc{@fqM=v2݂m#es>`M`'˼sP7W d1J2mD$ l9d$.ۦa7{݂1BG̙zƇ' %2>`e3>5,>~쇺v|N׊ޘfk%]zs& ,=`~mT̕N&[0^ys{`1G;nH{!߃ C`]dY?ƵsF `0hƬd#l2=w6l2fC`' Ǘw^;>` ߘ~6k%]7l4fA`'˹ B& lвvPUxS`};n{%C$ʦ!Gv2݂JF`]M=6 d9 L>hJ|sX;(骼gz L``!s7M=Cd9؋1JFy Ҋ5/xޝ;|pf #ڋshݘj%]#< Oέl!>#Y;>`{<,!̔7ßAIh7,K&/ߙ|ٛ- v/!r|SV;(5;;8~ٛk~/#|U;(Цt4Zßc77d&pf+ڋkL{c>tMrSeZ /_S8{[?ps& M|c>9tM|SeZ ?|ޝ;#w<8{[yS?fs&rM|c>٩t5_@fLZ 컻{bwV}V|~XCȯ?-f7TP`/~}o{S<~ٛO0Վ9hv/:M}c>٨tiSNQ 5>aG^gov>~fysgwßy|SP;(鲩_'LcKĻGl}.^窟Z5a^;(鲩vOh(һ{Gx ^Yhͯ|!T껎}(,f 4aN>}&*1ZL-3|-&ͯ>p_ɟEacf8O5,U  3|-&Ϛb3acf83j,?YJ  3|-&QCr<+1ZL~&l g|F tOެJ  3|-&QC؂?,Npf%xPWb\ؘk1Z Uz{W8Jk113b؋=x;G<'goVu%_υ Ϩ^q}#Q<~ٛA]bsacf03j)汗,ެJ  3C|-&QS<山>qw{? l 5˗N]ۼ>~p=30?mc_ޏ?nG(׳1X`ܼϻs癟G:? l4P6d$ #  lH`@F2cz7{7buw>k;gM,\9O6;}{l6yFC<sq6@?~gfu[p<<#Y8s$]n,Svqk;͖m򌔇fy6l̡vm~~lq!O/< #;[pw]^L)l٘C ʖKW+X>n -F~?9Sb򌔇fi6 ḻve_mvGvs7gwqkn19g<4 1`c%+> vqk]_3nf򌔇fY6*ḻv]_l_ƄZ/{wqkPb^&Hyhfcsnŋ</;j،M,<6v]Go_z$W,>n JZ)l#`cM`׵wy]O'([W&HyhVacƜk;[H.`un򌐇f6l 9A5(b,"7&hyh`cG`WvĥOD֠Կc&yh`c.H`WxnvG<>n xם#5yFCsq6HŎwUL}[n =ҷջ<+d#xi?]~S7y{ۼ-2΍#iG_ {a}c6p~W~߃9lqsmW|֟Zv+}]|:Lin=_ڎ׈<܍o{7 \ !_6V,+?~t3s{npo?s,yK8r~ؽ_S  6(u'.3;2Ots{م>c_?{/;;_ĉo;=>@`8;zɾ_+O.ʸWV|-~n|>{Wi,k0<;x)SO}Ɂ}c 6p,ۓRйxyU仿:x6.S<{~ԑ_ھ^޼{N S_S   թ~~ w;ػdO,m] ݧnĝL>6G<^{owo>1@O`r޳o-s$].b90=Rz>1~z[<7^L K0OnK;ɺPOy>W,lCUGN^m c;81ׯo}Ⱦ/mGU=z.>m鯏)v{^*ཷ8 kW؝kDnlo8?x|z%Wgm=^Q}ޓ;xKaupb`~=ꃗ=2)7׈<}*w^+k3~{{[0ɃSo~ONN{ypj`~A}~ȴ}wo{?w+m` \ %wC 쾃S{7Q7={'L -w0?mKmS_S  $]C^XI^VW}#{uȿirw{5W>m7O}}L.*"xǿ+omSNU>s_ {"|Nؿ".8mwޕfz~ϸ%<]Ϲ=nmN \\`wpe6]+}s~؛;ܻp M|裻 ξ̻ސ/ݶAŞ8x@`ߞ؞=ȑ}{8mwW%|vwlg[ͻyyX w?gn;X?̑}xʐ|tw l~$ŇyAUorb77y/2Z^cuEC}^]#ro{/_G.~?6d$ #  lH`@F26d$ #  lH`@F26d$ #  lH`@F26d$ #  lH`@F26d$ #  lH`+iIDAT@F26d$ #  lH`@F26d$ #  lH`@F2Ȝ?4IENDB`bayestestR/man/figures/unnamed-chunk-16-1.png0000644000176200001440000010523214560763455020465 0ustar liggesusersPNG  IHDR `gePLTE:f:::f:f!333::::::::::f:f::ff:f:f:::MMMMMnMMMnnMnMnMff:f::f:fff:ffffffffffnMMnnMnnnnnnnnnnMMnMnnȎ:f:ffffېnMnȫff:ff:f۶۶ȎMȎnȫې:ېf۶f۶۶۶۶nȎcfȎې۶M3- pHYs.#.#x?v IDATx$י"1c AS *VX\ځ%k4n3giR]YuNy˞&qΉ&Oe.Nbl(H`@A P6$  l(H`@A P6$  l(H`@A P63OEM١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @ug__ݻ/ S?ޙ߷Ÿ_Ʃ :O".aW lLC~bՎ ȴ:\_bMS @Iu߬n-/߶b-l @Iu?޽i?~ay| Ȥ:{M7ؽ+ @)ure?/tmR^qv;}I Se`ol n[`/OC_.6 Ȕ:ڮ+;W~Ͽ&A`bJzm*ja lMCv6ԡ}W.K lMCg:z 2ؗ-:rek SнOYFRo{ Ȕ:ts{7oqR^{79 lnRen_bCQəT^u}mGҲ7nj߼}N`dRz0~Gd۞"LCW> kO Y[6Y_x @iuM2??r;7~/z&ek!"2]¾p~{ccI~Xn͝׫M"vlZ?|qydտO^vޫOzO?"+ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6Arv H١ 9;T`$g lP @*C6ArvOE079;T`pD09;T`py-rvZb}P vյz١u١k 앳C6'g l薳C6C k t١v١av١Av١!k 쐳C6 .g l;%6UvD_+l`*먾VM9;T`ӑ}rvZaP @/ZaP @EZ`WP @e[aWP @ZaWP ~Zarv`}- 9;T`WV*اh_+lRS86p.g l( 8C6P @ *T6C6]VrvCVJV6C6 l lS6p*h١]6v`+l g l ١6P]l5B_+lh^l5J`+lh\l3N_ lh\l3R`+lh[l1V_+lh[4^_ lhZ0b_+lhZ\7j_ lhY\7n`+lhX\'P 5#†P 5K\5z_+lhW\%P }-Y9;T`pED`+lhUl k ١MQlk ١ aI9;T`p)64)g l.†P ȾТ* C6bZ`Crv\p`+lhOk ١Р*X ړC6kuX`C{rv`%:WYDJ #١>= rv`)D0*8L_ lhLN'6%g lN6#g l& ڒC6C6 l -١IP [aCCrv `<9;T`]E0*7D0*7E0*Z][D 0*Z][D 0*[E 0*[E 0*E 0*;D 0*];D 0*;E 0*;E 0*;E 0*ZC-C!g lEGtƐC6@â#S#١a )zpP Ю#zxrvhWtA=<@}9;T`+*{EP]͊G-g lfE~#ԖC6@빇!j١UGP Шv%zrvhTt;=J@]9;T`){&*]=EPWMޢ *g l&EwsoTC6@١E<@P5P Тj zrvhPt4=V@M9;T`4(:,*̃DPQNaG (g lD'@ԓC6@{y١9*]G>*]G>*G@*G@*G@*ZD!PZ(-g lVDqCC6@#㸄1J١q\D P Ј6."zrvhDt=@Y9;T`! F*]ƅD#PVm.R(*g l&Dwq1 C6@J١ Y\NH%P Ђ*.(z(rvhAt=@A9;T` :KK*EE&PP nⲢG('g lD'qYѣ C6@~E\XpP _t=@99;T`]ĥE'PLEpq C6@z=\\P ]t=@19;T`dD)PJEpC C6@v5\AP \t W=@!9;T`$UD*PHEpу C6@n)\IeP [t W=@9;T`]•D+PFEp- C6@j!\MEP ZtW=@9;T`D,PBEWpEC C6@f\Q%P Yt=@9;T`d5E-P@E7pUу C6@b \W١ +ztP WtW=rv+k_h9;T`E/p*Ҋ8ZiEo}# +g lC6@V;!C6@V;!C6@V;1C6@R;AC6@R;AC6@N;QC6@N;aC6@N;aC6@N;aC6@J;qC6@J;C6@J;C6@J;C6@F;C6@F;C6@F;C6@F;C6@B;C6@B;C6@B;C6@B;C6@>;C6@>;C6@>;C6@>;C6@:ѽ;C6@:ѽ;C6@:ѹ;C6@6ѵ zȁCP MtFs@9;T`d8PDnAC6@2ѭ"zЁP Ltƈu09;T`]A8LDnaC6@.ѥ$z؁P Jt膉x 9;T`ݹa8HDwnC6@&љ'z䁃P Itz9;T`d]8DDWnC6@"ё)zCP Ht䆊|9;T`$ݸ8@D7nC6@щ+zP Gt~`*.` C6@х,zrvH#:pE?0\iDn ١ =`9;T`ݷ',g l,v*g l,v*g l,v*g l,v (g l$v'(g l$v'(g l$vg&g l$vg&g lv"&g lv*$g lv*$g lv2'$g lv2'$g lv:g"g l vB"g l vB"g l vB"g lvR' g lvR' g lvR' g lNi `*/:i'&z:rv袝١`vb/g l.ډ*f/:h''zBrv螝 z١`{vr'-g lًɉ*.:g'(zJrv蚝)١`kv+g l *f.:f(zNrv蘝Iz١`[v')g lnI*-:e)zVrv蔝i١`ޢKv'g ly.ى*f-:d*z^~rv萝z١`֢;v'%g lYɊ*,:c+zf^rv茝١`΢+v¢#g l9 *f,:b'-zrrv膝z١`ƢvҢ'!g lN؉`*+`'.zzrv肝١`v'+g lيɋ `*f+_'/zrv|١`u'g l"`**^g z}rvz)١`u' #g lnY$`*f*]g!z=rvvI١`u& 薳C6zV?6D7EOEKV?6|D'EOpS^,nM)F`Gt\7짞\l.ԙ>!ԳT?6|DEOpSĞvl 0с:{зCOEbO;> nС'߾hoݧ= :]6 oݧ= ;f[`Et_ 7ҡ۱UD`Et&=uv藗{E^ "NB;/\[4?w՟{g lzȿ)v<Ž3ww6@!8Mai: 'ondRp]u6@ Q;Ŝh IDATm¨37CO6vZ,7~\}{l^ȉݦ)8_@C:t_~~= p}=baGiMOo5^}ç=Wq}[Gۙ#&vt&1l=ͯ5|K>/p0˝?>~g(}=VaGiLW˭!۞z"ݽ^_m}' p=}=RaGi۠ο/EdYΗYi/ lQ ;:La{qs߯>cvtQv џ|]X)仭wN6Qv. W`[CJʎsˍ#?>|ЫvtQ{Aԡעwg6zuŽD*01䷟z }wW6@?;3 kwܽӯ^ܥ-ֻkvt&Rwa~s=}p}]4 4sE6&QJ͉:<-jvSD6Z`J`gTs::_{bqW-?,{s~pnjlvF5' C.y豜?̍79 lvF5' COo=0sOKA}]4z ١˅ʮk;O6@;z ݡv3w^,eS_ޮ|>wvI`ToH]!wB`H`To&M ??r;S`f`_ ͦDM+W/`{QԘ$ NO|g l MZ}TI2_?mWחl\9% jLp*.]?%jLpg^s?mww>',dTiY8N`-|GQ`'UcClOW>ا6FhBU 8ȬD`] U+`zo~{v뿟 -vє0Lk[/zݢ)՛.`*lkT١b>\ݢ)<@Y9;T`~:,mS4(.g ln%{~S4C(W^,ykY{} 7D:`& zpGg[V; l}BZ`qT;/ LJyE`U(y߾~;4C&(׉q}oү^_`czI`O!k?.<-l 4Гq}}6:C:`2-O/{V]#$~;&WC!";D_n|4="h{lEWhb# Щ yǷ/<s}ZrFk]XStq>^ވ^~k6Ўg;~s;3JƳC6, [`1]lxEZ`'2]!}Qm6;:AsgN=ރ{]D`D;>v*L"ХcVO^m>{n`;v&L"ХfW7Ϟ'z`v@K? DƙDKW}cq /rJ @S>C.M"p^'凗_Y^߾ l 0H: Ghzf8T}pدly/JÔm^YֳCf__ l! vM3Bo>;w~ٟYC*@` Q6<;?+3Гa&({^. (2rv-'l@iC6uvR*g l!PlP 0D08L}'7D_(tSrГn/uP`:lByЯCmk 0jCt{6ay:Y6v.##ХϹ}-Ƴ{/ӳ'ThuN?~=ѯ4$|:|w4L9S?X_~( l EԟHKj 䳨X; tqᵧJAHf_ lO$Хg`Oی;l }=^`Gg3$E`CžTIK= ZTIKsC{`orfTIKE"X=@^`n6;S tա]ط>}( l!F ":=P{*.:txU:@JݞM=@>zO>yox[w;чl!F u_+QTKK]q>O` 1V`_="){<"'7.ـs t;9ѯ= l! ǏN&%g l! l= t١`Sw2.9;T` 1J`O_l]rvb~GSu6.9;T` 1b`?c:@!z__M#*A` 1F`gK:Г߼pGK<# l`F>،t]¿e>[V=l`> jN'Хշ7>Xpv vNt]۫>yw/J-.lR:}{y^;߬>yL`sѱ٤ ts^ݰ^m?6mZ`'Uq>.}߫ث ח𕚇v }-8@>'A6{Eǩ lJ8@'C6{羭xhGܥ{L_tk6|]zU}z37 0DNF՛PK>+i Nބ]6;z t9|1"`d 7@ÿЗѡ٪j tuJo*= ^P-6@/YF`?&G,Y{lOU[:gk(ХWna/^"lv;"6oW5TQK}>=Ҿq{ǩ\jM)Хg>\|#;bk5@z60k5@zѕ~鳚Gu, 0N֔]to߿}3`-NJjM)%g l!* TSKCDc}]M9P I+<Ҝ]Ul`F&pyUSKߓן,U \z:_1 l[9:9ՏX*(lXI?/qS60# MUu&n˓~v IάΤ]ҿsN&v uUUK9E_߽?' {?M`SUYt_7~ ;b0@)K`gVeV.]'wy}cǫ~n65;:/Q0}>ەh`Zitt} ž-l 0Nƴ]::QMGSޅ-qc ЇWGD` !s0@}R_~!عUWwф7a l!vtZT~^N݁ݵz5G ${Q/)?@kŏ>6S 'rٺ tL/Wo .m+?@ {P%XZ`؃ ]Xl 3 tL-vig"Y`r[YV`QS tL0JO-Х;酅aMQ'M$+=@ 0i*vtTr6g裸N`Wxn.`DF`Wxn.S;ɗ1&HL$_^k݀s tY)^.zrg:\Qvr.;1T([Pvr.;͗0YaG e'2| ~L$Pvr.<  (;@*A5Eg蒳C6Eg蒳C6Eg蒳C6Eg蒳C65;:'rvbXg6]rvbzEOh[JN/%g l!f } t١`\jsJ/!g l!*v4%_KCL?v ҧCOQB`]t-^$A`c '3[/S`C%C[Spg~:"`]!M0eH`?Տ 0,0С_~Ebb;b'#݊r3 t{?'=yv+0a=93(*f2.cz`1(6@gޛv9\΀,6Rl7cOs.g@Ŧpi˽"/}VJ Hol`GW$;bˁ'pS{33kݐRs t8伿UFS3 Ĕc7g7_ql h,NG;!Ph.N';Cyk'aX%(4@!e/oi?_Ў (4@jO?znRCdCZͷ/oav8 0D.H:dK˭!۞z{ 0_!e&2(~m/ݐ2 tػߊŭi=O` Q4nE&7^bSbXJ,]z޾5d6s ő]eKC0PEfrL>)bv}p1eeK-"߹scOֳC. l!J8Pb.}x9{% 0>\ilf { t9<-6@3 `%ѡ'[/޿j=)5w%Sb.]p0`=^&gKW/8C29Xytv=}XG9B`<];~΋}#R`.?Ed6drq<6@A/(؍9~.]t1n tux>xy2H/O4evW^xyk_ ?@] Fz*hwc7 nNE:wN lfvg,nHaݜI` S`; lJvt5[e첻CO޿on#)nrvB`ĺv١`ݞ!g l! vt32@lC6AEVUC=ϟmvsTd[P 0DVY9VݯJǫ2(؁(+tm_4d&e`Pf[lvl- -WU ؃B)g l!cy=TܔC6n١`] VjP 0nR\C6Ip]CXdbUW~iWKrm*_4~Wx и$gݦb J`n}.> 6[@Up$-TlWu*}*/Mti }.:9H%lea;`nU%lJp]"]6%.lL^ح*M. 7%'D"*K. 7%3l#[Up\` ح*K;~歚u4 0nUE\ۡK~X#863C\E~z8RЎ *s:ΐ߿s{-H؋EAeաכB>8oV}kD6 {u>(s}:nܯ>hsS}"_`/vO%pO>ڶdkTn.-} 3Pt!k}:ի=>_ Cd  Xѡyфl!Bztr >~< `ݰ+ X9y7V;⛟|oӋ9="`ݴ« c>59O.iW yz9&됣^N`}>vJ'h^G`~gh(M`z楻JdS onC (u+/dkݸ Z2[웢ې/(h]R0IZ`%N l}MtRD%m;:SD֤<ƕ_Rж~W߿sr؍+m=;˟x @ZvtRF5Mס 1ݺ Z֫CzUs &{}SVaQAtɻ~=[ӧ@`nEĄUXTв>}ui'_dR&g7c*,*hY}8^uV?l6vtt1@&ƲvW?>iUW<l!cWeo~œC~xm { գC)}d-+16-j,+hW>Wq3{sl! (-콪,,hհ޼m.ܷ`9"{UYXЪ}IoC0mU7^o Ylqܧ‚V}me` xl! $:+ Mg)곻NB`>֫Ljf?X#@ eK/n+:cRl(WnaW|'^4dD`~WKS!"b8=Ha7^va?oz6PJ^7|t/ ֑ڸ cX4qBl(he !_rs筩9@1gw6c jp9Fh66E#}}P`G Z^ОW.kJyhz@`Wk}As\6;O} q!06'Z qW#l!6+V4_>8rwnO6j+ ӫC7|p߬dwl!vt RE%mӡ?v~GˏD6-"&Gv] C4ثa6 nV|C*@` 18;8g$>)Ƞ%=:t7U? 0D[}4 ZңC[IC؏nWݤ IDAT4$l!vt-j.3hG-" &j.3hG/9܃"KG1I5cn~q{vOb``GG.U4O#r9S}>Р:t {W``GdU]hЊ~*컟]yg?oC4TuA+vw/>ȭO՟^͉ClU]hЊ| >N@Ԡ ͅK j!PwA:;{@6M@6.5hCHG@}#\Ԡ 9/" ^BηEǸvtRY-y i"?*ؠ9!]Bk͆ʋ Z"(b!?*ؠC."G}IZWG&zP`G^mЀWoo<}IZGGtQ]|׫~q#PL'͆ yy5=cl!6j/7ȯ_>:m}wof]'l ^*o|~[V<l!vt1 աOU: l!6/8ȮOn`_S-؋+ӡo8kڄ(hI >`kJ? 0D. ξ}RAn=:ݭAGf6-gdR9HG.7!IC؏& kR;l zvtUoaAf=`oyk`d 5#:HSDn>/d h;FXuX]ޫq {S!ч09#:HO)smS݂-Wiey;e~ze_OE`-XwV]}ib^{W60XwV]mnD60=;( ١?F_?;ݾleAV};l#!167 W/_L960SF.>F5҃]TNOv\/ZDE( ,=)%k%06}67 >Ww/}VHJjR !{vt1t'K%0>l3⃌z\RVKjZ اmFZ|QK-3>(5mFZ|Q[q-FZ|Q-"`5ѹZ~Oç|#)I` !b|Lb_/sI` !bUaz4B`XաO?Οcu犻G`GF[M]>Fd>\D` !fl5$al \qLh D(ѩ7aP 0$7!*ؗ0\rvB`_C zxkRӡ_M(K` 7;oLzÈ2סO>` J` !7 #.BȤCO>|F:6{4*D:;\y˳-0*D:k/n|~:b_`GWa\GW><r;ghu 0f1!ѡ?vg?|-L6l!6!}rԫ">堎&nW lvsBטWoY|^+#R$q͞n<!K̃kk@JbB6;!垐+[Bg+'H1F];?| $ 4J$˅蠯o#ԸKr@knEHA` lvw-B h3`#/F@`MrB`ȋ2l:! @W`G^0M#̟@`a'踛E}= lng:FD$]w`/sŵܹ;C]}F_0w{{C.wk s'ػ$̝`w`G]4W_0o^I¼P 0I`/$arvB`xZ$arvbg`G(arvB`-`QœP 0[9١`ME sC6;:똊U 3C6="%W5 6{,YQ .Da'rdcbl |0VLDB%Wr,X\\zfgVsZڕsle+"%+1JCEFvtQ 9nQu׮ gl YЪ+6ׄ,LhUqcBV&4*1G}.:4M9A WlYЦ 6ŬMhRyc\\6I93{-NhQClzZР*:A9;T` !!huBrv+kZ<=9;T` !Z=1$DOhNC~6o,>0QC6r5Z,f^a ZC6 C6aP 0i`G\6GC6GCfkqKڒC6'r)pBSrvB`O"P 0E -١`M?ZC6ǁq*rBCrvB`S2vP 0e ١ؾ$< )rB;rCxvtQu 9{ U'Cl ]ЊPB*"1Ua|=Ѕ 9|LU=}=a`G'5]ЈX؃lz]ІX\T 9Ǐ <./g MoKڐsl!;:\bP 0 -١`MZC6W+4 g l!;>ꗳC66G+/g l!-6o3>C6l ;zBrvb/ۭ!8#g l!-| C6&薳C6&薳C6O]nmaZE/X]Cl^P* br9;T` n+*C6aW,T.g l!6E/Y[Cl;hFP 0f% u١h֏hf% u9X%}3@Ks0G>f5 U9X#}};Pks0C>f5 U9X!}}Pks0C-,,2dal l^PȔo$,zBr# 0fE 5١`pѫ*C6W-T,g l!6EZXCl^P*E,O9L)zBrvB`o9vzP 0 [a99;T` ! VCfvjס~Ws_?~xqՅ?C` ! a`+l8շ6^B`0pNeox}yCΨC~ "%̯6QW~oF_yg˿=_>l!v 3k ݪY_u{.|-&zBֻ}x齯q l!67^P:^SI(C`s uCw *zBjMGw]_eB[{ ]"[E/^RM螏.CD6Ba!Y*4l.D`s Ui0 g03E/_QMi@`/F.́K!zBjLp6̂.E`s 5i4}'ߺfA`\`s 5i4|^{ҟd.쩍6^PuaOi$_zTF0$K#4T$2!)4/zACEr*3ҲK#M+sT lkH`S@zP p~ l ^P*8(#MkꑳC6e$'>E/jFW'1E ١0c<=4F9;T`\vF{d, ;zUC5rv0 6rv찋| C6e]$G'aNrv訋f6rv訋f6lP pQ ̡6P pQ lʈ^P*.9"M+*C6%Y$)$ziCrv上6D/mCW u١ҰpRER7T!ؐ<(ؔ 9' Y~}D U9 dHbzi(9ǖy IQ6 59cA_㴉6D/oAιe C =&9疁 I1&?Lc9 Y?2^PD<Z#%6w^/ЙV#zC*y꠳y-Gx9;T`AZasErv8cAWZasErv8c@WZam}^.g ln {L'PFh9D١۶v;JOc4P i@ZaeH^P i?=Za%{`+l.g lN| P i]?ZaE`Cj9;T`tYπVc ١˺}vrfrvn]}-*G`3rvi;١ú|6ыBP a]> D/vC6Ml&!T.w<L!zCL`Clg`_ ln!RAfBC﷋>6#BrH9ǘ Z,h#D@9 ZmG`3rN1Ǵ$<9ghSk&!N1f>CG`3%qr1e{6^' 3a8G`35qr2 pd{6ӈ^&g l#ݣD09;T`: }$=D١al&!JG_3eQrv8pR>:E zC*K'Q^‡ 9;T`8-}]Lrvו>)/zC*u\rvs}u=vڇ9;T`9[?i[a3O9;T`9_?YZ`3O9;T`?IZ`3S9;T`<@ںIZa3O9;T`<@D/C6 $M9;T`h x7١`G l @ut=H`3 r6 ]'6 `Ќ5"> $Qk5bȬO lF`z9q S@Eo^Ωf\C#zfLћ&sІ_،)zr5ZG+6c0sf ͨL-\3!fTs l~#U6P ҳ60*Vzf\&C6J،+z#rvX?BE`Z9;T`,],O١_ ,6,g lGݬV`R9;T`< v lh[Z`WGaCrv-KxHv)P 0v}fVrvMKVK&C6n[JCG`3١`Hl&%`:9;T` )L'g l`f{C60{G`3M١ewNdPl)`29'jٞ>)D LAgC6>>IDo J1g~C {"úG`3mS9oB`OeXl&-`*9 UZ 47L$3Nz2G`39 pL#zcDr9j14{60jٝZ=Do FI'^vVf"[s l`Wf"{C60kG`7`>"7L"g l`GB`C;rvlx}EDoB o]#OS١G`Wn(6sC60c7$b7L g l`nI]; M١`WO`CKrvfK١G`/M^?W@l<yZ`_\<)E]\<IEo[\;IEo[L;IE[L;iEoYP {qZ7fZFs l8[sG`3#96b賘[sG`39 t6TnĢ +3ϡ{Z7׎fb{ƕsP}=kG`39 tB`OL-zr=*'u{l[`T9S=v6.0Dz؍ӹu6.0O`3tGl&_`L9;T`3tGla`D9;T`3tGla`D9;T`sO-gp-١{JG`g蓸OP ]#H rvf؍ٽ%5Di`49;T`ss_lMZ9;T`ss_(mc١;;G`7'M"ƒC603wvnOVؤC603wfnO~.I+g l`^ݠy\aU[9 [ƑC60/V&HցqP ݕ#y`9;T`rwlDoE֋plDEa(!؄>0P`C/bvoMc9MxP pSB IDAT4&L1䜃LN Sj6ZPF(avZU#Eނ"rNG V9 V3D5Oy)+OcFMm7%純PBaW`T'z=rK-vkMu#TPB_Wa'zrNK2Do8Cq4]SF`S9.uÍY2 Eo9]y)<*ژ%#QF`[5d65tpS`2{N'_[P d3ny1!Om١f܎سq/zrv9c\l}Eo7$ C6о)E`ѧq]rv7e۽Z*Dޒ_@&-=cf ;zOB9;T`͛\ P npsL_+lڑC6кiE`Z3}-iF@&=o¦9;T`8[5 VP mj4"zkB?9;T`mZ6ޛK@&M+7'C6вE`ӌ }P ,Y6͈ޞG*Rfش#zB9bH>D$;z9VX(D$![9U )MC(\sG_W(X6-ޤpUα']`ش$zU9Ǫ^umbE`Ӕm 䜫z]+DS&`U ПR^ش%z9'+SE\UᲜ*6EՊrFy[.١hRXl:,΋ެpQ@bE`sd8/z%9;T`-k͡FY.١hQ\l, C6РTj65١hOdl P 'T6kMrvZ*¦b9;T` ͩZ`S*ĆI١hLplqጜ*}QLش)z96FŢ3E`Ө r[݊> :EGU{圶2Nl_}tM7/t9lU{zqp*:Q6 ޾%pdP.Mâ/t9j5Eo`s֊8'6Mp*UpJ_*N6 p*紕ƨTt, lZDq#}Q6Y4-zñV`.5MoEp,g la!k9aTF#9;T`mΒ-MOEƱ Grv%[ z١hBtlY P 4!Iv6<Žp g lID`SJ@dZZ`S*DMousMUrv#6 P /F l6١^tؤa+g loAtؤa+̚ Є9$!z_F1/3ς+;& k9`ƶo>.c$6[(DG MћVr`ql-D gE')MѻVr`m|D')Mr`qEHM6]6Doqؐ_$I$z,EG'3؉ &6ZNs؉搳C6P&?b'z3{9;T`36>( f2oDtZ#,* ʃ9lF sB laѓf<ق!BP !*z،f#ٱg})`nrvlFM@BbX^zf&g l=1f$fZ9;T`!66١ClFTG_+lC6.:&،VL(g l ZtJ #S%}Ndb5(#C96y,,&EgP409"!OGCEG`809"!F D'pو<09 ! ݦ耸f6CαGB`(n!Kssl퉎l$" ۂvB}#XΐPH\ray ޜ6l-RE@9KB"qΕp*0tsذU.kʙ32K%dvJ?d$ H8C`O}C{G_\PP1!rό ;OL+ggٺ{Fs#@96 5[WY`=u6uAF_HP/'^LF6vZz~DNWyIu"~W؉!)ωh| lX`oD_DAm!o=l|*1+y.a;RJ,D~͇/-(v՝'*7'y.{#J1uȯ#)v])䅂f8kJ'~{/e6?ykWo?`ʬםA 9g"k}O_r:ewl8!92k1؆_݇WzV޸F k2'E l 2;fFU=%2|Vq?560管W~}g7<=d[@r ֿ@i1ɔ 짿sxE;wޯQw|ߗ~Ƀ@mJ g%l pS~^.yg}-IfDq*Q*=gS5M7\9,`Dg~?t6S9hK,_Z Xz4a/AFm`K|9,_fR Ÿ0˗YԦ)"%Y465v`Cxf0˗w_|Q K< |iKmj e1_,kW=H.4a/*n>%Y46U2wp#WH.4a/*7}l?~q K< |iKm U4?|OZ՛@.4a/+WPl?~uP{#Eeɷ.EmxxxOwE} P6$  l(H`@A[U͇=_ ~]W(.@`>*_woS_}k&(.A`㯾qTg/-@]!Vu+DSÅ .pe|uoNuV}㟖.@]Z!FOR^RgW>u}B}K36hy+eݮOM\^WPefl1a/{efl(Sg:YXh^=*K6y_͇~xxOwO>zTe l(?o,?omc~޻Yg`_<*K6,y^wROP]j&Οf?|lGU"@\vuoyLK`.UpgݗGMlrp٥n_mexx6)R9 w?{u$K6|Ӈ"|߅>]'^k> M\vi:gg_JO \vi;<&*&˚>.@$] v.^VB~@ ] f_9~Rڲ@v+q8.4B`íW/w|럽BV?JY׽W0.B`í~ᵿz'*~{(.B`ÍZ_ɟ=}=*= gu}s٥nBz?JGʮ?meflѻׯn>|/L=x+yv\vig3W?:Oᷗ?{pv\vi6$  l(H`@A P6$  l(H`@A P6$  l(H`@A P6$  l(H`@A P6$  l(H`@A P6$  l(H`@A P6$  l(H`@A P6$  l(H`@A P6$  l(H`@A P6$  lG^}Vzm~K9}m!: nyOXrwE l PTw`/iuWuoW^+]`l[(0_7;_]_8 \IDAT6@Q'IyyU5H` l  PTgsF+Y~Q`l:oX7RaB 31E`}}T`F~Ϗ8 l  PTw`{DJvWzZ`l~?xeuOŗ>l>}緗v:ga}* ؿaρ6~/KN`˗^#~cܵqgNmO="oFo{??8w~E^^Zطk^{_N'nGvځ{DV:mP Pԅ{7AĶu__8.|q O';{du|߇mP PTw`='zȾ^?uӏ[>x ^ߔő/~y?>iW~McU}ȮS;v(qm P PTg` raT8yy]]}?|&оy/?tɩ;y~|ؗ^T٧W~8⥃׉'x|qƙ#O7/@=6@Q'](}۞'/7<)Ƚ/^:+^~ps}&Dxd烮#ܷ3/@=6@Q{5NlSoG^S]38(^s]{(L`>9zkޫ;5GKT3LyG}N(;?w(h~}x->ۧvl .kߣog`_ܩ9xǙۣ;~}!~_s楆]{W s1;wd>Gv|~E]O4 LgWm "؇w:?!ǃ^pp(Hm l  P~{/?E/3;rr#ӣOK~aP PԵ^FO\ K 8 G җ|po8Q`{d PԵ^}p&/3/?1}gػ{DN~})}E] <./7O+?⑽{Ǔ7,^/G^wpOԧ߸9td^ 旿{?C`]$n}3U.>=_ts?8x~G?^t~E{o,Ubj3{ށK_oV.W‘=_'yto4})|ïl~jl W6z\؏P%ۇ'pȞnܸm.>y;(f~qBϽ'{w#'ǟvw77o /|'E] ͭyyZ؏lkW؛q·}؏;C/B`u=_Dzeﮎ{zJWŞ;xP`?>_fKyWzȾGQ`/鷗O7\?TB`@A P6$  l(H`@A P6$  l(H`@A P6$  l(H`@A P6$  l(H`@A )tx#IENDB`bayestestR/man/figures/unnamed-chunk-8-1.png0000644000176200001440000012036114560763455020406 0ustar liggesusersPNG  IHDR `gPLTE:f:::f:ff!c!!!!!!!"c"c"d"""""d"""$c$$$$$$$$d$::f:::::::f:::ff:f:f:::LPLQLQLRLMMMMMnMMMnnMnMnMMPMPMQMRMMNPNQNRNff:f:f::f:ff:ffffffffffffnMMnMnnnMnnnnnnnnnMMnMnnnȎ:f:fffېnMnnMnȫff::f۶۶۶ȎMȎnȫnȫȫȫې:ېf۶f۶۶ې۶nȎȫccd d e c c d e!e! c d!d!e! c!d!ePQRfȎې۶QRdeQlD pHYs.#.#x?v IDATx,AXri,lbȮ]Z+dY'xBB:1Tyl/ZBM$˥J0ZuIFׁWA6vްG'wz}gt_>} ܱD`@@6$  lH`@@6$  lH`@@6$ zw?pGǥ3奛j>s_b{+#y6g\}_ ؙ;f`gN{e3v݆ ]g 0Zsp}-bwxF.`,Fk>wgwEC~ؕw(;%h81QvO~F@,Fkg`ߐOݹʴv,Cv?/.?*O>"vB`/^IG}`_C 9")gs{X={@QC`>MsHK`/0 0vZscӘa(n^V{;}痋i}cw.^O=ZÓφ;޲!>7/^G˴-?<[NDOs>}mo}d叞{ȷ~1}7+P}9LXUo݀dBe,!|Hַ]xs'W8sx2MY O lO}īWX5<ʧŴA?őڗ8W T\~KM^n˥[%[iq~]9 Zm`7OnDv;'=Qx_dx<E{6u.J˗lZGb#Wn?Mо\Ŗ_`Bxv'9*n[i:CC'tWU/;|_u ?=GQ >zc6m ,@m`OnD|oo|ں]PL>nV+@qŮ+kҲƖ\5q<|s6qr#g*CZfBSxu{l7'Ƭ_ffr<K,.)|e}?]<;/,y e[nE'K׽]\̟b.Ƹ/QAsG1w6h6V/-]:՟W?rv\Ed'Z}Tl.o+gK~150~}zSr[W]uKg_*כVlmUHPR_!:Ϡmس9WoYk]-Uam`Ov yy0sԼoPvvwVw, u'j'Qm ib!b%.sl̶R6[s`7Oc`x}ub0@Zm,gU9""^OޱrݻpA`!bʵjo}l=4GJŭu~<{'- j..^;|1 ^}rO)0?Ai_Y:j+e5yM>U~A͟Lq:r%}^<[Pt g\=WyҢ~+ ʞSDʉ]XEZ(,]7xV\g˭CjzHk.d޾ZCߴ&wO)"7c5KoP h*(&rKBkrإ'ع3 7,n 0wx0uSl ?\S\߱dzw\sW='Wx.wu\ɟ9$oy|45Tɯ rh3~*}y eͼ\T]7obN]voA~C+kV;}vDnB{=QxSAmuq;I`Dc>dW`W0&z1ct+'(?xvq07؁ػ+{~]Z@'>RY8Zֺ+ϋ5/鐌`gZ>(已g` @ ;l6{1Z mXY};l'%VПP ;."ri4e]j`DJ}C<G`I.')mu֋UZhXljS:շ"z|]x{v{3v ݟh[~Cؗ|`W͙O=KysAm^eng/Qx|u9ȁ>tVL Yr'Z}o~C؍6=wrOv˹|T[h؞~O=PqXvXD+/"r!͹^wcXfcݿirCqOn[?ط]bI'^ ١-=;j^~-9w~w w'ǖ/,y e.ފ~貿Jzb$ۏxs݇?k ;r {'Z}o,y e[zhƺ^>?Z7Uvh! #.Q})MzOno,y o`_'sԬ=-&uӇ ;:q;i.qmF6%'?껅N<0ݹțw?Ҷ[6Wy첷n">RdO}|vMg;ϿO4e:|1Gj0-Ё61s5p`g3Dܽ8^32l`n>GmŪjOQJ2@}i{@?%D{sü!my(OZ^km[ lH`@@6$  lH`@@6$  lH`@@6$  lH`@@6$  lH`@@6$  lH`@@6$  lH`@@6$  lH`@@6$  lH`@@6$  lH`@@6$  l(>wͱH>uA[ Wf§04c+LflL"I36ٙHL @$iv 4;S`I)$Dfg l"I36ٙHL @$ivf "J2>uA[ Wf§04c+LflL"I36ٙHL @$iv 4;S`I)$Dfg l"I36ٙHL @$ivf "J2>uA[ Wf§04c+LflL"I36ٙHL @$iv 4;S`I)$Dfg l"I36ٙHL @$ivf "J2>uA[ Wf§04c+LflL"I36ٙHL @$iv 4;S`I)$Dfg l"I36ٙHL @$ivf "J2>uA[ Wf§04c+LflL"I36ٙHL @$iv 4;S`I)$Dfg l"I36ٙHL @$ivf "J2>uA[ Wf§04c+LflL"I36ٙHL @$iv 4;S`I)$Dfg l"I36ٙHL @$ivf b]澏|ug.;&\ : [vݖ;%|@l}5/ >uA?h~o6W;3qbgcM{ؚyHFߙj𣫙"а3= l"{gf|^ulWD2U熬_lYwv wcyوv0śj,D2zpUcD;O2,i#L #EHFޙ՜&J @$#٥uxZ}(_i,"dL%C?~y{Ǐ4' wc =XOz;~7,-?R7.;oɶ@Wy۵ߺz^^y/7~+1ygg*|{S_vk7f1Åvy]jڍmvk76|Z5pxw~u [`Gjw6~uv^6~5^`?_~V`܌3vvm4*"[sq<$U`爼%b`<'`vFޙ{:[ϯanuՅmZ_ږoY?~* 1]:,J)mRL;G`WdVN:4b}Ř^#(]X !Yw|(^)~9 2qcE6i~O]V+xrS>?J`gE78G-M+ynI`3 ' z] UZFuEPj'R`PӋM/`fFޙv;WR& sDϊEȁ-ں_[^bD{p5M߿kQ׵WrZ[+-?)]Y?xr?R ;V3e}V#^ ]Mu\{>+y|`ƍ|bmu}x&~,_Y46K緛Uʟl_DxFޙ@n=~Yd󻋁|PSDsD=ڍT^zˍ7VwJ&~>s}-t bY^i9G lH1^,?G$! e_/fy[r P?L)v=|_dIޜ7]ޟ;+\_k`mw׶wfY{])[v~H6C؛.&u%y7d3D Ey*Vnb`}w}Hﭞ+9$?5kpC0cUk=SnL"[vȢzw E#9_lm1eapbo[wmw6_٠Uz,E1,WMwv,.;9*sD|`窺pc@W#e+tst] "$owǫ.Jݛ^Drn[%|>۟k읙fr6];:1?ȱal*sDv^.,U`o|uBva{?T`{}/=AB`8wf6d-懛o)?{y[`Ƿm{Յկ&#M>f[6+Q_tiW[rv.\1l6f?NJ6;3pGxvl^xg~w7{6.p`ut^ͻ.ӈoy.{k֍_ `~M`GW-W]]Ϟۮ'`ߙ٬ܨt6 gvlnثk3DrR %vtV\m`frIv:۷s }9o~~y1s]{/n O>{}53d9Wsm{zf5m`Wg/sZ}ڮ^,6{o;J`6r6uʕ?ŭf64:[4}9w~?Sڳ$&sD:.QXo9"kk/r\qc4V6GZ7_R H3vt^y:7_6$Mq'sD޶^o؋7UVZm[ogˁ]\wol4;S`G E8/?3 z!QoYLo4ez{q=.pb`/s.ߍqgq`;oQK3vt^ ՘O-ZToYӛ~[a{3u69 gYJ_;q;.K6U)j !~yȪ]}^-v6N鯭Ky"_yz;{c)W|؋6Puګ;0ziv.ȯq 쿩Y=cWlg,kߛ!kUE7~9^.l{^Gj?&zK3vt^Y*r}^VjR؛"[ mf7Ks.'>{pGtmfẫ6U)r:ȪWÅ,֫k[de y۳xQS IDAT |L_snbٌ cfg ܿݐ[;^qZM~{e?p5zsi.u\ 쳳?Jv_?|ϖpl cfg l"I36ٙH̄;SDpe&|H3̄O`iV• "RDfg l"I36ٙHL @$iv 4;S`I)$Dfg l"I36ٙH̄;SDpe&|H3̄O`iV• "RDfg l"I36ٙHL @$iv 4;S`I)$Dfg l"I36ٙH̄;SDpe&|H3̄O`iV• "R#c@0ivw`I3] 4;S`ʎ}@Aٙ{60Oiv>J_+l`L}t5}w9$G/l`L}t[bӔfg 4;S`[m_W[bӓfg 4;3˩wl L(bkpc#˩ l L(bkpc#˩ l L(bkpc#ͩk L8bkhtBVTٙ^ 4;S`Y=ZbӐfg Zr߾Vٙ/60iv>\/k _)[bcfg 9860niv>b+ 4;S`MVٙXJg`+l`L}$P760^ivf}S 4;S`G%l U)ZF*G660Nivf}D5|P`+l`L}u|X`+l`L}[a#fg 򡁭I3F'؃[acfg 5qVȤٙ{h[afg 5'jl QI3"$؃j.@I3#zK l G)$ٙ{HCF#jpH3  4;S`H`iI3pZ8d`+l`L=[afg  4;S`60?iv̠H3` l _).C@rL=]9>6pliv[aGfg&Þ1[aǕfg ala O)qVQٙ{G l Sp`iw G l Q)!ٙ{ l O)С&C8j`+lXL=.,I3 84;S`؁H3v|8j`+l(Lfg F 84;S`G׭# L8:u *э#604;S`ֱfg 64;3F Z)#Q`+l``ivL`J3vdc l +qun_ O)ܾfg :0!ٙ;+I3vTwVLU*604;S`Gս{60?ivG Lp`p=W`fg zdpٙ;;``+l` ivO l`~̄;>;d`+l`ivO l`~LO4604;S`+y l !*^ O)Ufg hЁLMٙ;~;x`+l 4;S`3w60?ivg -ر#"K3ȧ3v60?ivo#6W)#ۺ4;S`Gҷu *L8꛺ l Ĕfg 8z'q.#"J3vCW`fg ([aٙ;{V@4iv l`~LE=^`+l 4;S`ǰG l`~L{V@$iva=f`+l 4;S`GO l`~̄;ީӸG l Dfg I\ O)#'q !U4;3f=r`+l 4;S`W l`~L~{V@xivnٙ;聭L~y{V@hivnٙ;vLڞq+I3vh{[aaٙ;=V`fg lQJ3Hg l`~Lؾi;V@Hivl߲ٙ;}v$̄;}V`fg ۱I3vX{wh[aٙ;V`fg BI3vX{W'a]# l fg Z O)?j #Aߴ l fg OZ O)?i !L8cE+I3vH[aٙ;V`fg ڱfg&г4;S`t@ώ.6p4;S`tHΎ/6p4;S`tH l`~L!5;VL!1+I3v@[aI3v8'Բ l $4;S`sPʎ36p4;S`sPɎ46p4;3}ꇅ'c l /ֱ4;S`sXǎ664;3L3_} /v|}…Ƈv0ex[aBg j.AX#l i͟ux30X ;s1#=)A=#v́3=.ܾ}Y8خgK@lX ;|+/gŽ3 l=[w؍|h@Fߙ?ųW_0[`!D l`~ߙ٬}g]WjP`+l t7 m"Z60?S?Y`QhR`+lit櫏߷h3siV O)Y' $؇ 4;S`.HN+6E)X60?iv>XbX`+l4;S`,L l`~L}0:Vnivf' ӫ l fg 샅vI3Ԫ'L8 T l fg CU O)(V hfg CjU O)U' hfg CJU O)*U hfg *U O)T' hfg  U O)*T hfg ٙ vSSHH3aet{Q73fg I7*lF)R'/X L84;S`&XN8+}4;S`$\N7kZa4;S`$\ l`~L}p*I3Ae' ھB)S'FFiv>HLٙ3U`fg CT O)0S4I3R'ӗfg CT O)0R3fg lI fg&؇ \bKF$s c'ٙ!U`fg  T O)2P60?iv_@ٙ{AU`fg  T O)4P60?iv_@K`po4;S`/h l`~L:VFp`zaU`fg 콅 L*I3[a+ivf}*I3[aKivW@U`+l fg }T O)8P XH3' 3 l l 4;S`)t-6 %t l`~LЁ:VЁ*I3N=t/6fg =T O)|[a@L*I3^[a@L*[>a ,>@@s`+lH|n}d#G@t sNn}tG@u`+lHT^4=Op<}Τ>"[a@:twۺG@t'5 .y3l Iڙ߼M_(#P60?=:o5/y{sl )י/?klc =T O|\(#Pg Ogtl*ٳ3~z #P ҳog>}rocO`!F l`~QiM{ |]'pp=T O_߸\sE85E [a@jtf~۾|P._@t=fnyإ a j 1:p*wIτ?XvQU`ӡ3Oy[׵7y{j -;3{d"2oQU`#O*SC E D[a@R:4rmM`%PS l )?8C`s!{ٙ8*93O/~Uؽ t[a@::^X[/'g98P`+lHƁ=7g~&=A;> uzy,\v:"槱3DD Ԥ[a@"GX}E T Osgfsw [@M+63/@}E T OKgѻ~r1}TZ`)P l I)}E T ̏HZ`+lHH*Й\| dHX\`+lH@){4;S`+P l fg&z@4b컟^Ibj`bkvH+]`+P60?;1;}[a l:ԧ!n4V0s_M&zO:}!V0oiv'J.l`~LO8]H46Z)Ѧ O)ѦT[aٙi$ߙOy-Og7I_DHӥd[au̧|j '%| l`~:uK3ۙ7Nv/t-V0_]:M }⟧xC䃋F`K760?:s5hUZ߼.{Sޥ [1l}ӫS$"{ [ݱ>w,|"!{ [)[٬UI_M~b31{zv/4'V0ScRrKW'&i[`:;A(V0K}{u&G`HK60?};Hߙ9Y%9vrva rN@ -t\_)ثEnyl>iY򁭰`:hf1RLǞGr*O:rkF`G+Й˱굋׶>pӹt=[`t|綋`LGK!6O|M__r)%O=TSl_/fb/7\1AP1ZG``v:'뮏ohC!P/l4;S`Ek 84p,ivf_' aٙ0)ZO`gAٙ !D`gAٙ !D`/KBܙ/?_R}H`/KB֙/^ikF`wC c@@]:ssL`[Й7L`kЙO4۱^; 3_*on9B`o{ݙ{8c q/fwg^pvgұ:7 38scNCc33)3݅Hf;'W [`OtF H` 쐂6dI&;5Fe.?! ¤c]p/bwgtӵaC,P:6 *b#*P96E:t ga Bc]tKgv"HoB*T96%:uC2**X9el!&] [`wk c6m•c-]qo8Mr#+ش XuvձrP:&*d9UCٙ vSuvx_>04;S`w4k:}`iv(l8V :}`iv(l8V Z~`ivfOpصљ|;ϟe0:CVvGñB`;kg>tSnn:wˣ1+2Qp,֙T3$; eٳk  IDATuKn(x8zGԥ3}zdǰv7B`zY ֥3'oX`~9c/Mnu-;Cg^b<}&co|:! ۍ5v Ӷ3-}õ{5=!lMn!kTZa̫K 1YXG`WIݙ6!]R}79-⢔t5c9[jwE}O``"|5V&k읙؆r6_Gk'W?VlS\`w+v\`+lwf6.E75;;+$ vS_{g>Vus<8- _I>6L;:LS7)?-k 6P5,i#R)"uzhM `R:˟˅;/H]NW^6'iX%lݝ[̜,bepym[`w>vb`+l]uwI>3T*ǂ?F3 UjwJ^غ 8 NGcnR l ڙ/]o~ʇZ`w>v ֙۾>Og>y͛~]H ?X%[attkXmksUo?K`g#n*D`tt/fٰ |4V &V0͝yu>l'bSD dnᛱnR l Sܙ ^f{UD2Ŏ ; 7c D`t5v 悾4uv܆[7c ݤ&6LDcg^rwrl-|3M6LWcg^5$)V\2֝p`w>XC`7 l [i-e͗C 7c D`t5V :RfVeq2#C86LBSlewi lvN^^ oSD쐆l Sح#Uِv]5g.~&_p`wk&k]r!R;;۱0mCO:IC`+lv6cH6]7Cdc~/4*;uv 5^Ys?ՎΦ4 ` 'cݤ)6{92}Gxvly6%…^Bi@@`>&k􁽜Le}5Nᓱn Fom)R. 'cD`tM ^lnP:bei`} 'cݤ96{1E3߷S]w~y1)Y"w uvV0rNᓱn"`on|/ZI[`+lM`Tb%l.k &`vbvH؉!+6Yc`y[6Pfg&/ZɎV0biv%|1MvJ3ჱn"`LC`' l fg c=D`tٙ{XO`7 *;zIV0Riv!|0M6LW)wv.`LC`'l4;S`> &[a(ٙ]^l l4;3t{n-6Q)ۅIV0Bivn&+bݤk`+l4;3$|/6M6LW)ۅIV0:ivn&[a_0&ۅݙ}ܭ p$CحbݤG`+lN}ɭp0حbD`tu Ec3 *|.6Mq\L[` Mv ա3-?vD`7 FSg>yGgpɣn>&[atӇo&/yحbD`tW)ؓQ` Mv`Du{' vSMv ջ3z`< 6kn76>YXVdӱvH`70]{vS"Oo[` _vށ`4'O zL%Fڧ3b/G5QD` _v`,wfozuOD8hvH`70]=;3}rWZymb#dV0}:3Bm_Xo>}(Gn &qܙ{HKS-b3D`tu]ү%b>b-b3dV0 :ᛷu]{c> #|,6M6L2.DXl& ƠG`Tv!E%[fط>Ҽs'*6"|,6M l #-pB?:-b3D`tu]z.ݧ> &K3vL`70]tOׯ*2zEXl& E5\?rvB`70]I8w ߊ-v[aS}cn<&#?_I`QRl%lA+,el Üa"hNqşDj n]3wSUYZ~w.UZ+2.D`sk̚D`G6K`7ஏYs2~*}Q n;"^mv4j "#h3vqcn&6\Bp`2r #fg N#;2Q`+l6;S`w; T`zGtO3wUz1K`G6khgխ_?/&X؝F^;2Y`+lܰebğlJ1G`G6kPg8~ޓ1G`G l SҙonP-G`G& l ЙgYl]h;"^:՚mUb|51e!#Siwj~0Z.a;"^hy/<`4=e;L`G& l ׃5h84-wL ۙOy{} .!;"^HZ]&jCvdV0!=& D$ lKDfd;@`Gl xח7s|Lr䁭`2ҏܦo^Kl'9>}uݕ]KL 23;oQ`w0B;"^C:͗^2aʅv`"Qg>nH?W?O>(+]r%;MrD`+lFԙ˛uo+]$";LrPc{IS. # l جMrv2` KlװC\煎{%M`G. &fg6O]rvD`@Lo$# l k3K\,6/;"^mvfÁ:[a̧??ݦo..Prv䂁`dC;w۷^zs=#(=;"^:w󠙹DؑKq ̷_$ٻH Й."!G`G. F53y}O \&v e[a;s}ٿ?-~>|o"{υBnlWg/~MVxq3_MG`Pؑ w沪?/߼I/WVH`Tm ̧_>w[Տj^$"\* ȥ[axz;s{dCs"#l ^;^yzūh/rvD`@ 썫dWG`\mؑ؛ ?='[; F1IQm=;"^ U,GwC`Gr[at2|lҷU<."sqᎻ&#53W/\ HR`+l\^^z%{ϥ;nM`G[atN}ի!*=-w]<vD`@uv^/|[`/ &#53~)}&#%atfw_\{Cf H`!E_]/n2{Cf z 7W5竟}i &#e!;s@ۯ\͋D^ؑB[a:ݗ-| &#ߙOUNluw\ؑR[a@\Y!vD`@z;9=&#^?8طRcM`G l }vR[M`G l =\""j;"^.rlޮ ׃G@`J-5):64A3kD+Dj}Vj;"^\غZ[&#eCtQwkoJ4{R;M`G l  ew|&ZO` &#53W˭~䥗nW}#7vVԙ޾طr+M`Gl a^re{Qv]Hؑ[a@d`g>Ig>;皖h;"^;Y|}*>{ o6T Gv7(}#7vVm@g?Fwx^oz6||/[L`-4P\߻G {7^ xC}#vVЩ3\~qx69>5{[:R` 4#6ts\s 6|rok{ }&#ۙt3e.Rbo,OQ{uտ\-\ľ=]O3$6t%>KyOW^Vtgí$un}-9vVo3V'/OSBO6SZr H5`Og>Z$/Q:L^о $Zr z M_UwK/hwdwîWn4;L`G l to/zc?[ikD7\n){$T v ̟(g>ww]!r`ȯf;"^ܽԷ8=@r HMوes IDAT`ۀtT H^^?rH G2ؑ[a{,tx'.%lWp,tՌu.־7L`G l ܦo^9؏qJ˟޻JÁ%;vVt3Ν\k竟x|Q ء:[aBܙoެg_?G[ؿq[~A`dU ӯ,յO\"ݫk5&CvoESػKď@}7ءZ[a~o^v叆^ˎ166ā՚yy;O`?{-vVu*lN.{Hz6;Zؑ mvأJEٙ[`B`-fg l= }fg67;kI`G k3>A7&fg 2Z`f k3>I&fg l= }/?L{4~V)(06;S` QSe`Jmvأ'06;S` QeN)(L{cfg6]n5P6;S`g՚ j3vvZ H6;S`g՚ yj3ZؑF[a0Kmv5i%6sfg Zؑf[a0Cmvή5i'6fg Z j3즺&# `vL]i)6sfg BHS6;S`B`G l ٙ;"^mv.4 Yi3v!vVIp`v= Hs6;S`B`G6ԫl=[ h3v!vVFp`/e i16sfg Bzٙ;d`+lf؅ؑ6[a0mv.4 Yh3v!vD`@;;n H6;S`B`G l ٙ;n`+lfg BHÁ^) !#-vmv.4 ʵٙ b׳ ٙ;"^mv.4 ٙ;z`+ljfg6W%](Cbmv.l @L] zٙ;"RT؅=T4mv.i3v!vD`/e8I) !#{%{)̦;;6 ^.p6;S`B`Gk3v!vD`0p6;S`B`Gj3Ůg- ؅!{L]؛G ؅%{Q̆kvH`o6p6;S`B`GqGh3v!vD`80\) !#{OL]{G fg Bޗ=t`6;S`B`Gvٙ;"d؅){ mvfÁ]HvD`w?0D) !#;=`6;S`B`Gv${@6;^zv"BЫ؅CЧ؅}@ mv.CGfg6iM`GAj3v!vD`=6;;"{d$8؅#{$mv.>C bmv.^c Bmv.~ك "mv.GL]Cd'fg B${<@6;];"QХ؅=PmvfÁ&%#{1L]؃e*fg B.{T6;S`B`Gh3>Fmmv.d,fg B>NMmvf]A{vD`){l&;S`B`Gj3v)vD`-{t&;S`B`G\k3v)vD` {|Z)K!# VL] 'adg R>M&;S`B`G\ ,c tK`GG,C`I`({nɢ>vؙ;"O=l:"## ֵؙ;"ϒ=h\)!#r}ސ$.Tp w沗oW,׋|zޖ]$.Uxw_>e8}[ײT|sY_wojo!G]! @ ;=׈<^/-\`eA;"K=(]᝹Be`Տ9H`GvѲG5+3sz?o/|s !;E]q @ '{OYG{U^ -!relJVxg> CW9^; |wIeJ`egA;"˗=(W)ϖ]! ATwfG*ֳ޲]OiN;"=(T)ϵ[{Lu2ޙ\A $=(R)ϵ{L ;EʮvD`#{P;S`+;>]A@q ݁A3ea;"=(L<*ˇ] K8,w_wv_ea;"+=(J᝹zqN{; C`Gvu:)3/iܿq=vD`'{P;s*)힛[C`GvG;(3w\/V-طewJQzg.׈Gdyo]=vD`){P;sy?Z 9-oeFؕ\¾wzz{Cvn]1@媐 ϝY\TG}cW _Va۟>=&Ma@:k8 >~=&M@::7^]v#[ W.e}2љv!vD`W/{% !#~٣]س=-p-t>]3=10:s_5Йv!vD`Z;"g.{v`R tf]س=?0:.˞ NA`B`Gv @gvh"aMȞ$;.FdOLbE`B`Gv+ 0p`/vqvdoE`B`GvC F7" !#)ٓ#gvi!#f$}gvj8"#5c}gv؅ݞ)̾3; BnQXfߙv!vD`7){`$N;"=o0wf;ݪ1̽3 BnWޙv!vD`,{\sn;"ۖ=pwf7]؍˞@8;;;ݼ93̼3;"ygŮ_0z- Pwf@`B`G6  ygv!vD`=pwf@`B`G6ײ'7 >`(ȞN8ڼ;3" !#  GwgFv!vD`%{J(̈.le)cޝ؅ͮYݙ]ɞVlޝ{`g`;"=0Ь;3$ !#Ns ̺3C;" d. 0 B&=k֝؅3 =fݙ!]=pЬ;34>t\^lzdO30Ό BWD@hΝ؅S 9wfL`B`G6dO6tsgf.s̘.lʞo7Ό;GpSfܙBٓfܙB(ٳ[fܙBHfܙBh37fܙ: 'ۙB$KCv!vD`s +=CcdS{~ ۙ4؋]A~؜%{h|;9vqW`I`Sĩv!vD`sãv!vD`3Ũf@fۙ Bf,S@fۙ Bf<ٓ@{fۙ8͘%̵3؅͸g&̵3؅ز&̵3؅g'v̵3؅'V̵3؅$'(F̵3o`g$#dOR-ig؅t)ig؅͔'*igh8~@;"X\0k3;"\l0c3 cjlͳ3B2,yggi8"#KɞhG`B`G6=o<;.l.*{yvfvAh;" `Vfٙv!vD`sq̲3{ B&C0^;"I=,;L;|<ؤɞf`O`B`G62ͱ3 B&WlP9vf?]ؤ˞*67>@`G6Ȟ5^#ٳ@fؙB@fؙBS@}fؙ2*6mȞj3.l =Te~9.lʓ=c~9.lJ=b~9;{*{:s]+{:s]ؔ,{(:s].{(:sv4;")_Pu0;"BPuK`IDAT0;"DPu0;"GPu0 #vD`S03́ŮOx=l*=ef9.l= cf9.lj=bf9.l*=af9;z*+{>7J`B`G6U˞ͫ3؅MgEL̡v!vD`Sy ϼ:svqd;" Ǭ:s0]F`V9.lf%{Yu`;"ifՙ,eϕ2N`B`G63=]\Ĝ:s8]W 09up;"I`bsG>!;"`J3#Bs'dfԙG؅MOį3 !#fdϠQgaV}t<l=n>y ]4&{"|:;"iO\ 0t1v!vD`Ӥ`$c)gMT1̦3" !#eϫgMgE`B`G6dOMgE`B`G6,dOMgeF};l=o.y]ذ!{8\:8;"a[\ ptqǼ3 =-`3#5؋]w"){d&y$]ɞvͤ34>$$!G p<:X;"G p<:X vYvD`s0@ytǶ gb=̣ Bd[fљG؅ ˞͢36>O`G6&{^XCgO`B`G6.{nCgO`B`G6){6<<;50ih :;"a,S5Тt v!vD`èk13"Wc ˞ߙ؅ ȞFߙh8>;"a:ٳ70w)'X6T+{f<.ly;$;"R's`̓ I =3S{gF`B`G6\\Hy]ؐ#{n%3O& !#*}<Tug>X+ u>.e3O' !#j}tJQsgN`B`G6T, 3OWw`5 1 l }Tܙgh8"#f#$3Pu`g+$#&\Ry]0Sه"sQ Y>3" !#Z}@Rmg>K`G64$C`G6#PcgeFc@!P ;s;"Sd ;sU8J}14e %-3Pc`gГ ,(M3GQa`g L"`3! !#CVm9;{lⲏt0#uHv!vD`{P:s$vD;@P:s,v;@IP:s4v:@P:sjqأi{L`Z]%9j{YL`I`- c3VK`O0q 1 lie4Utջoz}~7lYI`gOk # Йލ}-vD`% [*w>o ?a*;{c>Ӣ;?>wo'-k"vD`\@*3.ZbMo߲Ξs.C`G6@nwՓE)rznY~`gO+"#Xّ@̫akr';/_e=s\l*e'(3~i:o;{n$s\Rpby>oˢ;{_lVec(3זu`- A}i;"-Pfg]U=R/O`G6Ȯ6ؙ#y?pvD`PJMybwXZ=|˫rd e=9vqWe{Ld'tf{*_xWs+AV؟}-@<6y/K`P(4M˚,`FTA`Op#LD` o )=W'?o܁÷7WWᄆX%L^ذ4uj<%\F^qd'l QA`_j~m˨!k_]4;.Jl X_濺/[>3u8u/[pƫv;c[_~3P6SmkS-v3dO^~z_ذדf@㔧1?Ϛn\r'v_ Ý7Vv+wX>(oe/W_4sQA&1ܪ_XL8=)Yz~7@؍xy[QJxh\T dk_?+Q_~W_v߹4Ztd3Ǹ^bdaU^di7ۢީL oF=qj^Ov{zYei d㲔|w豛3nÝ-g.8h[ DVc0{c v&&,t[gqS 2N"I+Q(ׯwO6C,a+8%"•w<* 6C-G~?1مGAKvO<.asf.Jp=lyIonf2F`7aԀ9f1MW lWe0ͼ˿(Ơ :.`Ö_2ֶQAO C{[^+# rEٖ e^{lo5/ٟn0x Y.qlL/AVW>>SK9- 9_<I)vG x0-a}*C5aA@z pXW6=*l'9M?^_b^`7a|:Ine*!9cg9A%|ovoV}P쯜-)%"$۽h,oxmUKFE T~9ms-E[.T p[ ;h/O8cugZ}6>qy?rރfF<ټR;þs lZN8/\_PWJ9IѶ~{|ov#Vɻ\]+s"z lZٽ^˿{O3nzae=pUƩj!luv3*ט{;6í{5_-R7 nh,9K/7NOsM`7^]|^]Ć6_}aKi7Vy0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #0" #z;>xE']^_~Hz~q#K~- |}y΁s{j ;,o߹3N`/8G}|lp`Zq`P5"n@ 6sF kD?ЀV{W[H:{?Dg>G A`LoX){кk2\(:liw[]7*3[tVtGU3WK/^>?"lϿw_kQ`Nao}OrwpGq?{/nu>k[mbyf{];:TIl=Zz]G728뷁q_ߍٯ~y |O{[מy@_aopQ[oWo;m|Ύ]]#ʇv>Q$ζ,﹭AuwXJ3_ͅ~7;O߾x؇>*6e;5`AKDGm*.~?;mvr۟D;7w>5";7>kG 0% p&|c?_\VEזWGlym;\O^|0x;yO<||3?{zo|7{:l=kG 0% puY^/^%J!{SOqo`mqVsvp["rxϹq; / l=>'ur: 63CO{8z{q{'v^}}'// lmisf= ~#%W-ON츱֚xȣspmko&$ζWwv?],ɽ<]oV~]Zqߎ7;k[ݳܷurm 8͵ ]wX;P{{CAgF{mvC>GIݷ_g{';}<~K6xm-e=~Λv3;68 `BlyFHm`8v֫l_DٻkCw&$vJ`?uOmo~{66oAk/ lwϾǿtVeW}YeчvM`5g:؆&ۗ[kD^m]@ 6읨wWo؇s/l<,7׈t\xx׎ l- $g;7oη}7 x#.r.``}_`z^`x``>&=[)0! p3{+7o?io.7ط^~?зk{6 e5nn=n(tg~ޣl<4ož]ۺ=7/ lۡ|}{[znq= }o{lnٷ_g V`P`*ͭW|Ƿ 5"No׶Y38_ge m)>;|Q`l%~Í*_g;;F*~lWW? gko0^{޹ıvݹǿz~LG`mz}J7mW2 l l l l l l l l l l l l l l l l:AIENDB`bayestestR/man/figures/unnamed-chunk-7-1.png0000644000176200001440000017502614560763455020415 0ustar liggesusersPNG  IHDR `gPLTE:f:::f:ff!c!!!!!!!"c" c"c"d"""""""e"""""$c$c$$$$$$$d$$$333::f:::::::f:ff:f:f:::LPLQLQLRLLMMMMMnMMMnnMnMnMMPMPMQMRMMMNPNQNRNNff:f:f::ff:fffffffffffnMMnnMnnnnnnnnMMnMnnnMnȎ:ff:fffېېnMnff:fff۶۶ȎMȎnȫnȫȫې:ېf۶f۶۶۶n䫎Ȏȫccd d e c c d e!e! c d!d!e!PQRQRde cPQfȎې۶QRdeٜ) pHYs.#.#x?v IDATxݍm]s\SPڤ-)[%vW$mHR&21%LklZ=N{M1i+ ~(`Me!s޿y~k}|~M>}ag/psqտP pDQGlpDQGlpDQGlpDQGlpDQGlpD;8pw}_~e/.z]eϵ39 ?)EG~yaVeK/[/Z/.4P;?~ւ}2+Wܰ`_w{Ug,ؗ/ ^‚}uJ w{ҧrr '^;γO]^}uլV5ȳlNWM=R<{饷 ={O8qG`U7mӽlj8]7kRvG`KV%Խlj0 캗H 6, YU/a{< 0l{U6 3?V>4>/so<؉.O?ࠟzOKUOE_힇f@>NzߧW=K,O`^tx_T7>|~OSMsoǗoպ.{te,oܫ`OҐ{}ww͚^ƸXd+OTSoO;COy;xmwq;y1GupmZ[ w*֓4`EzYS+d  V?H i~w emJdW8X~_+Q6ܧ`Ow^~sƝFy6N-_<$V/ Krwmc.g`3y~}/o}7>wջ?_p__~ G<}o y'>`l] $-+.~MǾ)>ѱxIT4N[שW?: v^ |6-z]}YI:_nKb<+l{+.~[NK>hV|hT7w$<*<}ٓt`w:Ǚ+ A-WJ7/]M]?'~1`<! vMnN7mY}ٓt`w_>^e0Lx{>/?~{+?!{Vw&ֿ܍G,ا[vw;&# voQ' qq %Q^Zu譴{WtGѽi{hw/>O.7z>[/yn %wgJ^Q~%W!x.ֽM^c we+Y/8Sb`cվ/[w6}]ěy| 3%V/ vGՍȓo';e̝@vDv|3^$swgJ^7U\׮w쇟]}`dYW\~377N;l?r9~ و X$-؝>.n w;7mĞ{||zޓVF|xI]8f߶}'{b9{|}Av ޓVF{ xWW݃/9z#ꓫ+޶{O=i3}ַJ`_$ygB^uZդ߿dUR{{aU^ o=~Ο/GZ/} {3!V/ NZInHmSEjcw/pC³_o{;TK$W/xIV77DSwL}۲t;]뗂/Ƀ橃Ov}X/y|]l/D'O,ؗE_Xd*/vy1,+ӳo$ʴlQXXӶ|7Ixo S';}QO>f n*'#\$l+n{=vlvW^l_(zc̊{9 o}O:C %ON">\X$,؝kh?yk+\'wͷ/Y 3so?5 z wP?`h#c`?ܿj7t>sO^UN+wtW?a}ǟ`߽=}ɧrP?`xb`>|gwϼ'Ͻp_|窾=KZ>xUO?`AOn·}m=I?~R>elvt\z͔km:.\]8_ R#I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`X's> R#I (b7/F``*2+}F.Q"o^*KEUxeV0H\$10E߼U-ˬaHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;U8ˬaHb`D$y1,;[T=Y 5r"I~bTY v( {.҇Aj"E,ŨPlQ\fE#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ء.w \fE#X$͋Qe)ء(آ J$FHRCQEs> R#I (b7/F``*2+}F.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KupտN(2+}F.Q"o^*KEUxeV0H\$10E߼U-ˬaHb`D$y1,;[T=Y 5r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vpB=Y 5r"I~bTY v( {.҇Aj"E,ŨPlQ\fE#X$͋Qe(د|o޼#̩O~퉛{ދlQ\fE#X$͋Qg(؟VG{/޼2#I̋*r"I~bam?yOQX$1/E#X$͋Q G|ld>dAHb^T$FHʺE_]kY7?gɂJ/.3bļ"I (b7/F.V}/a/>eC>KTzq$EHb`D$y1wTTwoϿxUc>KTzq$EHb`D$y1wh@MsdAHb^T$FH:/'d8݋Hb^T$FH:?n>{w_ϒ^\f"yQE.Q"o^*\D&!|ۻ`hKy-_o]}~_~{N}޿xGu7xwܺu?[|y\{xpuw\Q>Ke AoS@sQMݽI>oӥq>u' t}}EU}~ ”5"o=.ם*؇W5"L/kD>GeZ/Zq&#> Z)G^7|lѥ򶃏`?k]?徲}]nYm?hҋ?u>Ï*2+}F.Q"o^| vϧNϒyc/.[eze_zW,߼)_|[>9 6> R#I (b7/Fɽʂmgɂ< ,_|u XG{eݯ8eUm6]sѦ?`aHb`D$y1Jn}쩋[/C/؛j~>._:U|M/?M s6oQqaHb`D$y1J /؟2/^`O]ܪ`QeK8d?:/u?ZһF n/_X}׬> WJk\zUv۟o~nߺU=Y 5r"I~b\炽Mc >K4uq|-_7/]# kD^n;݊ ηǭn~nծno>*Ot/+F}`>&?wks=o@rkb.2+}F.Q"o^B]z\}a IDATwȋ7/UϒM]ܺ`wY]!/_K?bGwY]!)ثR|_X;4󿾻|_/m?w~݂}߿toܿVܲU?Z{Ys?X.>޽;p\fE#X$͋Q M^+D:o.g?a ϒM]ܺ`wY]!/ػ"ݯGo|"˯XY^qBk`+|˾`K؛{?Ǫ`w; J$FHe~=Ǟ8z{[7rY5"=GץmoOsʦ`YvowV/u^^~u˟Uo 7n^^}?}Qޫӟ۶U~ˣoERxeV0H\$10E߼Uֽ`// {6D"m /Ks`wZu[C5"} ~囗Q^oYEEK݂}߷l_^a{~w~[6\fE#X$͋Qe Oo;|_>dAS)kD~[Ч [?gS׈|~ݜwo_·8,ث.ы/˫7{ҽ*2+}F.Q"o^*;C~xџ{vwwl~},h{w[w{[{wb?Ns`?/лkDosMUß?.ػ/]\+~g`3ZJ$FHQY?\N`ymʶ"og`[7.}`WM݂yas=(> R#I (b7/F`mm N_>Mۂ[^_Ro.]^ 5r"I~bTY v)߿-ثZ}҉ ׷VWW~-Ԃ )g9 uP0H\$10E߼Uʭ`Ⱦ`_!3lj{ݑwwo;sjmQ`o;rۿh_J$FHRC5"ݿu\wcqb^_#[ǓqWNO.o_'(D`WV0H\$10E߼Uʭ`y۶< v!+_5{}wU%>`>{灃w-tf(U> R#I (b7/F`}^o{U޽=`/_x`tf}Bd>?`Mzz/a^~]%` qnF2O)ؕ> R#I (b7/F`}5!ۂ+D6{٫͍?6K m¶I>#%"~}_oz{i2w߱˿}}-> R#I (b7/F`NRכGWl>,ݓ 'oce^_xM ^/ R#I (b7/F``*2+}F.Q"o^*KEUxeV0H\$10E߼U-ˬaHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;U8ˬaHb`D$y1,;[T=Y 5r"I~bTY v( {.҇Aj"E,ŨPlQ\fE#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ءJ/.3bļ"I (b7/F`*̈E\$10E߼U2#I̋*r"I~bTY vҋˌX$1/E#X$͋Qe)ء.w \fE#X$͋Qe)ء(آ J$FHRCQEs> R#I (b7/F``*2+}F.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨPHb^T$FHRC^\f"yQE.Q"o^*KUzq$EHb`D$y1,;TeF,U"E,ŨP1{UE=Y 5r"I~bTY vŽkˬaHb`D$y1,;Tfv{.҇Aj"E,ŨP/͇}* J$FHRCͿ8 (\fE#X$͋Qe)ءf_QaRxeV0H\$10E߼UbaΟ__(2+}F.Q"o^*Ku5{e·ͯˬaHb`D$y1,;l*e J$FHRC]ia J$FHRCͼz_iئ{.҇Aj"E,ŨPs/La[ J$FHRCͽsm(2+}F.Q"o^*K5li\fE#X$͋Qe)ء^M>ˬaHb`D$y1,;;ۯi's> R#I (b7/F`qg5 {.҇Aj"E,ŨP/n@a+2+}F.Q"o^*K5}ˬaHb`D$y1,;A>ٯiG J$FHRCͽu}>WiG J$FHRCͼ ݯ) J$FHRC],ӿ:`Ӱ J$FHRCZwyHas> R#I (b7/F`*4{.҇Aj"E,ŨPJQxeV0H\$10E߼UjM+2+}F.Q"o^*K5(s> R#I (b7/F`sqSxeV0H\$10E߼UjuzM*2+}F.Q"o^*K5(Ss> R#I (b7/F`qq 6 {ˬaHb`D$y1,;|憂M^+2+}F.Q"o^*K5(ؓs> R#I (b7/F`oqc 6 {ˬaHb`D$y1,;luf v{.҇Aj"E,ŨP-n|a/s> R#I (b7/F`kqVis*}F.Q"o^*Ku0ϥ`OTxeV0H\$10E߼UJ`Ӱ9D> R#I (b7/F``ւMT0H\$10E߼U-ˬaHb`D$y1,;LZi؅\fE#X$͋Qe)ءYa]`7+2+}F.Q"o^*K5k߰ J$FHRCͳ8}v=Y 5r"I~bTY vYwT) J$FHRCͲ8}v=Y 5r"I~bTY v9wܕ) J$FHRCͱ8}v=Y 5r"I~bTY v9GvPxeV0H\$10E߼Ujykݰ J$FHRCͰMݬˬaHb`D$y1,; +׹as> R#I (b7/F`Xpl\fE#X$͋Qe)ء 5n؅\fE#X$͋Qe)ء LnVxeV0H\$10E߼UJ`_߆]xeV0H\$10E߼Uql\fE#X$͋Qe)ء[m.2+}F.Q"o^*K徸-ݬˬaHb`D$y1,; um؅\fE#X$͋Qe)ءGQxeV0H\$10E߼U}q6{.҇Aj"E,ŨPދ;ݑ) J$FHRCy/n}=v=Y 5r"I~bTY v(Qs> R#I (b7/F`^Z6{.҇Aj"E,ŨP΋32Y=Y 5r"I~bTY͂a)W*(ء.< 0fy^в`; oE=Y 5r"I~bTY v(߂m6{.҇Aj"E,ŨPlQ\fE#X$͋Qe)ء|GvSxeV0H\$10E߼Uwqװ J$FHRC.άf\fE#X$͋Qe)ء\7cv ˬaHb`D$y1,;(~ J$FHRC.ˬaHb`D$y1,;vP[.2+}F.Q"o^*K8 {.҇Aj"E,ŨP`_]xeV0H\$10E߼UsqlG\fE#X$͋Qe)ءwI7`7+2+}F.Q"o^*K常 j؅\fE#X$͋Qe)ء.~S=Y 5r"I~bTY v(}Y5)תas> R#I (b7/F``*2+}F.Q"o^*K`_]xeV0H\$10E߼UoqlW\fE#X$͋Qe)ءQQ.2+}F.Q"o^*K8 {.҇Aj"E,ŨPnSs> R#I (b7/F`r[\L> ˬaHb`D$y1,;(ؾ J$FHRC-.`_]xeV0H\$10E߼Umql_\fE#X$͋Qe)ءUK.2+}F.Q"o^*K嵸K1Y=Y 5r"I~bTY v(Qs> R#I (b7/F`Z\\& ˬaHb`D$y1,;łϡ`;+2+}F.Q"o^*K`_]xeV0H\$10E߼U-ˬaHb`D$y1,;S>S} h؅\fE#X$͋Qe)ءGVxeV0H\$10E߼Uiqlo\fE#X$͋Qe)ء[C.2+}F.Q"o^*K8 {.҇Aj"E,ŨP>;W 5h؅\fE#X$͋Qe)ء|GvWxeV0H\$10E߼Ugqlw\fE#X$͋Qe)ء|^7{.҇Aj"E,ŨP>`+2+}F.Q"o^*K峸]as> R#I (b7/F`rY6LnVxeV0H\$10E߼Ueql\fE#X$͋Qe)ء.&(v=Y 5r"I~bTY v( {.҇Aj"E,ŨPlQ\fE#X$͋Qe)ء ˬaHb`D$y1,;wa v{.҇Aj"E,ŨP]as> R#I (b7/F`X{\fE#X$͋Qe)ء<GA=Y 5r"I~bTY v(]U.ݰ J$FHRC9,n@`7+2+}F.Q"o^*K尸+ؕv=Y 5r"I~bTY v(QPxeV0H\$10E߼Uaq9s> R#I (b7/F`rX ˬaHb`D$y1,;(s(2+}F.Q"o^*K5}qCz0Y=Y 5r"I~bTY vi?J v݆]xeV0H\$10E߼U-ˬaHb`D$y1,;T]as> R#I (b7/F``*2+}F.Q"o^*K5}qYs> R#I (b7/F`A-xƂ]as> R#I (b7/F`8 < J$FHRCM^ܕ ˬaHb`D$y1,;QQxeV0H\$10E߼Uj((2+}F.Q"o^*K5uq:f.2+}F.Q"o^*K5uqs> R#I (b7/F`8 L J$FHRCM]B.ٰ J$FHRCM]{&\fE#X$͋Qe)ء.N`Wl؅\fE#X$͋Qe)ء.|?{&\fE#X$͋Qe)ء(آ J$FZk$ IDATHRCM, `.2+}F.Q"o^*KEUxeV0H\$10E߼UjT v]xeV0H\$10E߼Uj(s)2+}F.Q"o^*K5qqs> R#I (b7/F`8]as> R#I (b7/F`8 \ J$FHRCM\{.\fE#X$͋Qe)ء-nh (v=Y 5r"I~bTY vi`ϦˬaHb`D$y1,;Դ)b ˬaHb`D$y1,;Դ f\fE#X$͋Qe)ء-nh`7+2+}F.Q"o^*K5mqCoHհ J$FHRC],՗ݬˬaHb`D$y1,;Ԥ=Rs> R#I (b7/F`TK5{.҇Aj"E,ŨPlQ\fE#X$͋Qe)ء&-np`7+2+}F.Q"o^*K5iqoP԰ J$FHRCMZKnVxeV0H\$10E߼Uj_ v{.҇Aj"E,ŨP7FB ˬaHb`D$y1,;Ԕ f\fE#X$͋Qe)ء,nx +uv=Y 5r"I~bTY v)^{) J$FHRCMYKnVxeV0H\$10E߼Uj޸]as> R#I (b7/F`᭗ݬˬaHb`D$y1,;Ԕ of\fE#X$͋Qe)ء.F~kC ,Uv=Y 5r"I~bTY v( {.҇Aj"E,ŨPlQ\fE#X$͋Qe)ء" ˬaHb`D$y1,;Ԅ5t^ v{.҇Aj"E,ŨPy) J$FHRCMX\C -5v=Y 5r"I~bTY v kf\fE#X$͋Qe)ء/Rs> R#I (b7/F`4{.҇Aj"E,ŨPx) J$FHRC_\K`7+2+}F.Q"o^*K5~q-7`Wh؅\fE#X$͋Qe)ء/Rs> R#I (b7/F`KnVxeV0H\$10E߼UjZ ot.а J$FHRC],ƦKnVxeV0H\$10E߼U-ˬaHb`D$y1,;Tтas> R#I (b7/F``*2+}F.Q"o^*;G~c?|yg.o~>K4zqMuݬˬaHb`D$y1 O\{ُS[4as> R#I (b7/F//I>zݢRs> R#I (b7/Fu/_{bg?׌Zp `mmݬˬaHb`D$y1{V_˪mt=Anv`go؅\fE#X$͋Qe :o/ yz {ݤRs> R#I (b7/F.؟e1 vKnVxeV0H\$10E߼Uֻ`ۛ?zD^6>dAcVv`'o؅\fE#X$͋Qe vEok7^~[{gɂ.Rs> R#I (b7/Fu.[w"Oj7E[ץ`7+2+}F.Q"o^*\GE^~`=_{%Wh/׸P4V] 6/؝Be`ts], #RNt\ BnXu)Wgւ}|~k> ZXu`3{.҇Aj"E,Ũ`/зqAcӥ`7+2+}F.Q"o^*= 56+*ؙv=Y 5r"I~bT`qo vƢKnVxeV0H\$10E߼UvwrOϸ[x/[\kѥ`7+2+}F.Q"o^F\/LJM֢{U;q.2+}F.Q"o^B]/Zo$ˬaHb`D$y1 w^f)\=\kϥ`7+2+}F.Q"o^*]yӪ]Z{ ˬaHb`D$y1{^G󙻯|^`7hf\fE#X$͋Qe +;/CRs> R#I (b7/F/w?Ħ^?G([Zs`m؅\fE#X$͋Qeg(w_/_yϮRS-Rs> R#I (b7/F`OdAr) J$FHRC],Wk˽‚as> R#I (b7/F`UK.Y=Y 5r"I~bTY v( {.҇Aj"E,ŨP v҆]xeV0H\$10E߼Uj;.Y=Y 5r"I~bTY vQkf\fE#X$͋Qe)ءF-^iٰ J$FHRCZ\sť`7+2+}F.Q"o^*K5jqݬˬaHb`D$y1,;Ԩ5Wܫ-)v=Y 5r"I~bTY vQknf\fE#X$͋Qe)ءF-Rs> R#I (b7/F`{;c.2+}F.Q"o^*K5fqݬˬaHb`D$y1,;Ԙŵ\ v{.҇Aj"E,ŨPc^p`'l؅\fE#X$͋Qe)ء.ZRs> R#I (b7/F`&;_.2+}F.Q"o^*KEUxeV0H\$10E߼U-ˬaHb`D$y1,;Ԙŵ۫/v=Y 5r"I~bTY v1kof\fE#X$͋Qe)ء,Rs> R#I (b7/F`V`gk؅\fE#X$͋Qe)ءF,nD`7+2+}F.Q"o^*K5bq#-Y=Y 5r"I~bTY vQn v]xeV0H\$10E߼UjFt[ v{.҇Aj"E,ŨP#7Rs> R#I (b7/F`V`j؅\fE#X$͋Qe)ءF,nD`7+2+}F.Q"o^*K5bq#-Y=Y 5r"I~bTY voQm5 v]xeV0H\$10E߼Ufy2=s> R#I (b7/F`j/cHkM=Y 5r"I~bTY vT?Q.2+}F.Q"o^*Kվ1V`hgI=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7*~ݰ J$FHRC/nL('t.2+}F.Q"o^*Kվ1햂ݬˬaHb`D$y1,;Tƴ[ v{.҇Aj"E,ŨPn) J$FHRC/nL}_SѨaHb`D$y1,;T۫/ؼ E#X$͋Qe)ء7Rs> R#I (b7/F`j^ܨvKnVxeV0H\$10E߼Uyq-Y=Y 5r"I~bTY von 6E#X$͋Qe)ءO>n3=> J$FHRCQEs> R#I (b7/F`Fa:)2+}F.Q"o^*KռQV`5QT0H\$10E߼UyqHT왞N?\fE#X$͋Qe)ء7왞MG\fE#X$͋Qe)ء7Rs> R#I (b7/F`j]ܸ^KnVxeV0H\$10E߼Uuqz-Y=Y 5r"I~bTY vōf\fE#X$͋Qe)ءZ7Rs> R#I (b7/F`j]ܸ^KnVxeV0H\$10E߼Uuqz-Y=Y 5r"I~bTY vōf\fE#X$͋Qe)ءZ7Rs> R#I (b7/F`XhqV`uM=Y 5r"I~bTY v( {.҇Aj"E,ŨPlQ\fE#X$͋Qe)ء ^Wv=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7Rs> R#I (b7/F`j\^+Xv=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7Rs> R#I (b7/F`j\^Xv=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7Rs> R#I (b7/F`j\^+Yv=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7Rs> R#I (b7/F`j[^Yv=Y 5r"I~bTY v_=Rs> R#I (b7/F``*2+}F.Q"o^*KEUxeV0H\$10E߼UZl]xeV0H\$10E߼Umqc{-Y=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7תl]xeV0H\$10E߼Umqc{-Y=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7l݆]xeV0H\$10E߼Uiq{-Y=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7Rs> R#I (b7/F`jZ^[ev=Y 5r"I~bTY vōf\fE#X$͋Qe)ء7Rs> R#I (b7/F`Xţ{pVm؅\fE#X$͋Qe)ء(3>Ss> R#I (b7/F``NQxeV0H\$10E߼U-ڰ J$FHRC,n|`7+2+}F.Q"o^*Kղ񽖂ݬˬaHb`D$y1,;TZ v{.҇Aj"E,ŨP-k f.2+}F.Q"o^*Kղ񽖂ݬˬaHb`D$y1,;TZ-ٰ J$FHRC,n|`7+2+}F.Q"o^*Kղ񽖂ݬˬaHb`D$y1,;TZذ J$FHRC,n|`7+2+}F.Q"o^*Kղ񽖂ݬˬaHb`D$y1,;TZ-ذ J$FHRC], ݬˬaHb`D$y1,;{ex{.҇Aj"E,ŨPY1 J$FHRCQf}(2+}F.Q"o^*Kհ ݬˬaHb`D$y1,;T&Z-װ J$FHRC5,nB`7+2+}F.Q"o^*Kհ ݬˬaHb`D$y1,;T&[as> R#I (b7/F`jX܄^KnVxeV0H\$10E߼Uaqz-Y=Y 5r"I~bTY vM X.2+}F.Q"o^*K5|qSz-Y=Y 5r"I~bTY vዛk) J$FHRC _ܔ^`k5{.҇Aj"E,ŨP7Rs> R#I (b7/F,e], )6G*Pyj+Y}^,þrJMR}s> R#I (b7/F``wT)2+}F.Q"o^*K5|qSzm԰ J$FHRC _ܔ^KnVxeV0H\$10E߼Uj,[as> R#I (b7/F`)ݬˬaHb`D$y1,;Mf\fE#X$͋Qe)ء/nRMSuv=Y 5r"I~bTY vk) J$FHRC ^ܤ^KnVxeV0H\$10E߼Uj&<[as> R#I (b7/F`IݬˬaHb`D$y1,;Mf\fE#X$͋Qe)ء/nRMTUv=Y 5r"I~bTY vA_8Rs> R#I (b7/F`` ˬaHb`D$y1,;@\fE#X$͋Qe)ء(Gf~*2+}F.Q"o^*K5tqz-Y=Y 5r"I~bTY vkSl]xeV0H\$10E߼UjZ v{.҇Aj"E,ŨPC7Rs> R#I (b7/F`i6Wh؅\fE#X$͋Qe)ء.nZ`7+2+}F.Q"o^*K5tqz-Y=Y 5r"I~bTY vkl]xeV0H\$10E߼UjZ v{.҇Aj"E,ŨPC7Rs> R#I (b7/F`i6[h؅\fE#X$͋Qe)ء.nZ`7+2+}F.Q"o^*Ku0&Z v{.҇Aj"E,ŨPf)2+}F.Q"o^*KE>m'{.҇Aj"E,ŨPl\fE#X$͋aO IDATQe;[ogɂ.nb`7+2+}F.Q"o^*{`ĩ7dA7Rs> R#I (b7/FR/.nם0>K4pq{m‚} ˬaHb`D$y1찂pc,YMf\fE#X$͋Qe_?ԟYk) J$FHuG~٣?dA7f,Wܰ J$FHMߝ߱7".Yk) J$FH=~`dA7Rs> R#I (b7/Fmy޿؏{>% 6eچ]xeV0H\$10E߼UyR9dA7Rs> R#I (b7/Fmw{7Yak) J$FHʶE\=?dA7,Wڰ J$FHʶ-V8;,Y);US{-Y=Y 5r"I~bT٦̮]سzR6,Y?{.҇Aj"E,Ũ Kko79㓪i>KDϿˬaHb`D$y1O]w}}3dA J$FH)؝X|7ʔ*}ϒ [^KnVxeV0H\$10E߼U|vݗo`76k†]xeV0H\$10E߼Ul^v5!Oj,YаMf\fE#X$͋Qel}p vak) J$FH*['~d7LYAkk؅\fE#X$͋Qe,%s)% ɽݬˬaHb`D$y1숷JdA7Rs> R#I (b7/FY<{xCW>K4hq{mނ}e ˬaHb`D$y1KDC܉o,YРMf\fE#X$͋Qe᭮ϒ Z^KnVxeV0H\$10E߼Uj&v=Y 5r"I~bTQ 87Rs> R#I (b7/F5 K|heF<Ա~tc̝ɽݬˬaHb`D$y1 SzwY Y)PxeV0H\$10E߼U.HzHݽH>+  J$FH^r {ٹR,YN(2+}F.Q"o^*{93?rȳ}uϒ Y^`_M.2+}F.Q"o^*;."Y!k) J$FHRC Y^KnVxeV0H\$10E߼Ul^^(>y8% 6w]xeV0H\$10E߼U| >K4dq{-Y=Y 5r"I~bTY v!k) J$FHZ'~>?N08M U4{.҇Aj"E,ŨVm~3ϒ Y^KnVxeV0H\$10E߼UjZ v{.҇Aj"E,ŨPC7Rs> R#I (b7/F5 ;z_㔇)# Y^`_A.2+}F.Q"o^*]DB XC`7+2+}F.Q"o^*K̗8Z v{.҇Aj"E,ŨPaB*2+}F.Q"o^*KE&${.҇Aj"E,ŨPaB*2+}F.Q"o^*V| 7)y% 8^`7{.҇Aj"E,ŨC 3sy&o}ދk) J$FH(\4Wzr63^/dAk) J$FHʞ// 7r|G6,YЀ9;as> R#I (b7/F=[o5!g1;݋k) J$FHʞ-O4U~ܧJdAk) J$FHʞ-On_ŶW?5U>K4`qݬˬaHb`D$y1칂qO׷Y9o$dAk+]xeV0H\$10E߼U\^^nի CֵzY/Ysf\fE#X$͋QeuM=y;as> R#I (b7/F^`SG;8^KnVxeV0H\$10E߼Uvp^]i\=yZ v{.҇Aj"E,Ũqw)c,. ^[`6{.҇Aj"E,Ũgoӷ%So\odA1s> R#I (b7/FF3]!.x( b"Y+2+}F.Q"o^*{`X}s_!Rw/R[dRxeV0H\$10E߼Ul^_|~{~3[cgɂ/ΣRs> R#I (b7/F=_w {Scߘ{ R#I (b7/FR^~dAk) J$FHʶ>Kt~qݬˬaHb`D$y1,;y2;as> R#I (b7/F`:8^KnVxeV0H\$10E߼U\zmְ J$FH,~|x?uYsu 0B 5r"I~bT!w\[L|,\zm}k`aHb`D$y1쀂=Ź"֭]xeV0H\$10E߼U|~d`rvq.Fuh`aHb`D$y1ق}{{= \z-Y=Y 5r"I~bTٳ{[wgɂ(؃Yv=Y 5r"I~bTs% `u_ٰ J$FHʞ+_>WY Plt$FH)7~ί:dAgk)#gc҇Aj"E,ŨC v"uŹZ `aHb`D$y1k)n.Υ('9gc҇Aj"E,Ũ"5^.Υ(ؼ E#X$͋QeNy0% :8^K|?> R#I (b7/FN/a,YйZ `aHb`D$y1}ɋv̓,YйZ `aHb`D$y1쀂~3_'=gɂ-ΧV(ؼ# E#X$͋Qe쯿.N">Ktnq>D>n3OHE#X$͋Qe췟q-ΧRG3OHE#X$͋Qe)ء-Χ(؇ {`faHb`D$y1KDNy=¹"qOS 5r"I~bT!gɂ_y^[`w*s> R#I (b7/F``לJ$FHRCQl WˬaHb`D$y1,; z+}F.Q"o^*Kunq>="#> R#I (b7/F\/al'?O_ş=nԘ%c4>{N`o?4| {'F}K`Ou-`0M{,S1HXbaL1K} *l`obӛ ψ'׷ilD][3v;Y 5b1X,%Hs;|}O;מᄡ7'>g'OȆNԵݱP 5b1X,%Hs;~n5=m{_,Q Ȑz\C`oz-ڢMa. KKӁm`ї?M`؇l%|%ߺK?!s-{ݟo`RعM`ע c;Y 5b1X,%ܳ8Kρnf.K?JȆNNSX 5b1X,%ܳrSO?*}N`}#:}8Mv]eV1HXbaL1K} "l` ~?{<6`o͑ >$j' oJ?1K,)bI/A_i|s?9O0@' Ei[cҏAj cXK^9;~'_> +v.|2+\,0%ݾ{I`~ٽ~5|7aIDsdCh {`ZθB 5b1X,%.UO}qA?#r_$״7' >A9ӇS4`0~g\cs˜b,t񅁽O iǼ~߅ȆNN[Qas~ Rc.XSŒn_ __x '~wG_~_gMŗO|l͑ >E{^06/R1HXbaL1K} R\` {9 hlh^_ ߹J?1K,)bI/Aʞ<377|}bklg"v;Y 5b1X,%HٓxUHkzȆN=ˬcs˜b,t~)_|~ڞ>9!{nR؅\fԘ%cۗ eOC_?yoʉ96g wŕJ?1K,)bI/AƁƃ_g7^ѧhl']qҏAj cXKq` Ɨ_O_Чil'Eas~ Rc.XSŒn_ {쉾~(#9f 7ŵJ?1K,)bI/Aʆ^Q7i)l͑ <ܕ5^0)U1HXbaL1K} R6 oO]YϪv.|2+\,0%ݾ)s w{D|KhlᮋO\cs˜b,t?HaklᮋO\cs˜b,tl؛x2~>͑ KsdC7{`= W1HXbaL1K} Rvn`|˾?h5G6nqN  rԘ%cۗ eg_wPx :eu}}as~ Rc.XSŒn_r}~{pt `0hcs˜b,t4kok}D4G6nqN!  ~ Rc.XSŒn_0۸!< ߹J?1K,)bI/A^؟~&?0]sdC'{` B 5b1X,%H}ϒ9IsdC߀8Aسs~ Rc.XSŒn_];=}eas~ Rc.XSŒn_]/| E4G6D`C`[ 5b1X,%H;!O4G6D`C`[ 5b1X,%Hً᷺nhl(< ߹J?1K,)bI/A][Sm~ Rc.XSŒn_]˄[SWv;Y 5b1X,%H0?[wt>Dt:^0kH 5b1X,%H+ޜimRPt:^0kH 5b1X,%H8Fz'Dp tJ.|2+\,0%ݾ){3W# C#@' s0Z)\,0%ݾ){/9w~K>eLOPt:i}Eas~ Rc.XSŒn_]]DPt:^0hcs˜b,t,Ut:^0hcs˜b,t|P'lȆ-.I ]eV1HXbaL1K} R|`9p t`0GN 5b1X,%HYw`:ˬcs˜b,tl/Ӈ-~Dp:^0+'J?1K,)bI/A][rhcs˜b,t,Up:m偽 ߹J?1K,)bI/AʞI'8@ sh@ 5b1X,%HYHWO^P؅\fԘ%cۗ e yu+\,0%ݾ)K`wE`C`[ 5b1X,%HY+{= ߹J?1K,)bI/A][~+\,0%ݾ){'9nXc#IKLnqم]eV1HXbaL1K} R~b}> v Ԙ%cۗ e 쮦?6]C 5b1X,%HY-= ߹J?1K,)bI/AʞIHG~Ӈ[ܟcs˜b,t,E-M`P1HXbaL1K} Rjp3@`? ߹J?1K,)bI/A]Mnq J?1K,)bI/A]Mnq썙MJԘ%cۗ e 쮦?& ҏAj cXK˿sC~M#͑ Mnq썙MJԘ%cۗ e/ |b;` ͑ mw3@`oL;Y 5b1X,%HKO*Ȇyu+\,0%ݾ){A`яq|O-| y 9]eV1HXbaL1K} R|`꾯_߼_d`/}o` ߹J?1K,)bI/Aʞ _~;OF>~}E9-}o`tCL 5b1X,%Hٳ6w`MW~]B9-``SJ 5b1X,%Hٳ3wk͑ Mnq~Fs#2TJ?1K,)bI/Aʞ 헫xȆ&8?#9N*Ԙ%cۗ eGǏF"#<؏f F9f~ Rc.XSŒn_$Zz4G64y!r)\,0%ݾ){GDl-H ҏAj cXK%`o>"ilhp1B`?|09Ccs˜b,tEߦ0[JsdC[\僑Ԙ%cۗ e$o}Oc~v`D 5b1X,%HF}j5~TR[^ŃԘ%cۗ e?G/z͑ Mny=F|ۈ؋MNЎ)gnXcs˜b,tEߦ>?yxrf0톎J?1K,)bI/Aʞ MV'͑ MNю)gnXcs˜b,te?*~KoY#8ؓNԱT 5b1X,%Hٳ雛OCدo<}l͑ MNҎIpXcs˜b,td퇯_|lDsdC>{;*\,0%ݾ){>?$ρ u4vr0-ǎJ?1K,)bI/A^ط|`ۧʼniq=`Z ~ Rc.XSŒn_$oo_Ҹi훛O~~>KsdCӴ;pj0MeJ?1K,)bI/A^ػ^!4G6t|8Q:!vXcs˜b,tAsdC(؁x0\fԘ%cۗ e yāv;Y 5b1X,%HY+{{J?1K,)bI/A^/#u"=:.|2+\,0%ݾ){Y`C]<>,wءx0GJ?1K,)bI/A^}?{S9qzXcs˜b,tk7^C#:>,wرp0gJ?1K,)bI/Aʞ_+~v>kؚ#:>.رp0gJ?1K,)bI/Aʞ _~;OF>~mC9 |cs˜b,t~oӻ_&+_.Ot>!LcҏAj cXKgg~9#:>0'Di?|V1HXbaL1K} R\`o\Ń_|5G6t|8a:>!O acs˜b,t| HDsdCLJS#`0J?1K,)bI/A^G-=J#:>2'M1S 5b1X,%HK>"B`NZ쓦ecs˜b,tE3؛4>}#::اM,Ԙ%cۗ e/6}1=R#|ý_Жs~ Rc.XSŒn_=q=[KsdC<~ Rc.XSŒn_=ov)^G/E`&' ˬcs˜b,tlؿ*~?Ao9!{{J?1K,)bI/AFi^ywYprG`31^W3~ Rc.XSŒn_{%.-cs˜b,t,E`u ^mؚ#:<\p$/s0)\,0%ݾ){I`O}Ȇ"  =eJ?1K,)bI/A^/zSf^mSfn vsp$/;w.ҏAj cXK?yXۯakl^ҏAj cXKMgE^§=O-w.ҏAj cXKgk|gW>Jhl^ҏAj cXKgׯK| %i#:<\p$/;W(\,0%ݾ){6qפ4G6tx6H`_hw0.P1HXbaL1K} R\`oᅣ9jlpm`W1HXbaL1K} R\`o>}y_Td#}t 8cs˜b,t,d#}t 8cs˜b,t,d#} 8cs˜b,t%>!Q3#:<\j$/<g~ Rc.XSŒn_廈tupFH`_i0#(\,0%ݾ){>/ilp`F\Q1HXbaL1K} Rl`o?#ʟ^k wpq0CN+\,0%ݾ){6^}4vݻxpFH`8!~ Rc.XSŒn_=O\o៛~]<8\f$gx̐J?1K,)bI/A^ط߼9>AsdCFH`ϱD;Y 5b1X,%HKS>݄Ȇyu+\,0%ݾ){Q`߾'7nilG`o ˬcs˜b,te7~|m;_DsdC<~ Rc.XSŒn_=b#:8\b$ҏAj cXKWs%95 F{_*\,0%ݾ){яJ/95 F{_*\,0%ݾ){.W KilpT 5b1X,%HK#U4G6tpFH`gcs˜b,t~U-tpFH`cs˜b,tE>͑ U.sy*\,0%ݾ){{WmD4G6VH`VeV1HXbaL1K} R4A_[-9õE{w.ҏAj cXKg{ MȆת ޹J?1K,)bI/AʞL5Z"=_;Y 5b1X,%HYõE{w.ҏAj cXK|Dd' 6O* ] J?1K,)bI/A^=nԘ%cۗ e y:6mcs˜b,t,=nԘ%cۗ e * E] J?1K,)bI/A]U)؋~ Rc.XSŒn_=ؿ?|m˟8EsdCkU"Ԙ%cۗ eO?]?a>9õ*E{qJ?1K,)bI/Aʞ_2҂>CsdCk2~ Rc.XSŒn_Wt㧵 }Ȇ,  L)\,0%ݾ)aEmD95D{7SJ?1K,)bI/Aʆ<g?:jlhp:^jҏAj>KB IDAT cXKa`| 뺂>CsdC{kR&~ Rc.XSŒn_ {OۯgȆ, ^ L(\,0%ݾ)8|ݽnMsdC{kb~ Rc.XSŒn_=ػ y뇰5G6wfH`/6nX 5b1X,%H(7 w^milhЬ ^)\,0%ݾ){i`4G6D`C`[ 5b1X,%HY+{Ma;)\,0%ݾ)K`wE`C`[ 5b1X,%HY5kD o~ Rc.XSŒn_%;\F$1z@ 5b1X,%HY5KD~ Rc.XSŒn_%=\D$2`O 5b1X,%HYõ+D*#/~ Rc.XSŒn_%=\B$3`W 5b1X,%HYõ D:#ov~ Rc.XSŒn_='5m͑ ] yCcs˜b,t,"}W;J?1K,)bI/A]]WyEcs˜b,t,!}wJ?1K,)bI/AF>[?UW͑ ]yGcs˜b,tlcilhnF^<)\,0%ݾ)K`wE`C`[ 5b1X,%HY+{{J?1K,)bI/A] l B 5b1X,%HYõCz#o ~ Rc.XSŒn_%=\8$F^<(\,0%ݾ)"?ޟx/o[#9\6$+\,0%ݾ) yo|e#9\6$^l~ Rc.XSŒn_/_{_?!1/b1X,%bu`w>#nzU zs˜b,tT8y g{4G6saH` +|1K,)bI/Aw_\w~\Ȇvװ lw/b1X,%\q`-ƃtg{ϴ2rsv!2w#Ul$읯JKq``*r؛x l[z[@NM;ȶo!r[<e:cڕ~ Rc.XSŒn_ɾ{2 leJ?1K,)bI/A o /kZ&!4Ƭ[ 5b1X,%HYu`o?~8n>]|>\$$^U+\,0%ݾ)Bgn{ײ lWfJ?1K,)bI/A{o|~/`o>4r!Z!5άY 5b1X,%HYy`oH"-ꟽ8ԶȆ2 lwfJ?1K,)bI/A\o_y H'Z!-6ҬX 5b1X,%}O؛O;oS$^+\,0%ݾ1"9!{)\,0%ݾ)K`wE`C`[ 5b1X,%HYn{VԘ%cۗ e 쮞״ lfJ?1K,)bI/A]=i z/J~ Rc.XSŒn_%z:\$_*\,0%ݾ)K`wt1H`70S 5b1X,%HY5mA7gJ?1K,)bI/A]=i - :T1HXbaL1K} RpMSnaYҏAj cXKvWOkv~ Rc.XSŒn_%z:\$|w֨cs˜b,t,ᚖ ˳BԘ%cۗ e 쮞4 6_*\,0%ݾ)K`wt!H`72O 5b1X,%HY;hځv#o~ Rc.XSŒn_%"1 l ҏAj cXKvW6 VFߟ)\,0%ݾ)K`wE`v_Ԙ%cۗ e ׶ fF_)\,0%ݾ)K`wxH`3K 5b1X,%HYõ@7h]J?1K,)bI/A]=m BR1HXbaL1K} RpmnhZҏAj cXKvWkۀvKК~ Rc.XSŒn_%z<\$[}֤cs˜b,t,& K"Ԙ%cۗ e ׶ F_)\,0%ݾ)K`wxH`5G 5b1X,%HYõ @ѷh=J?1K,)bI/A]=m؍FQ1HXbaL1K} R/Z5kԘ%cۗ e yLcs˜b,t,=nԘ%cۗ e y\cs˜b,t,苴Ԙ%cۗ e ׸Fߤu(\,0%ݾ)K`wpG`7&C 5b1X,%HY5?WiJ?1K,)bI/A]=qJP1HXbaL1K} Rpۏa]ZҏAj cXKvWk~v~ Rc.XSŒn_%z8\#}Vcs˜b,t,˴Ԙ%cۗ e ׸>FߦJ?1K,)bI/A]=q}M~ Rc.XSŒn_%?\#;}+\,0%ݾ)K`wusnԘ%cۗ e yncs˜b,t,=nԘ%cۗ e yu+\,0%ݾ)K`wuG`w3BW1HXbaL1K} Rpg􍪭cs˜b,t,ZGU[ 5b1X,%HYõ>WҏAj cXKvWk|vGTiԘ%cۗ e ׺FߩJ?1K,)bI/A]u=S~ Rc.XSŒn_%?\#} +\,0%ݾ)K`wuG`w5RV1HXbaL1K} Rj{G`5VU1HXbaL1K} Rj{G`5VU1HXbaL1K} Rj{G`w6ZU1HXbaL1K} R}9{J?1K,)bI/A]$ l ҏAj cXKvW<~ Rc.XSŒn_%"vԘ%cۗ e 쮶k^{vw/VQԘ%cۗ e 쮶k^{voVMԘ%cۗ e 쮶k{voVMԘ%cۗ e 쮶k{VIԘ%cۗ e 쮶kzVEԘ%cۗ e 쮶kzVEԘ%cۗ e 쮶kz/WAԘ%cۗ e 쮶k^z/WAԘ%cۗ e 6k_zoW=Ԙ%cۗ e 6kzoW=Ԙ%cۗ e 6kz W9Ԙ%cۗ e 6ky W9Ԙ%cۗ e n<{ҏAj cXKvW<*\,0%ݾ)K`wE`C`[ 5b1X,%HY+{tMaK~ Rc.XSŒn_%}㌾a~ Rc.XSŒn_%}b~ Rc.XSŒn_%}b~ Rc.XSŒn_%}#c~ Rc.XSŒn_%}#c~ Rc.XSŒn_%}Cd~ Rc.XSŒn_%}ceu~ Rc.XSŒn_%`oYԘ%cۗ e n Yr6R1HXbaL1K} R^ҏAj cXKvW,I)\,0%ݾ)K`wuK`B`[ 5b1X,%HY;nE+cs˜b,t,=nԘ%cۗ e y6-Q1HXbaL1K} R'o`S Ԙ%cۗ e nKV1HXbaL1K} R%q`SԘ%cۗ e n Yu+\,0%ݾ)K`wuK`ϒ9)~ Rc.XSŒn_%%g!׭cs˜b,t,-=KV1HXbaL1K} RK_&F߶J?1K,)bI/A]l ZԘ%cۗ e y6}ҏAj cXKvW<~ Rc.XSŒn_%"uJ?1K,)bI/A]V1HXbaL1K} RN#}q~ Rc.XSŒn_%"5J?1K,)bI/A]V1HXbaL1K} R@`SW(\,0%ݾ)K`w_r^ҏAj cXKvW<^cs˜b,t,=O+\,0%ݾ)K`wE`C`[ 5b1X,%HY+{Ma/U1HXbaL1K} RK_nF_J?1K,)bI/A] l {ҏAj cXKvW<~ Rc.XSŒn_%"2Ԙ%cۗ e y6H 5b1X,%HY+{{J?1K,)bI/A] l {ҏAj cXKvW7wڷmhKcs˜b,tg`E`S(}@/vW<635_7D`S)|Ԙ%cۗ e K l {ҏAj cXKvW<~ Rc.XSŒn_%"\Ԙ%cۗ e yu+\,0%ݾ)K`wէlW_6Ԙ%cۗ e dj˦cs˜b,t,U#mɔ~ Rc.XSŒn_%Sq0ҏAj cXKvW}*5R1HXbaL1K} ROF_TJ?1K,)bI/A]i8+J 5b1X,%HY> G`;}3)\,0%ݾ)K`wus}F_DJ?1K,)bI/A]V1HXbaL1K} Rd`S+\,0%ݾ)K`wE`C`[ 5b1X,%HY>G`} (\,0%ݾ)K`wէlwaԘ%cۗ e n=̢cs˜b,t,S|#퍾IT~ rc.XSŒn_%{ToW1ʏAn cXKvO7*P1ȍXbaL1K} RS )T~ rc.XSŒn_%{nvb ܘ%cۗ e :˘A 7b1X,%HYNF`06&P1ȍXbaL1K} RS) T~ rc.XSŒn_%{TnvʏAn cXKvOinvʏAn cXKvOLU~ rc.XSŒn_%{"g*ܘ%cۗ e u\,0%ݾ)K`)4FHsܘ%cۗ e :U+cs˜b,t,Qh#}'~ c.XSŒn_%;mv"/Ar cXKvGdtV1HXbaL1K} RWؙ ?1K,)bI/AJ6;X 9b1X,%HY^F`2Z+$\,0%ݾ)K`wԫ\FK_䘋%cۗ e zics˜b,t,Q^#}1m~ c.XSŒn_%;kv6oAr cXKvGs}錾 ?1K,)bI/AsV1HXbaL1K} Rk5MaO*$\,0%ݾ)K`wD`ϵ~ c.XSŒn_%;jvB/Ar cXKv?ZhtT1ȎXbaL1K} R[)>1K,)bI/At+5;P ;b1X,%HYnF`4d\,0%ݾ)K`-FP;u옋%cۗ e ~ujcs˜b,t,ON#}E} c.XSŒn_%ivZ神Av cXKv?*Nk5S1ȎXbaL1K} R[y^>1K,)bI/At4;ѷJ ;b1X,%HYzӾFR+u옋%cۗ e ~'Za`S;>1K,)bI/AO`ϵ} c.XSŒn_%y^Av cXKv7 mMQ1HXbaL1K} R_ɍ6>1K,)bI/A3;WF =b1X,%HY~}F`g7K IDAT(\,0%ݾ)K`w/FUe%cۗ e njcs˜b,t,M:#}[=} c.XSŒn_%gvAz cXKv7ڌ.`uP1HXbaL1K} R_>1K,)bI/AK3@ =b1X,%HY~eF`0(\,0%ݾ)K`m;ˌacs˜b,t,6yv ?b1X,%HYm10K,)bI/A؝g=dcPs˜b,t,}%F>0K,)bI/A؝G=l cPs˜b,t,I#K}(\,0%ݾ)K`wҳF>0K,)bI/A؝ 1їA cXKv];j5cPs˜b,t,G #}{T\,0%ݾ)K`5Fj>0K,)bI/A}t0A cXKv]#.lMcPs˜b,t,G# }T\,0%ݾ)K`ѵF_j>0K,)bI/A}tM0wA cXKv] mecPs˜b,t,Ci`vm/s?5 %cۗ e >҈46wS1XbaL1K} Rⱌyis/%%cۗ e .ÈН| J`.XSŒn_%[_vy/t'%%cۗ e .]GǠb1X,%HYE`+EǠb1X,%HYE`+EǠb1X,%HYE`;CǠb1X,%HYE`KAǠb1X,%HYE`KAǠb1X,%HYE`[^Ǡb1X,%HYE`k\Ǡb1X,%HYE`k\Ǡb1X,%HYE`ZǠb1X,%HYE`XǠb1X,%HYӾ}۪\,0%ݾ)K`C<YvS%cۗ e j>oncPs˜b,t,S 獾-U| j`.XSŒn_%{\ U| j`.XSŒn_%{\\T| j`.XSŒn_%{\ʌT| j`.XSŒn_m~_x_/_?Vsd{^A  cXK zq߼E`C`HǠb1X,%HY}`ųw~W/ؽk^WA cXK[/]F5>x"%cۗ e]:Oөo!!!Wh%ocPs˜b,t:7_NVp{F >E0K,)bI/Aʪg;|/ u??U}(\,0%ݾ)wv?gD~?͑m.-{FsA cXK]F7þ ?OѧGhlwh+5| `.XSŒn_ ߛo"?siYZj"%cۗ eŁ^k*R===n .k]-{'%{9yF_v@`л}@XJ*%cۗ e>Csd^]cPs˜b,t,^"mשT\,0%ݾ)`7[#Xʍ2*%cۗ e$Or|@`D`+R1XbaL1K} RVطxavJǠ b1X,%HYu`~zy-ث7΋{ `.XSŒn_Uoz]EǑnKQ1XbaL1K} RV؛l(zs˜b,t,qC^ zs˜b,t,qcޠBA1 cXKvCB`C`6x =0K,)bI/A "2CWcP s˜b,t,ΰ&"3r<0K,)bI/A K"BWcP s˜b,t,ΰ""4n<0K,)bI/A "RVcP s˜b,t,ΰ"5j<0K,)bI/A !bVcP s˜b,t,ΰ"6f<0K,)bI/A !rCVcP s˜b,t,̸"*\,0%ݾ)K`73l<0K,)bI/A͌ !Mtߡ2A9 cXKv3Srs}hy a.XSŒn_% {M*\,0%ݾ)K`73'<;T1(XbaL1K} RnfNyl?=wcPs˜b,t,̸"P*\,0%ݾ)K`73l4m<0K,)bI/Aح mZ*A= cXKv+FccPs˜b,t,!\%\,0%ݾ)K`2}lc<0K,)bI/Aح LtX*A= cXKv+ˇF헨cPs˜b,t,!G%\,0%ݾ)K`20{ltx<0K,)bI/Aح ]*A= cXKv##F7McPs˜b,t,ti<6:jEE%cۗ e F[Πy b.XSŒn_%N{;f[T1(XbaL1K} RndDyZmQǠ b1X,%HYC`6[T1(XbaL1K} Rnddy b.XSŒn_%:6hEE%cۗ e FF[T1(XbaL1K} RnchCF5%cۗ e 6fAkT1XbaL1K} RnchEF5%cۗ e 6FqkT1XbaL1K} RnchHF5%cۗ e 6dkT1XbaL1K} RnchKF5%cۗ e 6 4kT1XbaL1K} Rn#Ȏ;p5T\,0%ݾ)K`7U=bJ<%1K,)bI/AMDA`C`gvx Jb.XSŒn_%N=*\,0%ݾ)K`71klrJ<%1K,)bI/AM.ۣAI cXKvckcPs˜b,t,ؤ!a=*\,0%ݾ)K`0hlXYH%cۗ e  /KcPs˜b,t,!f"Ux jb.XSŒn_%[36,Z AM cXKv [T1XbaL1K} Rnapp4*<51K,)bI/A foRǠ(b1X,%HYC`M*\,0%ݾ)K`7͝C`֬M*\,0%ݾ)K`7=]ϜM*\,0%ݾ)qA`C`W4z?hn N { @[0 7cPs˜b,t,7:^lh?U1K,)bI/AzӅFRǠ*b1X,%HY[otH* b.XSŒn_%Fw $έRǠ*b1X,%HY[otH* b.XSŒn_%F7 )cPs˜b,t,-6:L6l٦Aa cXK, QXbaL1K} R%6jH\,0%ݾ)K`N U~ c.Ycۗ e lAA`)麒Ycۗ e l9A`;c麒Ycۗ e l1A`[C麒Ycۗ e l%E`ы}rYcۗ e l3ps}بgjcWGzX,%HY[L$x6z,#]X?= c,t,u&ylx.,1K} R:<6^pHO%ݾ)K`k-u^qld~ gaŒn_%F=^s RYcۗ e lqFq}?ҕӳ2bI/ARF%~+KgeŒn_%FW=+0zW-#]Y?=+c,t,-59XbRYcۗ e lqJ^JHWO%ݾ)K`K{6VcʯTGzVX,%HY[itl< "~>ҥeӳ4bI/AJSU+.-󟞥1K} RVl_tתIDATi,XKx@`c}F/}KgiŒn_%F͝A`cF}KgiŒn_%=YF.-󟞥1K} R:?=F-񟞵1K} R:?=Fk-񟞵1K} Rl觠tmXKxD`cF?ť}kKgmŒn_%F7#HזO%ݾ)K`'61I+#]\?=c,t,3&яBUYYcۗ e l-~jHO%ݾ)K`.'6cPPGzX,%HY[gtFӳ8bI/A2 >Ԓ.ퟞ1K} RltuiXK|xF`FU$}KguŒn_%eF3~(JHHWO%ݾ)K`\g͝@`~+KHWO%ݾ)K`\;=FF|gyŒn_%U.SF3_r>eӳ #>@*S!}*ϲ)n$RV`}&}TCU:=e)R~I 6LEtz>RHY#w,0Y 5 sz6)n$RV`K6l%yR9=`Y_)+c%H)[tꜞ ,E/1r r*n@ӳHq%;FX"!HP5 sz6)n$RV`]6}CUNX"D CGљ]9 r0ũnAӳHq%;9-#!S T9=[`Y_)+C {MIr3nAӳHq%;-&QS T9=[`Y_)+#l؝M ;Ple)R~I{_#ar8wH7RHY!F`î>tnBӳ Hq%;BY}dS!݄g,KK"evc ɡC 5N&X"D u+ompz)n$RV`=ܯذwnCӳ Hq%;@~rDS!݆ g,KK"evc: >C N6X"D 7l+kҍoz6²)n$RV`o/,A`CvϥnD}ӳHq%{{ JhڝF7=aY_)+6f0_PӎTvH RHY1V`#9Ϩxҭnz²)n$RV`om̠lF*Tet+,E/5c8ÒR!݌ڦg3,KK"erO6,CMfX"D m+l(]k;uͨmz6ò)n$RV`o)^E`Cr_UuHRHYz }MQ!ݎʦg;,KK"evr6%A6VMtCꚞ ,E/=WPܧ5 kz6IJ)n$RV`o'H^I`CritH7RHYx5 }S!ݒgK,KK"eVr6G\BEtK-,E/[=}WpHrs7UtHRHYs7A`}-nJMӳ)Hq%{GnÔȻT!ݔgS,KK"eƏǣ3C: .W!ݖg[,KK"eOE=|g_5t[*m,E/[?86rUsHRHY=݄Y(0Z3=cY_)+=N6j?_-tcꙞ,E/垤IïC1LX"D r4 tvuUrHRHY=Yљ&e_%tk,E/S垗kl %nN-ӳ9Hq%{Sr W!ݜZgs,KK"eD:lW!ݞJg{,KK"e4'ZaX!ݠ:g,KK"e4ZdX!ݠ:g,KK"e$zCEULY"D )r 6fX!ݤg,KK"e8?Tle)R~I`::7R6Km`zɲ)n$RV`XlE]*RHY=#H`#>f?=eY_)+Gfq6T,aݚg,KK"eXG(T>=eY_)+=@r凧,RHY=R4j|\ӳ]Hq%{g ܇~Eʞ ,E/E`}y6^|;{ #{2RHwfn9幘o9^2{:4RH>-tbh` ػrg,KK"e;ݵNߎ|B̷,N`{@ӳuHq%}|^s#_-= [=p)tzbY_)]6_qr/|ˑrl]=ʜ2DG^53:K1rH O'+ _A>oK1rܧx6[',KK"{l/_#Gg'W 9WeMOX"D߻q|[?8`rރSLW"n2M/B5Ŏ-=hK1 <88沶J|vﮏ ˥.7v_^7U{9`8Fa` {=-pp `p8`8Fa`;9/0 G5. ުOr\sp `pտsp `pvtwCȫ^>x?~l&ٍbsp `pvwE6w1} /: g6 W_`w|NYuzPrq7H[W #>}~碟oy'^2ӻ/o\=z)o c H`@ 6H`@ ?`'s00~{osg7[G`&a_ ;KwO~:6lv0b\^׽3{%J`ߙf߼?O lؠ)}ۿ@>^u;7b_{r|եd;#awkwUAP n<{quub~ F'.a'agj7\퐳K{?]+`nMNR\<3-' ;h3L8  lب{(ɛvmL*ݦyFa3 Fg̻kvSŭ=@6;*=wHX!^,ƒMNΟ6&a. sg~i`FuX'a}=a/ G( Xhγvذ*lw.Y} k$Ac~l6lv?@Vcb?Q`r`EֺAD`8ߜ⿺[E^@V| E@ `pذѽE_*!as l~\"ol l4R ,?׀5nnw{?k Or{7$!F`w.fޏp.p" v='<[ _^X^6&uǏzi9QϷ>/^65{V^J?=o`: PE`k|;6b@yyzwݯ?}k;6_uyG/һCkD^_,_qh_EmL$rӻ_/u%}DZ2 H`TF*w"𫷏H`Tv?~|; Iʷ0~ϐYة0G4H`Tk]`K'~';6&Z/>~`y ljyH[/-^I0V9Z^6&zo<.׶ uo`" P(.?/o|oSDֽ 6@W 㣥>z첔]T0S@샳_~"ϯEguczlH`죥ψ[ƣkDj~A3}Zm"׽ i6@ݾ|2,Q鷞l^;囋׿ i6@>}G?z_[YG<|; /mxl$ @ l$ @ l$ @ l$ @ l$ @ l$ @ l$ @ l$ @/IENDB`bayestestR/man/figures/unnamed-chunk-12-1.png0000644000176200001440000010347614560763455020471 0ustar liggesusersPNG  IHDR `gbPLTE:f:::f:f333::::::::::f:f::ff:f:f:::MMMMMnMMMnnMnMnMff:f::f:fff:ffffffffffnMMnnMnnnnnnnnnnMMnMnnȎ:f:ffffېnMnff:ff:f۶۶ȎMȎnȫې:ېf۶f۶۶۶۶nȎȫcfȎې۶E& pHYs.#.#x?v IDATx$gyj^G׶ШW^c1ȋ@63!3rvfUkfVdfD|SnD'NdS`4'l l l l lQsG׭g?C@o?__Nm~ѥ/~c? 3<KS-١XtV_> ١XtT_>y5;T` N҇ f l`9A}KP `19A܁H&cVs` " @VXZ)XtJo>,Q5w`i,DH*eHVTC6 *}`jv!; @P#z١XtD>895;T` N;@L@}逾SP ԗ;@J@y| }BjvK QC6P\:I%*N҇ ,-Ԗ ,-Ԗ ,-=@@XZy/0*ͼ_@adSp̮f lt0+}fWC6PW:>`s١(+H2P jvJA `^5;T`ES@0*ҥ|aU@MP>X̩f lt&.}TC6ҙ|QXZ)(H;܁ґ|OXZ)((I=܁PP:>|١'J?P ԓ䣥 \jvIG`.5;T`xC0*jq١%ƣIH9P ԒѤ$jvJIg҇`5;T`)$cJK܁JQ<^XZ)($#KN܁BE<\XZuxt 0*:=<Z@@Lf lt O }H&VC6PE:'>Ӫ١("HUiP Nቤ+jvjHd`J5;T`5;x2 0*<P@ PLf ltO*}pSC6 <NXZ)( K^܁xj 0;SпtO.}Rs@;J@;!H@;!H@;AF@;AF@;aD@;aD@;qD@;B@;B@;@@;@` zY6jLA;_XZ)X:yg>K 0J`t5w`i+KpP t+KqP t+C0*nk7 }FVC6ЫtF:jvzn݈AW@ҩ>١TtC҇`T5;T`}JnLf lO΍Ix1P t)AC0*.+7(}FTC6#7)}FTs` zܨOXZ)P:qG`<5w`iC K~܁Пtথ?hjvܸ K@wy>c١N:o>#١M:n[>#١M:n> ١L:mې> ١L:m> ١Ll> ١K:l>c١Kk>c١J:kۑ>c١LAWYېAXZ)I:j[>#K 0=IGmK`5w`i#mKl,--p*~1p*~5p*~5p*n{=3p*ns=3p*nsASp*^cEsp*^cEsp*^cIp*NSMp*NSQp*t"]J܁>CUp;SЇt6+}bQs` fO 1jB:c>5G١Bb>5G١A:b>9١Aa>9١@:a>=١@`>=١h_:`>A١h__>A١h^:_ۗ>C١h^:_;>E١h^^;>E١h]:^>I١LAڅI8LXZ)h\:];>MK 0Kk'ҧ 5w`iqrD4,-õp*p*#Sp*#Sp*'sp*+*+*/*3*v7*v7*v;*4+I1}܁fs?3;SЪt(}Ts` ZjhTU>i{١hTU>k١hT:U>k١hST{>o{١hS:T{>o{١hS:T>q١hR:S>s١hR:S>s١hR:S;>u{١hQ:R{>w{١hQ:R>yP (ݨ]K܁[XZ-I7i) p*S@CEZLtܩf l!"-&}:TC6Ўt>w١hGGIPP 4#(]jvтҧ5;T`HhAS p*Vc9C@+1ZRVC6Њt>P )}VvK 0HhQ SXZ)hC:DJWjLA!ZUTs@!ZVRC6Єt֕>P 4!u,.5;T`-HWhaS K@ ZYPC6ЂtV>;P O.v5;T` H'hm ]@ Z[lWC6Ѐt>[P تf l /O065;T`)Kgy MXZ)Kg}3 MXZ)KO15w`i .] >[܁%Hc-jv Y@Z=!}6١KBO3F5;T`a\iبf l ,] >P ds1'`*tw.FDlRC6HhMjvٹ S A@T:$}6١JW炤O55;T`)HJG碤O6m5w`i )ݜ>܁tr.KlVs` ɹ0 pKXZA\f l '>7P {sq'চ*to.NTC6Jrjvbҵ@SpC@L6(}n١HI"O:u5;T`)\If l %ݚ>P Ssҧ*ti.T\SC6th.U\Ss` 2ҡXpUXZ)HwbOW܁Kz+jv"ҕ`SpE@B:2,}١HHG梥O>*tb.[\١H'沥>*tb.\\١_:0.}.P /K>jvfK/ 5;T`K%\yIz?H `Bdd/,P^X*餃 @5;T`I#{J/`yjvE^0P L&+b١L:[zSC60t-f l`*Xd5,NTұҋX*[ 45;T`I"H`ijvS0t*r,-L$]$lK 0H"I`ajL4ҡȁ X;D^8P L"*re١D:9XzRC60t%rf l` Hp,JґҋX*)#$5;T`H'"H`Ijv&ND^>P L ]%|١_:9Nz RC60t rf l0K!GJ/ `9jLyȱ+X;S0tr,-.]-ŨK `l8x5,FqҋX*ې5;T`#K!cH"`)jvFNCF^FBP ,]"١W: Gz QC60t2:f l`\0d$,CYX+ X*QW 5;T`Jg!cI$`jvS0t2Z,-)'EK 0cJG!I%`jLMȈҋ X;FnBƔ^MP ()%١Q: Sz5KPC60t2zf l`< d\,@xAȸ X*񤃐P_h9+ f l`4dlWC60t2ʫ١M]zIP %/jvS0t 2K 0cI H/*;S0t 2K 0#I H/+;F.A&^V@q5;T`#I H/+*qCP[8D f l`d"VC60t2J١ELziP "]L&3 IDATjvƐ@&^\@e5;T`cH7 J/.*1 PY Ȥ (f l0#H J//;S0t2 K 0K J/;Spt2ꪹK xcbUC6pt1 ١8Z:\zeP -]L.Ājv?^c@Y5;T`J3H/2*cۏPUҫ f lHceUC6pt12١8N:GzEP '~$ЀjvSpt1BjK 0GIgsI4;Spt1RJK 0GIWI/5;>f^j@I5;T`HGI5*cPQ1njҋ f lcNTTC6pt1j*١8B:UzP .|+ހjv>^o@A5;T`KJ7*{WPOҹ+f l0KsK8;Spt1꩹K 0JK9;Spt1ʩK Pc~5SC6pt두^u@55;T`J UTSC6ptꑐ^u@55;T`JeSC6pt葑^w@15;T`IuSC6pt^x@-5;T`Iw!RC6pt摒^y@-5;T`Ig1RC6pt^z@)5;T`)8D:I=;Spt^|@%5w`i#(JjL!ҍGPz܁pt^~@!5;T`HQRC6pt^~@!5;T`KaQC6t^@5;T`KaQC6t^@5;T`{Kq%QC6t^@5;T`J H/B*}ێ!PEmGҋf l0{J-HB;Stф2K 0{JMH/C;Stф2K `?鰣PC6tшBj١OhDz!5P %u4#jv:^@ 5;T`{IWH/E*}#PA>MGCҋf l`馣!TPC6tєr ١ChJz9P !]t4%jvS0\:hKz=܁AGc _XZ).s4& ܁9Gk+_XZs椗$н*5GsK^P阣=5 tf l`tўWC60T:hPzQ١(r(*P N9Z^@jvJ-JJw5;T`äK6%й*a!G\0鐣Mu tf l`tѨ:WC6AG+ېo1S0H:hUze}~8'S0H:hUze}''^f4L銣] tmp`?WzUDZC#v&е}Ͼ9'HGJMk:.۱60D:hXzq=ڡ"ۿ[`W'г=:/۱60@:hYzu=ۯC~ p4-<ݡ?Vc l`tѴ:vH^[E6ptѶ:v`yA`wKK/P_v'"Kl -o4.@~ҡWxvsG`wKK/P_{w'W?=pS:h]zگCOWo{koM%)o4/DnoyǫK/ю -)]o4/Dn ށڕo5^gzI 0wJK/Q[v_k%hv8i.xE j髗lz6Зtс"zW`?|s럻EK@zߊ{m=O`wH]H/SSC{ ?`3 !]nt!LN ֐v lr e tf l`tщBtL~?/El`tщB4 \K)mt#T. l`F7Kщ:6^@vt{|''>/݃ t)m#V.''wyiϹ `tёbzk>]ls?L.f# h}\r_L.f# h~}SC:Jz:)"-b+ tH`.6^@64`3 gP~?J`ۥ{Τ,П*ҽFg OV\;% tf l`tѝC?}?zfJI/Y;;!6k"&kt(hl`YҭFҋ%jt(hlo?~_@dM`3^W.Зo/og`{ku4 l4z^@_u鷞\f)?Q6Q:Vz]ԡ\+?^&H_ teP]~_L`#~.Е!/7I˗6I:Wz]ҡz_\w4H`W/Г!ET!rƏGD`W/Г?㋍> [`W/ГJT?կ?)?6p[Zz=%ʳC6Зtѷ:_`}2Zf nK}K_#{!}ϣ=2Sp[:[z%dz{ނ]D`CL->w ccO~rٞ 2ޥW0Џ/Y]^_>}onnIK`_gm<{% tcPo 9}v %g/n з/+6p[:_z ءpj__c6pS:( ^ Oڃ_}|S}ltQ@z8CO?6pC:ͨ ^P ܐN3JH/c5;T`7ˌD 22:QC6p]:̨!N O>x疿mU.f^@vlM%\2H/dv6v]F a,SpM:(#. فO64\2H/e Cv1A_iMZפ2K}{իLQF$QF! `@yi2" \n2 I/f:W ltQHz1=ح~q \N2JI/g(/]d^@ރ-~R}lc 7CW/rW7C.{b hߠ]݅}ﭩ?ʈ6p!cT^@u]3t?7COwuv5}Sp!]c^@W9n '&S\:(( lyV;@kҝB>Ж;Z)HgK^@[6Դ)Hg^@S6Դ)HW^@S6Դ)HG˕^@SjL Y,Xz-١)X,Xz-١)X,Yz-١)X,Zz ١)]X,Zz ١(X,[z ١(X,\zvP K+.=@;jvJK5;T`KЌ*auGhFذ@b#4f lX 347 //-MA@`jK iqSN+s5wťN+s5;T` Eatb1. K+XIЈ!'_dL&V?ÌF`Ҥ Vs4bp`?WzUD`¤ Τ'h>gߜA`¤ Τ'hð}vl *8 C;/]$vc lXtU(mأCO[`ò KЄ:7ߺl ߎ-aYQϥghoup;eIG< t۱ۼUD`â Tp)= @ ܁߿W ư5餂KiZp?wy{Qi-j IWn#}m_=5餂+4`+{ß_~eOᣭoj~Qi**=@+w?[c~_?g.o6,I:< اC%FL^_?q [`Âs KO7C?}֐MO^Xϫ0~摋?x_Iܐ n~?ַVl 6t?#aA57Gߊ{#=ouU/-CV ˑ))=@BO>?9KMzF]۞'a91Hn!矬rSȇش'=@Z-ouo9"RpKz(c:k S 6H6zH7l ^W~w7!P]z:A|rՍm6,C:`xAMv^? -{*a!;jCwlXt@.]/k}?x? a ;ޡ=is~q0~g~lga i-` 'P Op1jZ  f|Ǐ?mvY@Z  f l/Op)5;T`C}v;H١K-=%@JP^:`!5;T`CyrcP ե H Uwt #N0HzP/nA҃dlClaғdlClңD~U]*HW  f l=hҳD܁k Q{ CgN  K Ps0D)H'  \:-t2pijvåHWoiWK#=/@͜Hf+gh_:`y6Лt0>l3^WoiWK'=1jvҹIO 0*t.~̯f l+]K١J+=3jvұJ 0}:y~}l!6ԝt,Cm|WWPG0T)H/=5܆p5W>֤8e+;T۰^e+;Tٰw<|vٴҥH 0A즐7O׍}ٻD6T%8Dzn O_u{_D6T%8Hzpy Џ6k)>6T$8Hzpy з7]^)>6$8Lzry uJ߾VQl(*IpС[?[_7A`CQJGၽMPS:Pf5 4 Ips%`n%G`NF:n҉KO0!~`.` 5 `F:t7 {+Jvt!h.^M}w"dZ^*NA:f}>K6{;??~FS$8Jzl߁WịA*NA(#N `>D:Hf#_{pKHO IDATfSC6ԓ#8VzP "`.5;T`C=6KPN:x)RC6N#Azա?ށF%`Cv{og[_XZMA`$Qf1d~伫beߵXZjMA:`,Yf1`^!Ǐ.~ZWK~J E00soœC>}݇l(&D00sС>ʏKoLɎ!txa``_r1"PJ:`Dqf_`_l]_LɎ!t`|H7a l$D0<3%7^_/D`H*=P>* Dl$C0@&^U+mB9JO0!Lj]~ėsƕ(`z:t'^W!Yz %g?ohZ:`l&7CחϮWfk C0L{wayI 8T)H-=S|yO_gߝcNZLA`|B૭PZLA:`|VcLZ ZPE`VC6T.!BzP UC+`bt'3fo\PE:` &6CO+f^hHwL#=Yv?\S}S e3,`Z:/2G;"HO0a;C>~ [`C G Ԡ}rvSțƾ]"jHGL%=[t觯޺^}կ^li"jHGL%=[tGY5ijHGL&=\tۛ.VijLA`24`^k5|HcttLi3?ouJ&/`B_7DZQJLA`B&4 .@0|%`n%G`:I :n J0!~`.` &1`2:t7 {+J&XzĀ ua?|oJ;Y HL,=bdw_z}'>wyۯn_ˍ#"ɥ ]=.L%>0S@K0 4)>0د=C L#]>0١.Az̀P OA:|`AUi} H0wzO 8^SGzҀioyZ:tLңLb7xݗ<-tLңLbp~`{їзt\ҳLbh5׉I?q6-=0SءO6i?16-<0S֡=l_~cv8 ]K''=mu뤾]ߏ} ?Q6t-<0ԡo_k<=Dh.Qz܀ 1v˗6,<0ҡo8~G7~ Q`CJ0!Ɣ~="zUz onduȋnF`CҹJO0"[ K,=r6kf9`t{-"Zc斞9`t݃ w ұK0OͿmCicw ҭK0!;ZKي~/:;`dC:tNwa-.H0Azɽ\p}U_7"G J٠]Yb|oٯ8 lW:t "=xu&AD`Cҝ5C?ҭl}-[΁ڡw]_zGv{6t*9=`T;.-n+Bңj=gzE`Cҕ!FUC6)9>`LC:'_xwO2& }J7ĤJo.ri@_3K7hz̽(#2-`T]NAp (=~vomܤ˴Qu9#x+Й 8@` lP:o ,=ht1"p J GK 0 !7B`,"[|ѯ= lOm .=XjvCf lN:m /=XjvC`$5;T`Cwe H!0!?sK`CoShBzqܵ}FQoim ]MH"0;.y}3}0ަ 5Є عkyؽ)Hg 4"=(v߼ƗfXG,-t@#ңbW>97 >q6t&]5Ј(ѡvx}ȋ$"/騁fÎh}W^/rY>6%4Ќ0cѡO_xWfH#Зt@3aG}G`;tuOȵ[B>&l ]I 4$=w;ѕ_A-I#0=/%'頁8=MI$p< sIhK 4&=6kIhjg 1I%p, 53閁椇8t@sC K`Q锁8% J%p$ DKKH>wrw6-`6ݮtP;su0nWAT`@e \M Xt LЫt LЫt LЩtKHЩtKHЧtҋDЧtҋDЧtҋDХt@Хt@Уt@Уt 8_*H -u7cZ:\<0pv6:L Y ]'0Fi3p^zہ0-`qK/b\5;T`CmK/b\5;T`Cwi1p*;28SНt@e f lM:LBSC6&%PBz!١:!P Ig ^YjvΤH/e,5;T`CgUE2p*/(2ҋ8G*H7 ^9:ځ+- Un(#st7WZ@BW $PHz9ggnVAHrRWi I/g 5;T`COA4pZГt@) VC6$#PJzAP IԒ^i5;T`CG9Ť4pRБt@1% TC6##PNzQP H^)5;T`C?-5pJЍt@Ae PC6t#]"PPzY'P t@I \/i9t@I \/i9t@I \/i9t@Q ^'i+J/mਚ*k8f lC:B١n(+cjv. K/o* 8f lA:@P =H^* VC6t P\zjvK/q`Rؐ(/ȁ)5;T`C~.q`ZͧWA:=١񴀸*H,@tjvh<- .  ]O Xtx":pXؐXB١ ^A5;T`CX:`!K8f lKW,DzP YH/v*!+RC6D$܁jvtq;p@ؐXz١^*!)(١ (L١ 0L١6,Ehjv KZ*!'8E١rҭ^*!'8E١bҩ ^*!&]@e١bҥ ^*!%Du١Rҡ^*!%Hl١Bҙ ^*!$]Pl١2ґ^*! ҍ5rP UN X;0f lذ,w`ZؐXE{jvt_f lH,[zOjvt^¥Gf lH,\zjv/=5;T`m*av6f l], ١f. @`C/jv zQC6-Ћ*afңX١f^f\*aU |8f lذH-{`Z a[*aVJ` x+ <_:( l=lH@`ϗ `Cz xtN[#skؒ )Pjv[ؑ @0tJS١fN `Oz,P I'=`jvVA:$X*A`Âͱi5;T`cjvVA:#fX*a&JX*a&JX*a&,[0tCf lE:!)VC6"xE١f.`Rz

z~8#W߿zV?zozt:'tӺ߹˃OaH`n:i]uOqN# ^pN C_n6tⵏ;6Z:3,UO)W?ۻGmpknΐT=u=6^gׯq/^?9n, Yң]M!/{{$%=*`zН_qwo6R:3,SO!88SzX2ԡ{9~Gw>M]`L-=.`zӁ؟M"f.lqS'޳ϋ\ =0`z pK^.D=uw6}JpĀ%CO駸6P:G,POE`ôt-$uաljqavUB:tw#.A`n3 i]u*'?%c 7[T.vYLCWI?@P 7X<DP x"jv 5;T`C{8)=D`9jvm0jvgJo,ң١'3If lx$=l*Y i8v5;T`pjv笂̨P 8Kܩ١!J(f l^z敞9PPpf,=t*j[z@=5;T`[=0؁rjvk7z`~P Jo@@z@55;T`Õ<PKp*Ho@ ,Wp*Ho@-,U bRP WDd2P WH@TzA!5;T`қ;BPGpQC6\,q1eP Jo@^zA5;T`å;Ё *jvKuAUP Jo@ң١.Ձ.GQC6\&H#¿es IDATf lLzO:FPCpt#=*Uсnp,rP s f lUn9`)jv VAz;rPC6\ ]I$(f l8_z3:J0*|Lz(jvr;ë١ΖɁ f l8Wz#:L0*LmQz2jv3qK١ΓāNf l8Oz:N0*,-Vz١%X̃P͒ l`V١D` O=O,'Awjvf>ƒSC6%PR}"PB}"PB l $@Vz B7jvf6Ѝ*YO6Ћ*Yݾ"G < 5;T`4}-G!f lF`]BD,́@BxBjvfY"PC6r6Ѓ*Y}-LP͂LBC:PC6 "΄"PrLbsjvf1&Z`9i5;T`Px2BZ,t_߭& ,Tz8BV,t_ l *=!f lH_ l *=!f lA`JHH١E8^'$$Pk dG$$Plk A5;T`'Z`i) 95;T`Sߩ@ZxLBN'$PMy'Z`yI )5;T`S@³Bjv3Z`=OKȨ١k t!6PAxXÕjvosJkJtm@ ר١w 1<[zhjv_HmXtk@ ١^($=B5;T`өڋJ.TC6]36PJx~ejvGj pDth@1!١&<|5;T`ӝZ`9f lz3_ l,3PM_y-RC6= t8Gt$*<ᴚ*G6PVxI5;T`ӍX_ ldSjvn7AHOw8f lk ԖpL .=ሚ*KyVC6q"GI5;T`O6Yjv&+k3I}pXDT['>RC6I鲾>psPMP:O&^xþ*Ig餷=?١tUoXOzExÎ*H7.X*GZazo,]"ǭO1wf lfS'r»KVC67֧ VC67sO4D7 f ln)]gZkzo ,TP:ϵ>4X*t7m}} }١[IWz:X*t3_d}M ١H'DX*i.[ '魄Ũ١ұ| /5;T`R:#I),B4 l PC6+9 t)P^4NY?ЩCq5;T`@:k ;@» Ps븁Ho_= o5UC6ϓn&֏$yt.PT(@m^P`#,@xC5;T`/Sh;3I:KK؋ݭ(ݐ^P$Hof HGl6@Nz$f : ЃIDeu$?^*KJhhM{MYP]H:SǵK' o̠x^"][w oVoo՟]wZ:LXa7NoDg?~w~tk{T&-e'78Gx:W}S'#Nњ-7dC?]e7իϾ{pG`.ݞNz}tҎ\(ݹދO/774{O?``9@`0ɨG(ue`._]ɨGX$ \ջ(Q[)[-[~!/s2.W/+|˗qzY-."Y$ \JO}H˗|{G?Y$ \JO*'~ٙe00/s2.W/+]M;7\w@[ s20/rU`mY$ \JWI/r,e`._e^Gwg[h"a`._e\^V 3ԏ~}<F`>zY`[=f`<z[`zy?WЋ&! lhH`@CАywcl6?ŋ{j0u{c2_}ȅi.b}1ϩc2\{3%|¤;'ۓ@>0 ~9~o/Mzs=}aCr4|L`oX?QͿ~tu{†c;3|L`?YU;w?~y/#hӂN^/lH1vۯ~pV EOVF>x8t{r=}aC5om.~r_gM>*s=}aC>XZ}w" E؏V4W?לޜnϸ!ehgglwջl, إ!1w4 cRJ7|kс͗Ϭp†o* eOFνSdЇS e|m.~Onz;`V@&]4d}K/_8D?wp=yo2 E>^}Տٓ_Wh0{[ N B`4+gaȇ+Gs~M7ퟦ_=Ɍ^}??6Phj*'nHg<|yq?C_"Z6@S{IOֺ{,&~Ї.Z6@S; oZGdOQ`lqwH *'Y{c6Ph]f{}s^(j6@S{#*6Php`ox)4_:?7z~l>o~6/2~>|S{t#,@6@S/tV~}U/;?}sc~{Oz6>xĩm8x=7?ݿL@?6@Sgzc}ᗿqh+_Sc3r(yԶGd~ia_ؓ ԑ{oyU]ۭ>xs{ՅO'<xۿ8hp`oO[~7fևݔ?{Q KK/߾ݦ:Щ{+8{gh`` u>u]~cR}1}^#Nm[as>v~M 컧U١c%;&6^_q7`L{j^>sC`4?/JhϽ7+ȍ/;x};~ORC73yHԣG|-;}!zWcC 7և؛O9x]OuSO/0~)ngs9sRIDATӟEa:;>3@?6@S6=|LO1[*}=L&<;O&ɹ}!:_Hf۷`>7y(ԣGH3վ;>z~M_wvܟ/>؇)>tn~"v39ujc>~~M~m53MyV`?#ǣX`owhD`|<̫`ܩˣ/|MyV`?|',o<hD`o>q{g>z𹁽BS~?ެC`4uN`o8S؛&ǎ#4$Zxb|A`?)gw>p乁} =U:ӭ>H!:Ϳ>~6_C~đ⑇د yͯv`y$Mבq_?[**vի2\/# {D=w{uN:?듏А64$! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@CUf9IENDB`bayestestR/man/figures/logo.png0000644000176200001440000001740514276606713016307 0ustar liggesusersPNG  IHDRxb]esRGBgAMA a pHYsodIDATx^]Uֽ#aHC,0$A]D1X뺀몿 f H 03ɩ?TUw3=-W]ozy{Oz/L~#8K +=|ͽ,u< 6O fP_ (B`]g`,3Qd\TJB !I0͋T3V&5n Mf́=)%! c/0~6DDlp)LJ /t P) b5 ?V{ ˌ[, #Hܰ"0}^E7 0H^'`{6/.W ؾ$_$<)_+TV2)H 6DoUw AG0`w"XfVx:jxg=ɞMJJ Q{6 Dg)%A!Fa'ؓ,3[*[,[.[WpIaq _$ A0lU U>v׆^ؽwEKg%ohLM HVݵ/lM0m kt;$c#J(Uzd*Ei%{Fž% `XO+ltqĿ $[ֲw3% | SL^Y绰) :gq< 381b eS Pٳ GE/ .RH"uoI vHmĿqGc"yǗj,cR>5y">E"{k_qRYV"T{\ }` t-"YKD:MѾdL;H[* _D2ЪIʼn4}UHqq7ՏbZY\\!/Dل XKߥ%}ӵV]SȞ\H+4 |Z?gE|Vhqd " mη6Q~,POҮ j^!K\K&Aݖ~џտ_P]j"Z"YSc 89#gF0]Cg^eI?87>YxcD+rhHA5ulGgVƦUG-sE;pSY r۷ŴL#mk4 Nè$gp3kGirÒ>Eox/HH|8wZ`5KU%ӵƣ+qx^u454*(3E5 mOC!Q|AmH1HjQC{5^"RC" `+gZC NB}"98+= D;/i [LcD|ccMk$gDjEeZsQdUvbx>qͧlv:"o~c[_'TvFi?QQYa@Hi}p^?GR)'v矽^-cif@G7_efN^yy%x;Btr 7'_w4 K8AFK 84`:#Q)@["oJ#L\\5Pj#(nͥ Pac #؂iJ=MqsYy.-ނ{&v2A~u@O_5^M:i"qꖮ|?M"FƒJ݂'L{0FOzTJVuo G@Z7[T"_\p$鞦`Os+͟g!}lC"8_SKסUMMF#c 7 wZ9 n-s}ws;'KE|pD<K Gm@C1h3ѯ+"ʇ/\ x_w7J> Fp]tM"!jAs09dn52n7-~UG6I;-0"FV6o+ Lfy#[vIKi-]Zm+%V@|(|c0`D؇滣HLR[I`+CIuuIoɣD`Kݑ` "O <[M2Hs;J895(-bʩrp0o'+CSD0>ңFϮcR2 Nc<^4zopu[|Wx3mW/=ʷ(gEHK8ԞIj h0Ԛ+DZRfV=CJcܸqX?9ڮ7o`b:uȓO ǟ|Ffg'Ϭ >锬ȫ$5|~ɞ>rtbe>ߋJҤ5~ Wց\0Oɼ%&-b4;ː!Cs1B\,mĶ'8!V`tJAc؈;$8#+W7f OZuv`}eS"%WHe޼y2g;v3FRRRR;t iiih"9}Z}ѝg8+u(7Ɩ}Ur݈~RXXȑȄ $==]xYx]w%;w[dص7*C !~!//8"U1WZbRm'[sML֭[xekO?-SLe˖)Q^^uЍiQ` ؞{5iC VhJ_˨ueڴi>'N=B6 mOBr,{>TND Z~+%99Y&O ۷;> οOGsEz)z,_}_U4GJ^̨:11QVYː l$%2M"G݆>T< 0@;Cy`F.GM^#{=[~(=aÆ J%Qtj5 ,j{`t=n[y;yO ܙ_yF|p)4pdJOͥd-j)ቕ;M+SGɭHVtib\oJޭoUg]H|/Wr}-g}qmQ\X]hz7bZKE:$nIY?6SGJoѵ奸eڪjx+Mlfɴ;+g=i$6K@kދ:>r%rf.@\ْ#*8*i.k CtNW>ZҠϟ㲿P"?^!+%j#g^BӦ77!} Lk0fΎ401+tىn `tʚ[ȭݥ:mTgFE[0>ybi+J!e }45ET$_$wgI*@~ud|TzH^yTKƽmarC\W)]Qz2QrJZ.u]7:2H8s0Ӱ5,DoIXt2!,F:! R`h_-i]Oԓ}Q+Cll/dɒr`JI'mƶ$gmT'LZ4 ga}"ym/"K 0P95(}c0"H :<&QaR-"R.$a<|VD6;f]qiٱ'](m n9-$đe!zOu:@t#lf¸دoD;!C Vu 2hQ.8ĞPJ|DƆsNr$ܸI«lǙ8*2&]2q[{T`$3\bGaKh%Ii?]HDȋa\z"X;='&{ /R{E^'lIMs6rјÒxdϒ敼8 ĚH0lMub){W Y*qvHˆ-,{ /n)~ Q4.HO :@.{rY#YI{Jx_Q^ )AGmkٳ&{&=9*/K,MU&/AK0yiZXl_EGp^ʋ|mnp" ){> i:ceO''/E}b" uhʞy kbl O:@tl({z;gbm!/^D0,Q5;T`ː f l`U$P ,B:wH*%HG.cTC6)}prjv wH*}H١/wJ *<@P TA f lt:>J5;T`)(.@DXZ)-΃@BXZ)-̓@BXZ)(-{H*;*KG^ `~5;T`y/0*ɼ]@]`Wx̮f lt0-}VC6PV:>d3١(+]H2P T僤jvJ҇ `V5;T`EK@0*ҡ|S@IL>\̩f l0%3C0;SPQ:>v3K 0#(0;SPP:>zK t")}fSC6PO:>~١'GK@P 㥏 \jvI҇`&5;T`դx0*jms١%ţIH9P % jvSPI:ǔ>3K 0xT 0;SPH:G>K 0xd 0;H`j5;T`u{xt 0*29Ӫ١("IVIP Ԑɤ,jvjHwd`J5;T`%3xBC 0*<P@TLf l0xR 0;SP@:'>K 0K`25w`i\L,-wr 0*wC 0*wC 0*ޥw 0*ޥw 0*Υw& 0*Υw& 0*w. 0*w6 0*w># 0*wFC 0*wNc 0*,Jl܁w^ 0;Sбt,}FWs` ޹7jW:xg>c١V:w>c١V:w҇`d5;T`Jn@f lW؍HtqP *ݺ0*NS7$}FUC6Щt醤;jvݘS@ҝ>c١R:s҇`D5;T`]JWnPf l0=JGnR,-(Q0;SСtf>xjLA҉>K ?MKP 'q0*6/}RC6Нt6 } FRC6Лtܶ }FRC6Лt6!}QC6Йtڶ!}QC6Йt6"}FQC6Йt6"}FQC6Зt6#}"PC6Зt6#}"PC6Еtֶ#}&PC6!S0;SГtԶ$}.FPs` zږjLAGMۖ8^XZI'm[gx5;T`Hmcҧx5;T`Hmkh5;T`Hmkh5;T`Hl{gX5;T`Hl{gX5;T`HlҧH5;T`HlH5;T`HlH5;T`Hl'85;T`Hlg85;T`Hlҧ(5;T`)Dd>-GK 0}Hl(5w`imV,-!ݱJc܁Ѕt6,}jPC6Ѕt6,}jPC6Ѓt6-}rWC6Ѓt6-}rWC6Ёt6.}zVC6Ёt6.}zVC6оt6/}UC6оt6/}UC6мt/}UC6мtv }TC6мtv }TC6кtv!}SC6֥۵ p;Sиtv"}Rs` .NOAjLAډi8HXZmKk7' 5;T`mKwk7' 5;T`MKgkGҧ 5;T`MKWkGҧ 5;T`-KGkO 5;T`-KGkW' `5;T`-K7kW' `5;T` K'k_g `5;T` K'kgҧ `o5;T`Jko `o5;T`Jko `o5;T`Jkw' `_5;T`)hV:W>cK 0Jjg `_5w`iUZQ,-*=J3=܁Шtv)}TC6Шt)}SC6Шt)}SC6Цt*}RC6Цt*}RC6Цtv+}QC6Фt+}QC6Фt+}QC6Фtv,}PC6Тt,}PC6Тtv-}١hQQ>yP AD[ Ws` NΥO`5w`iAB\ Vs` ړO P5w`i'ݧK@jvړO P5;T`IiS0P@suZ@ TC6Кt>P &ݦ%O"05;T`Ii 0L@ciZD4 RC6Иt>P %U# 5;T`mIi 0D@[]ZFD QC6,-4%]O%5w`i)*-$}*K 0-IGi) p;ZnR'n5;T` I'i1 p*S@CEZLtܩf l -'}BRC6Ўt>w١hF:GIQP 4#O)jvтҧ5;T`HhEs p*VcIحf l-)}Rv١LA#)ZSVs` NѢҧ`;SІtV>;܁6Cyة,-6Cإf l +}fv١hB:CJY]jvZҧ`*+ءf l,}nv١hA:BKK\jvNg`*خf l-.}z١Khu U@^:@K`mjvS'`;Sg`;SHb-jLA\> }K -K>[P s'`*t{.B$lVC6NυHfjv Q@X<"}6١JbO4&5;T`Y\ؤf l +ݝ>P DsAҧ`*tu.HTlPC6Ij jvSEIljLAR9%}nK 0A\,-saҧ;Ź0 pK@N:8'}n١IO8M5;T`9\ f l & >7P Ĥksҧ*tm.PPC6EJtjvRҭHp]@J5)}١IBO;55;T`!\if l0\y,-dCs'ચ;SJxjLAD:3+}K " >WP D+sҧ*td.Y\QC6EK|K5;T`\TC6NeK}K5;T`\PC60t`.]\١_:0.}.P .ݗ^jvfK+๚*٥ xf l0K%\XZ)[.Q@3jLqQs` 斎K6Ќ;斎KEa١Y:-YI35;T`3K%+Upf l`fd- jvf.K`f l`^LzP +K/*ysRC60tV\z%P *\H/`Bz)<KG%WLM *S0tSrEz1l(\^23J%פ8V(&6A PC60tOrCzAP 'ݓܐ^5;T`I$x5;T`I$x5;T`sI$x5;T`sI$t5;T`sI$t5;T`3I$p5;T`3I$p5;T`3I$p5;T`)G:$"0eK 0Hw$[l5w`i`d,-"l^܁0tEUziVC60tEUziVC60tDCzqKVC60tCCzqKf;`۟f^l@E5;T`H73J/6*#9WPQǜҫ f lcVTC6pt1z ١8\:WzP .|+ހjv=^q@=5;T`KsK8*,{-zjLҵK,-*]{/rjLұk(,-CcPNҭGBzP (z$WPMҩGBzP (zDPLaҡGFzP &zdPLaҡGHzP &yPKAҙGJzP $yĤPJAҕGLzP #'RjL!ґGPz܁C*K 0H7ATRs҉GTzP  ]xDPH҅GTzP /x PG}GXzuP /w PGyG\z eP -]wĥ PFuG\z eP +w4 *jvn;^@5;T`J H/B*)v *jLiG(,-)]v4! "jLeG(,-ÎF"PC~]G# f l`?鮣PC6tьRJ١KhFz)%P %]u4#jv:^@5;T`H7 I/F*}#PAIGS(f l`颣)PC6tєr ١Lp頣-Ps` KI/H5w`i`tјWs` KIH5w`i 9^@jvKI/I{5;T`Cc$н*1G{k^P阣AE f l`tѢzWC60P:hQzU١(r(*P .9ڔ^@jvImJKs5;T`äC6%й*AG \` IwJLoCvӿc\L 錣U mk'/`O2&i`tѪ60ON?h!Gk~慯rHGJMk3kO4 8ڕ^@׆u_$vc l`tѰz6CO?Eb;H'-KNg{t_4vc l`tѲz_[۱60@:hZzyۻCn那i tz;vln連m t^A`wKK/P_v"Kl -o4.@~ҡWxvsG`wKK/P_{wW?9pS:h]zگCOo{koO%)o4/Dnoy'K/ю -)]o4/Dn ށo5^gzI 0wJK/Q[v_k%pv8i.xE jklz6Зtс"zW`?|k럻EK@zߊ{m=O`wH]H/SSC{ ?p3 !]nt!LN ֐v lr e tf l`tщBtL~?/El`tщB4 \K)mt#T. l`F7K:6^@vt{|''/݃ t)m#V.''wyiϹ `tёbzk>]\sOL.f# h}\r_L.f# h~}SC:Jz:)"-b+ tH`.6^@64`3 gP~?J`ۥ{Τ,П*ҽFg OV\;% tf l`tѝC?{?|fJI/Y;;!6k"&kt(hl`YҭFҋ%jt(hlo?~?i?oH=JZ75;T`)"jt)l܁-ҥFLXZ),j)n܁ҡF KXZ;N.З:?9yk>@dM`3^W.Зo/og`{{u4 l4z^@_u鷞\f)?Q6Q:Vz]ԡ\뫫?^&H_ teP]~߼_L`#~.Е!kϟ7I˗6I:Wz]ҡz_w4H`W/Г!ET!rƏGD`W/Г㛗?㋍> [`W/ГJT?կ?)?6p[Zz=%ʳC6Зtѷ:_`s2Zf nK}K_#{!}ϣ=2Sp[:[z%dz{ނ]D`CL->w ccO~rٞ 2ޥW0Џ/Y]^_>}onnIK`_g~哆m<{% tcPo 9}v %g/n w.+6p[:_z ءpj__c6pS:( ^ O_}r{S}ltQ@z8CO?6pC:ͨ ^P ܐN3JH/c5;T`7ˌD 22:QC6p]:̨!N O?|mU.f^@vlN%\2H/dv7v]F aɖ,SpM:(#. فO64\2H/e Cv1a_iMZפ2K}gիNQF$QF! `@yiO2& \n2 I/f:מ ltQHz1=ح~q \N2JI/g(/]d^@ރ-~R}lc 7CW/rW7C.{b hߠ]݅}?ɘ6p!cT^@u]3t?7COwuv5}Sp!]c^@W9n '&S\:(( l6p&a^@wOpON^~oʏu$ 3KhW_.{I?Q60J/mi;7ޛ~#l`-]a^@ӆugm}o6t IGu6дAU󧟽v?Y楉?60 K/neC:t}z}E`?k-߆-ҋhِx}{}e`)?tQXzq-?J`="LS}͔ҫhـx}Cꋏ/|Ov ifR 4l󻭯՟[#-I7а}^G:- ltQ[z} ;cD܃ +`^@_rZ/Kp]CwW{ݞ 4+_T^@hfW79MKեW8ЮJӫf؀fr54kP/aV81AH8Ьa^}rJll l^@vya_Ҵ/^,@zڡ?۽~- ҫh=޵~)?ձ6,~ W9Ъ}vu_|LJ[|Z)HK^@jO XˋeHsQ5w१tx u429Ш*aB:Цz+᤟f,.],Ezmҡ{?ձ6,\:XJtw˷_S6,^:XRtW[^+M? [`¥H/uIwt'ސ[-ar:ФE_?|}ݿy.~{x ˖.$؁鷚/l ˖n.$؁oۭO.[`â%IvE:g׶ߜCM`âEI/wA;:t}{} nEK^@vt;/R]=bQhЎkۭ#贀%OA:Xڳc~?^KQ,9-̒ [,Lzپuo^rZ%OAXڳ;wd-'l^;9/$ -'ltm8%4G`cJ/z5%Z,Pz@-bҋhJI^@c6PJX#Rҥ"= T-)lthPew``/l5b h} Z3J|-jZ3J/})jZ+J/})jZ#J})5we,,P ˔n,,P N,,P N,-P .,-P K,-P K,.=@;jv%J 5;T`KOЎ*ayGhFذ@b#4f lXt]xQC6,o qQs^^ZM˛t\܁p V s5wܴ)Hl๚;Hl๚*aqisC:o>IhĐ쵓0'Ih>9&0ذ4鰂ϼ^nذ0鮂3IڰO`?&Dcذ0鬂3I0C?x"[`¤ Τ'h=%]Up.= @߿hoذ,骂ҳ4a.a÷c lXtTsYw[܎-aYQϥgh!zv6oذ)H7\JOЂw.yq?Ѣ Tp)= @ ܁?.y\b/*-`EMA:Rz_ٍ"aO<?G_ƏvѢ TpEzza} ٯ>z5O_n/*-`AWh~zzΐ~[_~{G[хm%I\t薗9~҈_5GWl-aIAפܡ?}ʷ?ɳ_8i[{umOOذ$鞂k Ы_k%pۿ;:1v\ذ 霂 ^5dSW>V`;_-yj"aA97G+GE;[M?lXtM rH[]_vK`~mGD`rc nJ74wG8?ƏyS`W' lXtL-|kǫ+6Idn w]t[sHܒ p_:Į_ l RAz,A[[=z\%hQ*]RAz,_r1~} lIV)/-&-`LA:``Y'ڵ)Hwl k|yɽ/>n=;"ri)i; 6JCi>`ä3 HCOyW`9͇tor.+ HC?_Cm UR/F`B+ HC/[dKH mS'-=!@0|;GP ]Op1wo?~?i?o/Op15;T`C}x;H١K)=$@JP^:n)Rjv١K  f l.N0DzNݯJWpA҃d~]hHw  C`Jg  C`Jg  bU@D`5;T`C)HG  \;-`S&*=+@DvZ M0XzX;p!JOA:` 5wi KO PC6N&.=-@W }Kӽ*_`yvhE2_9E3H  ޤ  @`I%=0@W }Kӽ*]`?WC6%OzbP s `~5;T`C]Z}g]PW:`_fWC6ԕ%WzfӡV c `nw߿6:ZݴNA:`6ty'\)0X)H/=5܆Wd(0X)H =6̆<3Ǐo˦.%8@zl 'g7On{%"t(!slH~ڭէ[V&"t(A҃kH~~]#oNF t'A҃kHb{/M t&aғk@SGD`CQLGՀ]݂'7 JW(=:-nґJ0lH/9޾{u/9sJ7,=<>7gw6N$8\zz9 cDn>{uՇl)Hp3ԡQث_yU: `Fvua?|oJ{;Y%Rq ҁH0;_zcYW}o}4zHŴTt Qgz ]<ZUq }GI0 t"Gp@'yGJ0;=\uGJ0b; IDAT*t3̦f l'Gps١I-=D\jvriKO0*tc)"n~wN|A:`\7CW-}r==E>`zG ܠ]_>^} oƋfcƖ)`r:t}zjVPh 1cK0;O?z}kOCՙt 3LnEa>ձ[Ɨ*`j{>!ן!O SƗ*`j5vʤN!_zP UK&+`j5;T`C) XPE:` &O~׏<+o55 UC+`b;b慯M&t4ғLkhռ^?ٷ<PF:`5Cҫ~cl("A0d֡<3Ǐo6 HzI 'g7On{%"tTҳLjH~ڭէ[V&"tTҳLjH~~]#oNF tdLiHb{/M &.`JvuJ߾VqH 8F)H'L'=][?[_7DZQJLA:`B&tx`ouJ &/`BoSJ0_r}_r Tz }L3n6l ?0ҡLj|vPA:`b&3CW1}Wt`BG ̰].{Ͽ%t#Lf{~7Vzr_ywǏ="\zȀlc1}TK0 )>0S@3H0;=43H0*{ Hf4`][pާ =0zުu>y' F;v)Hg$=j$ف׏׏y}IHW$=j$w_yW}I }KG%=k$vWz_sG`CI0dk_C`CI0a?~7'lеt|LaP~N{_}~ޞE`C3J0A*X_ӳ_M&k ]_| [`CsJ0!~x㗟6,<0ҡlL' #"gށY߀=ƛAV7f6t,;0СAn!Mбt#N`CMOAv`fF70""UNA:v`nF7 om\=Ъ~ ;0c 60~ :0cUߺ7-`ҩF6Cq펭ނ-_ҁ#ԡwʜ ק_u/rЯt@@z쀑 %Õ:~C"҃kXoD6+9<`\;/ϷH0z~wdG`Cҙ!F5CO?x"r^ lVr $=z>l;W6t*]9=`T5;T`Cґ14COy{SQ lSq &=|~Uz6t)8>`L:tf_ڸ. 8?`Dv[f=GQir ҅AF40~k&])H[D\8?yQ4'SigcNN^i26(7@`<:t]^A7-C鼁ԡ~{pF(C鼁ҡLjlE6t(]7A`4hDn ,=h6Іt@\z zȷoF(?鶁c١nK!0*;鴁c١Nh@z P I 4 =Htl1. MA:l Aq}`F)Hw 4!=8v߻|F[Zzt@҃cٗVn.b0Φ 5Ј(ص~Ƌ_SUH"0]ސo<8/7g\Йt@#ңbG~ۍ"/vrF` ;:]!ϓz}ȽLЗt@3aG>~^#@`C_MH#0΍kNhHzl=!n 6t%]4А8#ޡ8~W~GD`K $=[hHxHK 4%=6hLz$ l ,]3ИHGPSGShLz$ l)H 4'=6[JXjg -I%p, DSKHJ 4(=6.hPz,#\ɍ_YSueHG t+8[P ːnVzq١!0ЭnQC6,B:ac ܠf lX*H t,<_ciZ*H t-@u_e iZ*H t-@u_e iZ*H t-@u_e i\zW١ ]/йVC6//лVC6//н"UC6/.н"UC6/.н"UC6t/.e \f l^\`Rнt)p*wp%HSJ5;T`C^ujvޥ!PP t"*pw0WA:[`!KJ;:O A ]- \z̠UXR|V/- \f l[:Z`1ҋFзtb+p*kdI/W 5;T`C ^jv$\+P =K ,Jz١zX.WC6t,+0% \f lXV`aKXбt¤,p*_XI/ZR5;T`C *8E \F̥UNX.|nf*H ,PzsUivK(l ߪ۴K ,Rz١zX.SC6*)H \f lT:S`KHЩtB.p*OHJ/^5;T`Cҍ^%jv>+xKP ]J' ,Xz١.X.PC6((d \f lQ:P` 8_*H ,ZznnǴyu y ^zہ0-`ft¥0pv6:L Y ]'p% V/'xE f lOM`ҋ8WНt@e f lNL2TC6t']&P@zg١z(!P Iw ^yjvΤjHd<5;T`CgYE2p*3*"K8KЙt@ f lLJZQC6t QU2pvv:K lHe=t*HG ^zځ,- Un(#3YZ&2ҋ8CЙt@ VC6t&$PGz5P I' ԑ^i5;T`CgIuW3pZЙt@! TC6t&]$PHz9'P x;OHN١!N١!N١V`Cke PC6tC`Cse PC6 lh/؁%- U a \/i9 H/l.vzI d0an6L"jv>0١ a" SC6A`Dҋ8f l[ SI/o* &^5;T`C lNzjvlPzjvlPzjv0FP 0FP yo6L+ȁ15;T`C~lXvjvh>- - lXtGxZ@\|l\tjvh<- . 6L.Ɓq5;4zo6L/Ёjv4 3H/tచ*!9:pP&aTC6 lEzP Yo6#؁Cjv, 3I/v*!;p@%a6PC6$0z١6(jv$ 3J/x൚*! 6(Ёq5;T`Cp0JP "ҁq5;T`t`\ؐ&^*!G`ҋWC6lYzjvW}-aje١b6.=5;T`C٥=f lHy^*!E`C@zjv ١B饗>f l^*!P_ lAzjv*2rP Up6a١6WC6$V0<0f lH*!`6"=5;T`CP #xVC6o6$='5;T`6f lh_ lKz jv lKQ0; q1<١6f*an:*afGZ`|ңب١f^0P c}-a>z*A`*ͷq5;T`UojvYk sJ^` lFz0@6p; I@`Б@6p}-a^lV nt6,=*a>: @0}-afP НXի١f#;WC6̵ Nͱq5;T`cjv +6P 33Z`fX*a& r5;T`L6t)=`jvy֭f lN[0Z`C@z:P ЭxU١f![VC6Ἶf5;T`6t,= `û_m03Z`CFzD֡S<'O lGXgo}?ЇsZ`CHzHzա|> g~lܴ#Wn?}W Z`Cʤ3Un~s)?<6l`C`|~~㻻'aUp~_ lHrGtաozhWOVlglH X:txK>z7co߷K`6,@zPZԡ{m㏿ywwoݑ0 Z`CNzTJԡC`o(_}w01 R=uޫ߼)J?"aJuC"g{sPD`\6,DzX:ԡ{9__W.a&UCO{cG/0 J=u~u{!Ge}-!*=0`z =0% F=uw5~ ]֨=>ػƟ0! B=u12'>qq 2$uաo#?KD`tҾ6(uա;ż׿u6l4URKR6L .k i`\W:<'𡍯<2"a2'=6`uЇB[_怑'6L6}u)gOO`yy^ɈlXCWY)0+Z`C^zt֡~)O'7]6LD`"GLo?}Ͽ׿{>0kZ`C^zvP ذPRC6LC`BK0Z`CVf lJX*a J0  &5;T`@`Â*aUpe_ lC١6DP W}-m'pDОKX*= "5;T`CsW^FМKX*Z`C7֢҃f lhM`CAkQC64vC_ lGzJP l(!=J`%jvnk IX*- E CM}-#iPC64%8U١ZZ`COZ*A` **6t`١6pX١ڹ6%=S`jvv6*P_}-3P l('=V*Z`Cosʫ١ZPPz@u5;T`C# Z`Cwғ١PRz@q5;T`C-Z`Cҳ١PTz@m5;T`CMZ`Cj١PVz@i5;T`CUЦ6)١6pcSC64XZ`C`D  చ* G VC6ܮU_ lTz@]5;T`62PWpf}-S)uP 7P^z@Y5;T`63PVpv}-[AUP ذAUP 7j4PUp# 5PTp}-ca5P ذa5P 7}-g͆f l9 Ep*hnOjv P 7h9PPp}-oP ذ2P Wk::POp5 ;PNp}-wP ذBP W6t/=y*JV)=z*:SgSC6\G`JRC6\eذP W |P ׬iZ`"C^5;T`.~ zP WZ`2L0`jv+lXBjvM"=*rV.=*bH!(f lt}-a)sʨ١.% P ؀Fjv1 IDAT M#=*B64RC6\fʾذ a5P FzA 5;T`E&k KGPBp*ɆIp*6,tS Vf lUK5;T``ذ,&X*ؒIP@pZ`¤,_p> H%X*lI%X*lؓKx5;T`ùk Lt5;T`Ùfk Lt5;T`Ù6p@z4P 癣6,Pz8P AVC6eذDVC6cذHKVC6 60j1uP gZ`20**6, ١6p9FTC64[_ lXŪ١N 1UC62__ lX١NIAKUC60c_ lX١Nң f l8nξذ`aTC65k_ lXe١ f l8f޾ذdyTC6#,Qp}-a f l8 6pTQC6Z`ò9*A`9*atn%P 6p؂ũ١/=`ijv1XzpP #}-aң f l8, H/X*0 \%=`Yjv"}-E١ f l8D`WK0X*P_ l!=`Ajv6p١^K"C f lx b}-0%١6ZdP Ȍ3X*aoZ`CySC6@Q QC6JB f l%& f lk ,Bذ-JI4X*aI4X*aK6Ԓi5;T`Ët_ l%=`jvPLzAjvgPNzAjvgPNzAjv'~+`P O ]o6ԓoп*qz0N:zWC6 &uЩ*YtSN(]4TC6+y ]֏3JG0.Pͺ U+9tf lmZ "=G5;T`j<#:TC6kWJ0ЃP͚{L'=?5;T`b~m8tJ=NجWN+SJ>MجV:+SJO>MجV:+J>LجUN,J?KجT:,JO?KجT:,K?JجSG  f lV)csKozRC61ù~`r١5ڭadz;?0~P UЍ*YcQC6_]zB/jvfu}p~mEzB'jvfm }p]EzB'jvfm }p]GzBjvfe }pMIzBjvf]}p=Kz BjvfU}p-Mz$BjvfM|pOz(B^جH:O2IOEȫ١IiY7|`Fq5;T`z>pSz0BZجF:1gzfVC6s YG#PZW k裆Mjvf%TjvfUjvfUjvf|\[=0􈄠*Yt7m8N.=#!f l gN6KIȩ١HgMo@@zLBLԗ 灀*/]N7 A )5;T`S^:/1oz"ңBjvt3_d8.d%dPMqdpMIK١|{<PC6R9x %=1!f lJKsNo@LzdB@Tv^`n>pIM_vf l ١έZ t#=8an5;T`SU+~G'̬f lJUO@Tzvjvt*_g8d'̫f ljJSOo@Xz~¬jvt(_k8'(̩f l*JwՆOo@\zŒjvt&_o8䥧(̧f l JgOo@cfSC6+uA s١rґ|:Ѓ$PM9HpmBzLjvt#d!=La5;T`SL:o3\AzS0*嚪VARp MDz,jvV`]JOTCTr] lO 3١BZ t*=Uaz5;T`SG.#IU\ؔH@OғVC6U۸B9ЕlPM4ncn%=]aZ5;T`SC.%IWTؔVkI@oTC6b[9Н PM,ngN'=ea:5;T`|*nhFt(=ga25;T`x(ni>(=ia*5;T`t&nj6t)=ka"5;T`p$nk.)=ma5;T`l-vX-O%7qSy ١EkRXą)P͒Z ,CzjvfU!=ta5;T``no+=u*Yt O`t,=w*Yt Oa ,=y*Yt Ob t-={*Yt Oc -=}*Yt Od .=*YtOe t/=*YtOf /=*YtOh ,@zC35;T`8p}}X$Vjvfi <6Y P¤xZwm`ڨ١ejU0pMX<&jvfQ&Z ,Rz"C 5;T`$T)=*YV` p*Yt` ,Hz.jvf);B5$ ١H<+Mo3ܦf l!]3.5Y p*Yte^ ,MzB-jvf ;b[58 7١Hg|M4\f l ާ%JjVt/s7Mp*\:y5\qz)=:5;T`ӷtl& ,Uz`5jvkp-XȆ+PMa74\tz+=r5;T`ӯV`U6\f l5[ lKPMZ ԑp*T:u3+O7\f lݔӛ3p١;7f ,^zjvC>3˗p*OrOo@9g١#7i Tp*MqޖSC6}Inp қ2PEz9jv'龍nBzKHt8Ct$y]H@!'PM?uہ6c`Sjvp1PJz 5;T`Ӊ` oDz7jIOw8f lZ pL [-=ሚ*KWKyWC6qp?1PQzØ*IK7mWކ١tvf%M(*=᠚*Jmo{ރ#١tvg)+=ᵚ* Jlހc^١th/,=a_ĤcG}Io@mjv&&=KzKOVC61p_[/P^zÖ* xL-*hOlĢl١Lt>VA=!iEwxQC6}&Unf lf;1L`+`f l71L`^`m^MthFL-3[05;T`3C<=:pX*a[S[LnlcG# `bmU١OthL,Ub5;T`3s<=:v/X*)knTL Ol6Ew Vf lrrcGnĢkTC68ccGoԢSC68ozcGg=EVf l;wvcٰ 0>šPM[ t>E7֣f lZhlc8$5;T`̥C;6a]u١F.w`bѭ١&`bjvu:f{tZt*գ:=L,PYA]Km(f lnp۔Nlnn9UC6WuFcG7WEJ١4`ZѽjvMs:f{L,QM\pNl^E7!j١K5Q 0ND!5;T`ss9=jx&ݎ(f l|*cٰ Xtc*996WC6gfcEtbjv椩q:f lE)f lNncGqE*f lM<1ۣio;ĢTC611ۣ=ĢSC63}1ۣY>Ģ[ SC6f\RC6fќĢKQC6Ģ[ PC6y E7zWC6QXto5;T`\rԦcG`Zݎ~Pb1E=TC:u1a1ۣE7@zSCL1lXsx#0VHGjv^4}9t>=NP)ksJ}&r#y5;T`זc6'g *Jɣ6guL+sPCvIx,1ۣEy0Z1ۣB1Ģ1ա?ox {_\Z:f{T!Xtz]u?~7>y#ݩ1ۣ<n\>Kx$H\q:f{&9CWf;Kx$s3'is1ۣ0!=uw~<sJ~lnG:f{_E=u|_yǯވO۔g*H#t kS7Oҋ606GE=uދ߼!-Fzg #l27f ~sw '$2Y@3]&O=ӷ.?7f |O>x7?;;}E &! lhH`@CА6჏~~w_|ܑ%8QosBl/q?9r؛;g>Jp_ݳa?[MN#KptO ll_>ɔu;g>J..'jw~H&W(|'#Z'ߌ=˿~xp9,Y6U6\kxs%~|w_> ?MtGG656\v G/tGGy?' p W -_o'\IN#KpΣty p Wca+?>g}{tGGi󃐟+  ג(mֽ+zO&'ݑ%8Qzz|6u6\i/>~&'ݑ%8Qzl p Wܑ%8Qޡ/ 6\INsG*m p Wܑ%8(}}:$'#KpQll8ې;p>rYSқW#6m7"qrYSk,CjjrYkzu;Vx66\khJH&'ݑ%8QCpK{s7z;g?JZ_iD֓( lk lֻl=nUIwd }66\oxK'utGGI`\K` >S~o9,y7ݗY{N#KpΣ$%! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@C/o|g5OՃ_܎>'!z؃_y|wp_: l ~Q>+ى?.Z6@Sc=p̧mg/n "z;m ǂk؛>D'g]jMz3i{5"oG6Ph"^7aB ׈lkc6Ph?94ZnOG T#:؛5"[aoW-Z6@S{w?ç|;dy _y7fw~m϶?dv>|S{vȕ\Gs}a_죝;xhwo{Ҧww>>-~)Lὗ|nGږh7G/{;?ٻ}=tIDAT`!:#;_Z؏~kG~OWjl+Omǁ׈l./=?~l1(+O8i7la7~w|夶#ځđ>?Á>oW8o`}?xK~xQ E~/aiϿ/;Щ{Vػ?x# 㓹R}9`/?B ߗK㈻;թ{V؛?eCT|} ;wvxD}>}\_x#G ~O>7@?6@SqAO _? xQC_gGCO!bce]=F^}  PC;vGko7vO7^y}!:؟ב8dpv|6Phd`׿{?ӋG0 $l ":=dỿo_N/9;lϫ`yN`u첏K??~lNe/ c_أo*G<+?.}H杣^~`oɽ!lNܯ>v}_MgkD^>[}❵z!:{s{uysg=},=?~lN6دOhҏy^`?~\O%@?6@Sv=v𹁽/or{'W`~{@?6@Sg9kG>;7o>7Ux?8x5"ÿxZct!?xo;@?6@S罋ȯ oUGT챃}ݯ.;yf`Ipe|*qOyJ!:ػ1]+P|NvO`3pes?O/ȕtC`4uf~_K #_؏>{ygyn`?~Wwe~)+hd`?tѯv^/ ַ_mOG؏h\n`?2w>r%M#/Ɵn{C;vE}!c <";q乁׆s\NlhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@CА64$! lhH`@C?`csJ0IENDB`bayestestR/man/describe_prior.Rd0000644000176200001440000000353614505754740016456 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/describe_prior.R \name{describe_prior} \alias{describe_prior} \alias{describe_prior.brmsfit} \title{Describe Priors} \usage{ describe_prior(model, ...) \method{describe_prior}{brmsfit}( model, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all", "location", "distributional", "auxiliary"), parameters = NULL, ... ) } \arguments{ \item{model}{A Bayesian model.} \item{...}{Currently not used.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \description{ Returns a summary of the priors used in the model. } \examples{ \donttest{ library(bayestestR) # rstanarm models # ----------------------------------------------- if (require("rstanarm")) { model <- rstanarm::stan_glm(mpg ~ wt + cyl, data = mtcars) describe_prior(model) } # brms models # ----------------------------------------------- if (require("brms")) { model <- brms::brm(mpg ~ wt + cyl, data = mtcars) describe_prior(model) } # BayesFactor objects # ----------------------------------------------- if (require("BayesFactor")) { bf <- ttestBF(x = rnorm(100, 1, 1)) describe_prior(bf) } } } bayestestR/man/bayesfactor_models.Rd0000644000176200001440000001744414560763455017337 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bayesfactor_models.R \name{bayesfactor_models} \alias{bayesfactor_models} \alias{bf_models} \alias{bayesfactor_models.default} \alias{update.bayesfactor_models} \alias{as.matrix.bayesfactor_models} \title{Bayes Factors (BF) for model comparison} \usage{ bayesfactor_models(..., denominator = 1, verbose = TRUE) bf_models(..., denominator = 1, verbose = TRUE) \method{bayesfactor_models}{default}(..., denominator = 1, verbose = TRUE) \method{update}{bayesfactor_models}(object, subset = NULL, reference = NULL, ...) \method{as.matrix}{bayesfactor_models}(x, ...) } \arguments{ \item{...}{Fitted models (see details), all fit on the same data, or a single \code{BFBayesFactor} object (see 'Details'). Ignored in \code{as.matrix()}, \code{update()}. If the following named arguments are present, they are passed to \code{\link[insight:get_loglikelihood]{insight::get_loglikelihood()}} (see details): \itemize{ \item \code{estimator} (defaults to \code{"ML"}) \item \code{check_response} (defaults to \code{FALSE}) }} \item{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 \code{BFBayesFactor}.} \item{verbose}{Toggle off warnings.} \item{object, x}{A \code{\link[=bayesfactor_models]{bayesfactor_models()}} object.} \item{subset}{Vector of model indices to keep or remove.} \item{reference}{Index of model to reference to, or \code{"top"} to reference to the best model, or \code{"bottom"} to reference to the worst model.} } \value{ A data frame containing the models' formulas (reconstructed fixed and random effects) and their \code{log(BF)}s (Use \code{as.numeric()} to extract the non-log Bayes factors; see examples), that prints nicely. } \description{ This function computes or extracts Bayes factors from fitted models. \cr \cr The \verb{bf_*} function is an alias of the main function. } \details{ If the passed models are supported by \strong{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 \code{bayesfactor_inclusion}). \itemize{ \item For \code{brmsfit} or \code{stanreg} models, Bayes factors are computed using the \CRANpkg{bridgesampling} package. \itemize{ \item \code{brmsfit} models must have been fitted with \code{save_pars = save_pars(all = TRUE)}. \item \code{stanreg} models must have been fitted with a defined \code{diagnostic_file}. } \item For \code{BFBayesFactor}, \code{bayesfactor_models()} is mostly a wraparound \code{BayesFactor::extractBF()}. \item For all other model types, Bayes factors are computed using the BIC approximation. Note that BICs are extracted from using \link[insight:get_loglikelihood]{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: \strong{P}roper \strong{P}riors and \strong{P}lentiful \strong{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 (\emph{Gronau, Singmann, & Wagenmakers, 2017}). If less than 40,000 samples are detected, \code{bayesfactor_models()} gives a warning. See also \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}. } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \section{Interpreting Bayes Factors}{ A Bayes factor greater than 1 can be interpreted as evidence against the null, at which one convention is that a Bayes factor greater than 3 can be considered as "substantial" evidence against the null (and vice versa, a Bayes factor smaller than 1/3 indicates substantial evidence in favor of the null-model) (\cite{Wetzels et al. 2011}). } \examples{ \dontshow{if (require("lme4") && require("BayesFactor") && require("rstanarm") && require("brms")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # 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 } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item Gronau, Q. F., Singmann, H., & Wagenmakers, E. J. (2017). Bridgesampling: An R package for estimating normalizing constants. arXiv preprint arXiv:1710.08162. \item Kass, R. E., and Raftery, A. E. (1995). Bayes Factors. Journal of the American Statistical Association, 90(430), 773-795. \item Robert, C. P. (2016). The expected demise of the Bayes factor. Journal of Mathematical Psychology, 72, 33–37. \item Wagenmakers, E. J. (2007). A practical solution to the pervasive problems of p values. Psychonomic bulletin & review, 14(5), 779-804. \item 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} } } \author{ Mattan S. Ben-Shachar } bayestestR/man/dot-select_nums.Rd0000644000176200001440000000040014276606713016554 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{.select_nums} \alias{.select_nums} \title{select numerics columns} \usage{ .select_nums(x) } \description{ select numerics columns } \keyword{internal} bayestestR/man/simulate_simpson.Rd0000644000176200001440000000233114461433341017036 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/simulate_simpson.R \name{simulate_simpson} \alias{simulate_simpson} \title{Simpson's paradox dataset simulation} \usage{ simulate_simpson( n = 100, r = 0.5, groups = 3, difference = 1, group_prefix = "G_" ) } \arguments{ \item{n}{The number of observations for each group to be generated (minimum 4).} \item{r}{A value or vector corresponding to the desired correlation coefficients.} \item{groups}{Number of groups (groups can be participants, clusters, anything).} \item{difference}{Difference between groups.} \item{group_prefix}{The prefix of the group name (e.g., "G_1", "G_2", "G_3", ...).} } \value{ A dataset. } \description{ 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. } \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") } } bayestestR/man/p_direction.Rd0000644000176200001440000002352714561246677015773 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/p_direction.R \name{p_direction} \alias{p_direction} \alias{pd} \alias{p_direction.numeric} \alias{p_direction.data.frame} \alias{p_direction.MCMCglmm} \alias{p_direction.emmGrid} \alias{p_direction.stanreg} \alias{p_direction.brmsfit} \alias{p_direction.BFBayesFactor} \alias{p_direction.get_predicted} \title{Probability of Direction (pd)} \usage{ p_direction(x, ...) pd(x, ...) \method{p_direction}{numeric}(x, method = "direct", null = 0, ...) \method{p_direction}{data.frame}(x, method = "direct", null = 0, ...) \method{p_direction}{MCMCglmm}(x, method = "direct", null = 0, ...) \method{p_direction}{emmGrid}(x, method = "direct", null = 0, ...) \method{p_direction}{stanreg}( x, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, method = "direct", null = 0, ... ) \method{p_direction}{brmsfit}( x, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, method = "direct", null = 0, ... ) \method{p_direction}{BFBayesFactor}(x, method = "direct", null = 0, ...) \method{p_direction}{get_predicted}( x, method = "direct", null = 0, use_iterations = FALSE, verbose = TRUE, ... ) } \arguments{ \item{x}{A vector representing a posterior distribution, a data frame of posterior draws (samples be parameter). Can also be a Bayesian model.} \item{...}{Currently not used.} \item{method}{Can be \code{"direct"} or one of methods of \code{\link[=estimate_density]{estimate_density()}}, such as \code{"kernel"}, \code{"logspline"} or \code{"KernSmooth"}. See details.} \item{null}{The value considered as a "null" effect. Traditionally 0, but could also be 1 in the case of ratios of change (OR, IRR, ...).} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} \item{verbose}{Toggle off warnings.} } \value{ Values between 0.5 and 1 \emph{or} between 0 and 1 (see above) corresponding to the probability of direction (pd). } \description{ Compute the \strong{Probability of Direction} (\emph{\strong{pd}}, also known as the Maximum Probability of Effect - \emph{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 (\emph{i.e.}, is strongly correlated) to the frequentist \strong{p-value} (see details). } \details{ \subsection{What is the \emph{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: \itemize{ \item Like other posterior-based indices, \emph{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). \item It is robust to the scale of both the response variable and the predictors. \item 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). } } \subsection{Relationship with the p-value}{ In most cases, it seems that the \emph{pd} has a direct correspondence with the frequentist one-sided \emph{p}-value through the formula (for two-sided \emph{p}): \deqn{p = 2 \times (1 - p_d)}{p = 2 * (1 - pd)} Thus, a two-sided p-value of respectively \code{.1}, \code{.05}, \code{.01} and \code{.001} would correspond approximately to a \emph{pd} of \verb{95\%}, \verb{97.5\%}, \verb{99.5\%} and \verb{99.95\%}. See \code{\link[=pd_to_p]{pd_to_p()}} for details. } \subsection{Possible Range of Values}{ The largest value \emph{pd} can take is 1 - the posterior is strictly directional. However, the smallest value \emph{pd} can take depends on the parameter space represented by the posterior. \cr\cr \strong{For a continuous parameter space}, exact values of 0 (or any point null value) are not possible, and so 100\% of the posterior has \emph{some} sign, some positive, some negative. Therefore, the smallest the \emph{pd} can be is 0.5 - with an equal posterior mass of positive and negative values. Values close to 0.5 \emph{cannot} be used to support the null hypothesis (that the parameter does \emph{not} have a direction) is a similar why to how large p-values cannot be used to support the null hypothesis (see \code{\link[=pd_to_p]{pd_to_p()}}; Makowski et al., 2019). \cr\cr \strong{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) \emph{are} possible! Therefore, the smallest the \emph{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: \itemize{ \item When a parameter can only take discrete values. \item When a mixture prior/posterior is used (such as the spike-and-slab prior; see van den Bergh et al., 2021). \item When conducting Bayesian model averaging (e.g., \code{\link[=weighted_posteriors]{weighted_posteriors()}} or \code{brms::posterior_average}). } } \subsection{Methods of computation}{ The \emph{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 \emph{pd} is to compute the proportion of positive (or larger than \code{null}) posterior samples, the proportion of negative (or smaller than \code{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 \link[=estimate_density]{density estimation}: It starts by estimating the continuous-smooth density function (for which many methods are available), and then computing the \link[=area_under_curve]{area under the curve} (AUC) of the density curve on either side of \code{null} and taking the maximum between them. Note the this approach assumes a continuous density function, and so \strong{when the posterior represents a (partially) discrete parameter space, only the direct method \emph{must} be used} (see above). } } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \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") } } } \references{ \itemize{ \item 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} \item 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} } } \seealso{ \code{\link[=pd_to_p]{pd_to_p()}} to convert between Probability of Direction (pd) and p-value. } bayestestR/man/dot-prior_new_location.Rd0000644000176200001440000000051414276606713020135 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sensitivity_to_prior.R \name{.prior_new_location} \alias{.prior_new_location} \title{Set a new location for a prior} \usage{ .prior_new_location(prior, sign, magnitude = 10) } \description{ Set a new location for a prior } \keyword{internal} bayestestR/man/describe_posterior.Rd0000644000176200001440000001755714560763455017365 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/describe_posterior.R \name{describe_posterior} \alias{describe_posterior} \alias{describe_posterior.numeric} \alias{describe_posterior.stanreg} \alias{describe_posterior.brmsfit} \title{Describe Posterior Distributions} \usage{ describe_posterior(posterior, ...) \method{describe_posterior}{numeric}( posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, BF = 1, verbose = TRUE, ... ) \method{describe_posterior}{stanreg}( posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, diagnostic = c("ESS", "Rhat"), priors = FALSE, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, BF = 1, verbose = TRUE, ... ) \method{describe_posterior}{brmsfit}( posterior, centrality = "median", dispersion = FALSE, ci = 0.95, ci_method = "eti", test = c("p_direction", "rope"), rope_range = "default", rope_ci = 0.95, keep_iterations = FALSE, bf_prior = NULL, diagnostic = c("ESS", "Rhat"), effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all", "location", "distributional", "auxiliary"), parameters = NULL, BF = 1, priors = FALSE, verbose = TRUE, ... ) } \arguments{ \item{posterior}{A vector, data frame or model of posterior draws. \strong{bayestestR} supports a wide range of models (see \code{methods("describe_posterior")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} method.} \item{...}{Additional arguments to be passed to or from methods.} \item{centrality}{The point-estimates (centrality indices) to compute. Character (vector) or list with one or more of these options: \code{"median"}, \code{"mean"}, \code{"MAP"} (see \code{\link[=map_estimate]{map_estimate()}}), \code{"trimmed"} (which is just \code{mean(x, trim = threshold)}), \code{"mode"} or \code{"all"}.} \item{dispersion}{Logical, if \code{TRUE}, computes indices of dispersion related to the estimate(s) (\code{SD} and \code{MAD} for \code{mean} and \code{median}, respectively). Dispersion is not available for \code{"MAP"} or \code{"mode"} centrality indices.} \item{ci}{Value or vector of probability of the CI (between 0 and 1) to be estimated. Default to \code{0.95} (\verb{95\%}).} \item{ci_method}{The type of index used for Credible Interval. Can be \code{"ETI"} (default, see \code{\link[=eti]{eti()}}), \code{"HDI"} (see \code{\link[=hdi]{hdi()}}), \code{"BCI"} (see \code{\link[=bci]{bci()}}), \code{"SPI"} (see \code{\link[=spi]{spi()}}), or \code{"SI"} (see \code{\link[=si]{si()}}).} \item{test}{The indices of effect existence to compute. Character (vector) or list with one or more of these options: \code{"p_direction"} (or \code{"pd"}), \code{"rope"}, \code{"p_map"}, \code{"equivalence_test"} (or \code{"equitest"}), \code{"bayesfactor"} (or \code{"bf"}) or \code{"all"} to compute all tests. For each "test", the corresponding \pkg{bayestestR} function is called (e.g. \code{\link[=rope]{rope()}} or \code{\link[=p_direction]{p_direction()}}) and its results included in the summary output.} \item{rope_range}{ROPE's lower and higher bounds. Should be a list of two values (e.g., \code{c(-0.1, 0.1)}) or \code{"default"}. If \code{"default"}, the bounds are set to \code{x +- 0.1*SD(response)}.} \item{rope_ci}{The Credible Interval (CI) probability, corresponding to the proportion of HDI, to use for the percentage in ROPE.} \item{keep_iterations}{If \code{TRUE}, will keep all iterations (draws) of bootstrapped or Bayesian models. They will be added as additional columns named \verb{iter_1, iter_2, ...}. You can reshape them to a long format by running \code{\link[=reshape_iterations]{reshape_iterations()}}.} \item{bf_prior}{Distribution representing a prior for the computation of Bayes factors / SI. Used if the input is a posterior, otherwise (in the case of models) ignored.} \item{BF}{The amount of support required to be included in the support interval.} \item{verbose}{Toggle off warnings.} \item{diagnostic}{Diagnostic metrics to compute. Character (vector) or list with one or more of these options: \code{"ESS"}, \code{"Rhat"}, \code{"MCSE"} or \code{"all"}.} \item{priors}{Add the prior used for each parameter.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} } \description{ Compute indices relevant to describe and characterize the posterior distributions. } \details{ One or more components of point estimates (like posterior mean or median), intervals and tests can be omitted from the summary output by setting the related argument to \code{NULL}. For example, \code{test = NULL} and \code{centrality = NULL} would only return the HDI (or CI). } \examples{ library(bayestestR) if (require("logspline")) { x <- rnorm(1000) describe_posterior(x, verbose = FALSE) describe_posterior(x, centrality = "all", dispersion = TRUE, test = "all", verbose = FALSE ) describe_posterior(x, ci = c(0.80, 0.90), verbose = FALSE) df <- data.frame(replicate(4, rnorm(100))) describe_posterior(df, verbose = FALSE) describe_posterior( df, centrality = "all", dispersion = TRUE, test = "all", verbose = FALSE ) describe_posterior(df, ci = c(0.80, 0.90), verbose = FALSE) df <- data.frame(replicate(4, rnorm(20))) head(reshape_iterations( describe_posterior(df, keep_iterations = TRUE, verbose = FALSE) )) } \donttest{ # rstanarm models # ----------------------------------------------- if (require("rstanarm") && require("emmeans")) { model <- suppressWarnings( stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) ) describe_posterior(model) describe_posterior(model, centrality = "all", dispersion = TRUE, test = "all") describe_posterior(model, ci = c(0.80, 0.90)) # emmeans estimates # ----------------------------------------------- describe_posterior(emtrends(model, ~1, "wt")) } # BayesFactor objects # ----------------------------------------------- if (require("BayesFactor")) { bf <- ttestBF(x = rnorm(100, 1, 1)) describe_posterior(bf) describe_posterior(bf, centrality = "all", dispersion = TRUE, test = "all") describe_posterior(bf, ci = c(0.80, 0.90)) } } } \references{ \itemize{ \item Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and Lüdecke, D. (2019). \emph{Indices of Effect Existence and Significance in the Bayesian Framework}. Frontiers in Psychology 2019;10:2767. \doi{10.3389/fpsyg.2019.02767} \item \href{https://easystats.github.io/bayestestR/articles/region_of_practical_equivalence.html}{Region of Practical Equivalence (ROPE)} \item \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{Bayes factors} } } bayestestR/man/bayestestR-package.Rd0000644000176200001440000000502314560763455017176 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bayestestR-package.R \docType{package} \name{bayestestR-package} \alias{bayestestR-package} \alias{bayestestR} \title{bayestestR: Describing Effects and their Uncertainty, Existence and Significance within the Bayesian Framework} \description{ Existing R packages allow users to easily fit a large variety of models and extract and visualize the posterior draws. However, most of these packages only return a limited set of indices (e.g., point-estimates and CIs). \strong{bayestestR} provides a comprehensive and consistent set of functions to analyze and describe posterior distributions generated by a variety of models objects, including popular modeling packages such as \strong{rstanarm}, \strong{brms} or \strong{BayesFactor}. References: \itemize{ \item Makowski et al. (2019) \doi{10.21105/joss.01541} \item Makowski et al. (2019) \doi{10.3389/fpsyg.2019.02767} } } \details{ \code{bayestestR} } \seealso{ Useful links: \itemize{ \item \url{https://easystats.github.io/bayestestR/} \item Report bugs at \url{https://github.com/easystats/bayestestR/issues} } } \author{ \strong{Maintainer}: Dominique Makowski \email{dom.makowski@gmail.com} (\href{https://orcid.org/0000-0001-5375-9967}{ORCID}) (@Dom_Makowski) Authors: \itemize{ \item Daniel Lüdecke \email{d.luedecke@uke.de} (\href{https://orcid.org/0000-0002-8895-3206}{ORCID}) (@strengejacke) \item Mattan S. Ben-Shachar \email{matanshm@post.bgu.ac.il} (\href{https://orcid.org/0000-0002-4287-4801}{ORCID}) (@mattansb) \item Indrajeet Patil \email{patilindrajeet.science@gmail.com} (\href{https://orcid.org/0000-0003-1995-6531}{ORCID}) (@patilindrajeets) \item Michael D. Wilson \email{michael.d.wilson@curtin.edu.au} (\href{https://orcid.org/0000-0003-4143-7308}{ORCID}) \item Brenton M. Wiernik \email{brenton@wiernik.org} (\href{https://orcid.org/0000-0001-9560-6336}{ORCID}) (@bmwiernik) } Other contributors: \itemize{ \item Paul-Christian Bürkner \email{paul.buerkner@gmail.com} [reviewer] \item Tristan Mahr \email{tristan.mahr@wisc.edu} (\href{https://orcid.org/0000-0002-8890-5116}{ORCID}) [reviewer] \item Henrik Singmann \email{singmann@gmail.com} (\href{https://orcid.org/0000-0002-4842-3657}{ORCID}) [contributor] \item Quentin F. Gronau (\href{https://orcid.org/0000-0001-5510-6943}{ORCID}) [contributor] \item Sam Crawley \email{sam@crawley.nz} (\href{https://orcid.org/0000-0002-7847-0411}{ORCID}) [contributor] } } \keyword{internal} bayestestR/man/convert_bayesian_as_frequentist.Rd0000644000176200001440000000315614560763455022134 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convert_bayesian_to_frequentist.R \name{convert_bayesian_as_frequentist} \alias{convert_bayesian_as_frequentist} \alias{bayesian_as_frequentist} \title{Convert (refit) a Bayesian model to frequentist} \usage{ convert_bayesian_as_frequentist(model, data = NULL, REML = TRUE) bayesian_as_frequentist(model, data = NULL, REML = TRUE) } \arguments{ \item{model}{A Bayesian model.} \item{data}{Data used by the model. If \code{NULL}, will try to extract it from the model.} \item{REML}{For mixed effects, should models be estimated using restricted maximum likelihood (REML) (\code{TRUE}, default) or maximum likelihood (\code{FALSE})?} } \description{ Refit Bayesian model as frequentist. Can be useful for comparisons. } \examples{ \dontshow{if (require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ # Rstanarm ---------------------- # Simple regressions model <- rstanarm::stan_glm(Sepal.Length ~ Species, data = iris, chains = 2, refresh = 0 ) bayesian_as_frequentist(model) model <- rstanarm::stan_glm(vs ~ mpg, family = "binomial", data = mtcars, chains = 2, refresh = 0 ) bayesian_as_frequentist(model) # Mixed models model <- rstanarm::stan_glmer( Sepal.Length ~ Petal.Length + (1 | Species), data = iris, chains = 2, refresh = 0 ) bayesian_as_frequentist(model) model <- rstanarm::stan_glmer(vs ~ mpg + (1 | cyl), family = "binomial", data = mtcars, chains = 2, refresh = 0 ) bayesian_as_frequentist(model) } \dontshow{\}) # examplesIf} } bayestestR/man/sexit_thresholds.Rd0000644000176200001440000000300414505754740017044 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sexit_thresholds.R \name{sexit_thresholds} \alias{sexit_thresholds} \title{Find Effect Size Thresholds} \usage{ sexit_thresholds(x, ...) } \arguments{ \item{x}{Vector representing a posterior distribution. Can also be a \code{stanreg} or \code{brmsfit} model.} \item{...}{Currently not used.} } \description{ This function attempts at automatically finding suitable default values for a "significant" (i.e., non-negligible) and "large" effect. This is to be used with care, and the chosen threshold should always be explicitly reported and justified. See the detail section in \code{\link[=sexit]{sexit()}} for more information. } \examples{ sexit_thresholds(rnorm(1000)) \donttest{ if (require("rstanarm")) { model <- suppressWarnings(stan_glm( mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0 )) sexit_thresholds(model) model <- suppressWarnings( stan_glm(vs ~ mpg, data = mtcars, family = "binomial", refresh = 0) ) sexit_thresholds(model) } if (require("brms")) { model <- brm(mpg ~ wt + cyl, data = mtcars) sexit_thresholds(model) } if (require("BayesFactor")) { bf <- ttestBF(x = rnorm(100, 1, 1)) sexit_thresholds(bf) } } } \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}. } bayestestR/man/mediation.Rd0000644000176200001440000001441514650172354015426 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mediation.R \name{mediation} \alias{mediation} \alias{mediation.brmsfit} \alias{mediation.stanmvreg} \title{Summary of Bayesian multivariate-response mediation-models} \usage{ mediation(model, ...) \method{mediation}{brmsfit}( model, treatment, mediator, response = NULL, centrality = "median", ci = 0.95, method = "ETI", ... ) \method{mediation}{stanmvreg}( model, treatment, mediator, response = NULL, centrality = "median", ci = 0.95, method = "ETI", ... ) } \arguments{ \item{model}{A \code{brmsfit} or \code{stanmvreg} object.} \item{...}{Not used.} \item{treatment}{Character, name of the treatment variable (or direct effect) in a (multivariate response) mediator-model. If missing, \code{mediation()} tries to find the treatment variable automatically, however, this may fail.} \item{mediator}{Character, name of the mediator variable in a (multivariate response) mediator-model. If missing, \code{mediation()} tries to find the treatment variable automatically, however, this may fail.} \item{response}{A named character vector, indicating the names of the response variables to be used for the mediation analysis. Usually can be \code{NULL}, in which case these variables are retrieved automatically. If not \code{NULL}, names should match the names of the model formulas, \code{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 \code{m} is used as response variable, but the centered version \code{m_center} is used as mediator variable. The second response variable (for the treatment model, with the mediator as additional predictor), \code{y}, is not transformed. Then we could use \code{response} like this: \code{mediation(model, response = c(m = "m_center", y = "y"))}.} \item{centrality}{The point-estimates (centrality indices) to compute. Character (vector) or list with one or more of these options: \code{"median"}, \code{"mean"}, \code{"MAP"} (see \code{\link[=map_estimate]{map_estimate()}}), \code{"trimmed"} (which is just \code{mean(x, trim = threshold)}), \code{"mode"} or \code{"all"}.} \item{ci}{Value or vector of probability of the CI (between 0 and 1) to be estimated. Default to \code{0.95} (\verb{95\%}).} \item{method}{Can be \link[=eti]{"ETI"} (default), \link[=hdi]{"HDI"}, \link[=bci]{"BCI"}, \link[=spi]{"SPI"} or \link[=si]{"SI"}.} } \value{ 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 \code{centrality} for other centrality indices). } \description{ \code{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. } \details{ \code{mediation()} returns a data frame with information on the \emph{direct effect} (mean value of posterior samples from \code{treatment} of the outcome model), \emph{mediator effect} (mean value of posterior samples from \code{mediator} of the outcome model), \emph{indirect effect} (mean value of the multiplication of the posterior samples from \code{mediator} of the outcome model and the posterior samples from \code{treatment} of the mediation model) and the total effect (mean value of sums of posterior samples used for the direct and indirect effect). The \emph{proportion mediated} is the indirect effect divided by the total effect. For all values, the \verb{89\%} credible intervals are calculated by default. Use \code{ci} to calculate a different interval. The arguments \code{treatment} and \code{mediator} do not necessarily need to be specified. If missing, \code{mediation()} tries to find the treatment and mediator variable automatically. If this does not work, specify these variables. The direct effect is also called \emph{average direct effect} (ADE), the indirect effect is also called \emph{average causal mediation effects} (ACME). See also \emph{Tingley et al. 2014} and \emph{Imai et al. 2010}. } \note{ There is an \code{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. } \examples{ \dontshow{if (require("mediation") && require("brms") && require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \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) } \dontshow{\}) # examplesIf} } \references{ \itemize{ \item 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. \item 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. } bayestestR/man/as.data.frame.density.Rd0000644000176200001440000000061614276606712017541 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/estimate_density.R \name{as.data.frame.density} \alias{as.data.frame.density} \title{Coerce to a Data Frame} \usage{ \method{as.data.frame}{density}(x, ...) } \arguments{ \item{x}{any \R object.} \item{...}{additional arguments to be passed to or from methods.} } \description{ Coerce to a Data Frame } bayestestR/man/simulate_prior.Rd0000644000176200001440000000160414505754740016513 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/simulate_priors.R \name{simulate_prior} \alias{simulate_prior} \title{Returns Priors of a Model as Empirical Distributions} \usage{ simulate_prior(model, n = 1000, ...) } \arguments{ \item{model}{A \code{stanreg}, \code{stanfit}, \code{brmsfit}, \code{blavaan}, or \code{MCMCglmm} object.} \item{n}{Size of the simulated prior distributions.} \item{...}{Currently not used.} } \description{ Transforms priors information to actual distributions. } \examples{ \donttest{ library(bayestestR) if (require("rstanarm")) { model <- suppressWarnings( stan_glm(mpg ~ wt + am, data = mtcars, chains = 1, refresh = 0) ) simulate_prior(model) } } } \seealso{ \code{\link[=unupdate]{unupdate()}} for directly sampling from the prior distribution (useful for complex priors and designs). } bayestestR/man/check_prior.Rd0000644000176200001440000000447114650172354015746 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/check_prior.R \name{check_prior} \alias{check_prior} \title{Check if Prior is Informative} \usage{ check_prior(model, method = "gelman", simulate_priors = TRUE, ...) } \arguments{ \item{model}{A \code{stanreg}, \code{stanfit}, \code{brmsfit}, \code{blavaan}, or \code{MCMCglmm} object.} \item{method}{Can be \code{"gelman"} or \code{"lakeland"}. For the \code{"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 \code{"lakeland"} method, the prior is considered as informative if the posterior falls within the \verb{95\%} HDI of the prior.} \item{simulate_priors}{Should prior distributions be simulated using \code{\link[=simulate_prior]{simulate_prior()}} (default; faster) or sampled via \code{\link[=unupdate]{unupdate()}} (slower, more accurate).} \item{...}{Currently not used.} } \value{ A data frame with two columns: The parameter names and the quality of the prior (which might be \code{"informative"}, \code{"uninformative"}) or \code{"not determinable"} if the prior distribution could not be determined). } \description{ Performs a simple test to check whether the prior is informative to the posterior. This idea, and the accompanying heuristics, were discussed in \emph{Gelman et al. 2017}. } \examples{ \dontshow{if (require("rstanarm") && require("see")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \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)) } \dontshow{\}) # examplesIf} } \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} } bayestestR/man/contr.equalprior.Rd0000644000176200001440000001504714307033260016755 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/contr.equalprior.R \name{contr.equalprior} \alias{contr.equalprior} \alias{contr.bayes} \alias{contr.orthonorm} \alias{contr.equalprior_pairs} \alias{contr.equalprior_deviations} \title{Contrast Matrices for Equal Marginal Priors in Bayesian Estimation} \usage{ contr.equalprior(n, contrasts = TRUE, sparse = FALSE) contr.equalprior_pairs(n, contrasts = TRUE, sparse = FALSE) contr.equalprior_deviations(n, contrasts = TRUE, sparse = FALSE) } \arguments{ \item{n}{a vector of levels for a factor, or the number of levels.} \item{contrasts}{a logical indicating whether contrasts should be computed.} \item{sparse}{logical indicating if the result should be sparse (of class \code{\link[Matrix:dgCMatrix-class]{dgCMatrix}}), using package \href{https://CRAN.R-project.org/package=Matrix}{\pkg{Matrix}}.} } \value{ A \code{matrix} with n rows and k columns, with k=n-1 if contrasts is \code{TRUE} and k=n if contrasts is \code{FALSE}. } \description{ Build contrasts for factors with equal marginal priors on all levels. The 3 functions give the same orthogonal contrasts, but are scaled differently to allow different prior specifications (see 'Details'). Implementation from Singmann & Gronau's \href{https://github.com/bayesstuff/bfrms/}{\code{bfrms}}, following the description in Rouder, Morey, Speckman, & Province (2012, p. 363). } \details{ When using \code{\link[stats:contrast]{stats::contr.treatment}}, each dummy variable is the difference between each level and the reference level. While this is useful if setting different priors for each coefficient, it should not be used if one is trying to set a general prior for differences between means, as it (as well as \code{\link[stats:contrast]{stats::contr.sum}} and others) results in unequal marginal priors on the means the the difference between them. \if{html}{\out{

}}\preformatted{library(brms) data <- data.frame( group = factor(rep(LETTERS[1:4], each = 3)), y = rnorm(12) ) contrasts(data$group) # R's default contr.treatment #> B C D #> A 0 0 0 #> B 1 0 0 #> C 0 1 0 #> D 0 0 1 model_prior <- brm( y ~ group, data = data, sample_prior = "only", # Set the same priors on the 3 dummy variable # (Using an arbitrary scale) prior = set_prior("normal(0, 10)", coef = c("groupB", "groupC", "groupD")) ) est <- emmeans::emmeans(model_prior, pairwise ~ group) point_estimate(est, centr = "mean", disp = TRUE) #> Point Estimate #> #> Parameter | Mean | SD #> ------------------------- #> A | -0.01 | 6.35 #> B | -0.10 | 9.59 #> C | 0.11 | 9.55 #> D | -0.16 | 9.52 #> A - B | 0.10 | 9.94 #> A - C | -0.12 | 9.96 #> A - D | 0.15 | 9.87 #> B - C | -0.22 | 14.38 #> B - D | 0.05 | 14.14 #> C - D | 0.27 | 14.00 }\if{html}{\out{
}} We can see that the priors for means aren't all the same (\code{A} having a more narrow prior), and likewise for the pairwise differences (priors for differences from \code{A} are more narrow). The solution is to use one of the methods provided here, which \emph{do} result in marginally equal priors on means differences between them. Though this will obscure the interpretation of parameters, setting equal priors on means and differences is important for they are useful for specifying equal priors on all means in a factor and their differences correct estimation of Bayes factors for contrasts and order restrictions of multi-level factors (where \code{k>2}). See info on specifying correct priors for factors with more than 2 levels in \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}. \emph{\strong{NOTE:}} When setting priors on these dummy variables, always: \enumerate{ \item Use priors that are \strong{centered on 0}! Other location/centered priors are meaningless! \item Use \strong{identically-scaled priors} on all the dummy variables of a single factor! } \code{contr.equalprior} returns the original orthogonal-normal contrasts as described in Rouder, Morey, Speckman, & Province (2012, p. 363). Setting \code{contrasts = FALSE} returns the \eqn{I_{n} - \frac{1}{n}} matrix. \subsection{\code{contr.equalprior_pairs}}{ Useful for setting priors in terms of pairwise differences between means - the scales of the priors defines the prior distribution of the pair-wise differences between all pairwise differences (e.g., \code{A - B}, \code{B - C}, etc.). \if{html}{\out{
}}\preformatted{contrasts(data$group) <- contr.equalprior_pairs contrasts(data$group) #> [,1] [,2] [,3] #> A 0.0000000 0.6123724 0.0000000 #> B -0.1893048 -0.2041241 0.5454329 #> C -0.3777063 -0.2041241 -0.4366592 #> D 0.5670111 -0.2041241 -0.1087736 model_prior <- brm( y ~ group, data = data, sample_prior = "only", # Set the same priors on the 3 dummy variable # (Using an arbitrary scale) prior = set_prior("normal(0, 10)", coef = c("group1", "group2", "group3")) ) est <- emmeans(model_prior, pairwise ~ group) point_estimate(est, centr = "mean", disp = TRUE) #> Point Estimate #> #> Parameter | Mean | SD #> ------------------------- #> A | -0.31 | 7.46 #> B | -0.24 | 7.47 #> C | -0.34 | 7.50 #> D | -0.30 | 7.25 #> A - B | -0.08 | 10.00 #> A - C | 0.03 | 10.03 #> A - D | -0.01 | 9.85 #> B - C | 0.10 | 10.28 #> B - D | 0.06 | 9.94 #> C - D | -0.04 | 10.18 }\if{html}{\out{
}} All means have the same prior distribution, and the distribution of the differences matches the prior we set of \code{"normal(0, 10)"}. Success! } \subsection{\code{contr.equalprior_deviations}}{ Useful for setting priors in terms of the deviations of each mean from the grand mean - the scales of the priors defines the prior distribution of the distance (above, below) the mean of one of the levels might have from the overall mean. (See examples.) } } \examples{ contr.equalprior(2) # Q_2 in Rouder et al. (2012, p. 363) contr.equalprior(5) # equivalent to Q_5 in Rouder et al. (2012, p. 363) ## check decomposition Q3 <- contr.equalprior(3) Q3 \%*\% t(Q3) ## 2/3 on diagonal and -1/3 on off-diagonal elements } \references{ Rouder, J. N., Morey, R. D., Speckman, P. L., & Province, J. M. (2012). Default Bayes factors for ANOVA designs. \emph{Journal of Mathematical Psychology}, 56(5), 356-374. https://doi.org/10.1016/j.jmp.2012.08.001 } bayestestR/man/estimate_density.Rd0000644000176200001440000001204214650172354017021 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/estimate_density.R \name{estimate_density} \alias{estimate_density} \alias{estimate_density.data.frame} \title{Density Estimation} \usage{ estimate_density(x, ...) \method{estimate_density}{data.frame}( x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ci = NULL, select = NULL, by = NULL, at = NULL, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Currently not used.} \item{method}{Density estimation method. Can be \code{"kernel"} (default), \code{"logspline"} or \code{"KernSmooth"}.} \item{precision}{Number of points of density data. See the \code{n} parameter in \code{density}.} \item{extend}{Extend the range of the x axis by a factor of \code{extend_scale}.} \item{extend_scale}{Ratio of range by which to extend the x axis. A value of \code{0.1} means that the x axis will be extended by \code{1/10} of the range of the data.} \item{bw}{See the eponymous argument in \code{density}. Here, the default has been changed for \code{"SJ"}, which is recommended.} \item{ci}{The confidence interval threshold. Only used when \code{method = "kernel"}. This feature is experimental, use with caution.} \item{select}{Character vector of column names. If \code{NULL} (the default), all numeric variables will be selected. Other arguments from \code{\link[datawizard:extract_column_names]{datawizard::extract_column_names()}} (such as \code{exclude}) can also be used.} \item{by}{Optional character vector. If not \code{NULL} and input is a data frame, density estimation is performed for each group (subsets) indicated by \code{by}. See examples.} \item{at}{Deprecated in favour of \code{by}.} } \description{ This function is a wrapper over different methods of density estimation. By default, it uses the base R \code{density} with by default uses a different smoothing bandwidth (\code{"SJ"}) from the legacy default implemented the base R \code{density} function (\code{"nrd0"}). However, Deng and Wickham suggest that \code{method = "KernSmooth"} is the fastest and the most accurate. } \note{ There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \examples{ \dontshow{if (require("logspline") && require("KernSmooth") && require("mclust") && require("emmeans") && require("rstanarm") && require("brms")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(bayestestR) set.seed(1) x <- rnorm(250, mean = 1) # Basic usage density_kernel <- estimate_density(x) # default method is "kernel" hist(x, prob = TRUE) lines(density_kernel$x, density_kernel$y, col = "black", lwd = 2) lines(density_kernel$x, density_kernel$CI_low, col = "gray", lty = 2) lines(density_kernel$x, density_kernel$CI_high, col = "gray", lty = 2) legend("topright", legend = c("Estimate", "95\% CI"), col = c("black", "gray"), lwd = 2, lty = c(1, 2) ) # Other Methods density_logspline <- estimate_density(x, method = "logspline") density_KernSmooth <- estimate_density(x, method = "KernSmooth") density_mixture <- estimate_density(x, method = "mixture") hist(x, prob = TRUE) lines(density_kernel$x, density_kernel$y, col = "black", lwd = 2) lines(density_logspline$x, density_logspline$y, col = "red", lwd = 2) lines(density_KernSmooth$x, density_KernSmooth$y, col = "blue", lwd = 2) lines(density_mixture$x, density_mixture$y, col = "green", lwd = 2) # Extension density_extended <- estimate_density(x, extend = TRUE) density_default <- estimate_density(x, extend = FALSE) hist(x, prob = TRUE) lines(density_extended$x, density_extended$y, col = "red", lwd = 3) lines(density_default$x, density_default$y, col = "black", lwd = 3) # Multiple columns head(estimate_density(iris)) head(estimate_density(iris, select = "Sepal.Width")) # Grouped data head(estimate_density(iris, by = "Species")) head(estimate_density(iris$Petal.Width, by = iris$Species)) \donttest{ # rstanarm models # ----------------------------------------------- library(rstanarm) model <- suppressWarnings( stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) ) head(estimate_density(model)) library(emmeans) head(estimate_density(emtrends(model, ~1, "wt", data = mtcars))) # brms models # ----------------------------------------------- library(brms) model <- brms::brm(mpg ~ wt + cyl, data = mtcars) estimate_density(model) } \dontshow{\}) # examplesIf} } \references{ Deng, H., & Wickham, H. (2011). Density estimation in R. Electronic publication. } bayestestR/man/eti.Rd0000644000176200001440000001630514560763455014246 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eti.R \name{eti} \alias{eti} \alias{eti.numeric} \alias{eti.stanreg} \alias{eti.brmsfit} \alias{eti.get_predicted} \title{Equal-Tailed Interval (ETI)} \usage{ eti(x, ...) \method{eti}{numeric}(x, ci = 0.95, verbose = TRUE, ...) \method{eti}{stanreg}( x, ci = 0.95, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = TRUE, ... ) \method{eti}{brmsfit}( x, ci = 0.95, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, ... ) \method{eti}{get_predicted}(x, ci = 0.95, use_iterations = FALSE, verbose = TRUE, ...) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Currently not used.} \item{ci}{Value or vector of probability of the (credible) interval - CI (between 0 and 1) to be estimated. Default to \code{.95} (\verb{95\%}).} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} } \value{ A data frame with following columns: \itemize{ \item \code{Parameter} The model parameter(s), if \code{x} is a model-object. If \code{x} is a vector, this column is missing. \item \code{CI} The probability of the credible interval. \item \code{CI_low}, \code{CI_high} The lower and upper credible interval limits for the parameters. } } \description{ Compute the \strong{Equal-Tailed Interval (ETI)} of posterior distributions using the quantiles method. The probability of being below this interval is equal to the probability of being above it. The ETI can be used in the context of uncertainty characterisation of posterior distributions as \strong{Credible Interval (CI)}. } \details{ Unlike equal-tailed intervals (see \code{eti()}) that typically exclude \verb{2.5\%} from each tail of the distribution and always include the median, the HDI is \emph{not} equal-tailed and therefore always includes the mode(s) of posterior distributions. While this can be useful to better represent the credibility mass of a distribution, the HDI also has some limitations. See \code{\link[=spi]{spi()}} for details. The \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{\verb{95\%} or \verb{89\%} Credible Intervals (CI)} are two reasonable ranges to characterize the uncertainty related to the estimation (see \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{here} for a discussion about the differences between these two values). The \verb{89\%} intervals (\code{ci = 0.89}) are deemed to be more stable than, for instance, \verb{95\%} intervals (\emph{Kruschke, 2014}). An effective sample size of at least 10.000 is recommended if one wants to estimate \verb{95\%} intervals with high precision (\emph{Kruschke, 2014, p. 183ff}). Unfortunately, the default number of posterior samples for most Bayes packages (e.g., \code{rstanarm} or \code{brms}) is only 4.000 (thus, you might want to increase it when fitting your model). Moreover, 89 indicates the arbitrariness of interval limits - its only remarkable property is being the highest prime number that does not exceed the already unstable \verb{95\%} threshold (\emph{McElreath, 2015}). However, \verb{95\%} has some \href{https://easystats.github.io/blog/posts/bayestestr_95/}{advantages too}. For instance, it shares (in the case of a normal posterior distribution) an intuitive relationship with the standard deviation and it conveys a more accurate image of the (artificial) bounds of the distribution. Also, because it is wider, it makes analyses more conservative (i.e., the probability of covering 0 is larger for the \verb{95\%} CI than for lower ranges such as \verb{89\%}), which is a good thing in the context of the reproducibility crisis. A \verb{95\%} equal-tailed interval (ETI) has \verb{2.5\%} of the distribution on either side of its limits. It indicates the 2.5th percentile and the 97.5h percentile. In symmetric distributions, the two methods of computing credible intervals, the ETI and the \link[=hdi]{HDI}, return similar results. This is not the case for skewed distributions. Indeed, it is possible that parameter values in the ETI have lower credibility (are less probable) than parameter values outside the ETI. This property seems undesirable as a summary of the credible values in a distribution. On the other hand, the ETI range does change when transformations are applied to the distribution (for instance, for a log odds scale to probabilities): the lower and higher bounds of the transformed distribution will correspond to the transformed lower and higher bounds of the original distribution. On the contrary, applying transformations to the distribution will change the resulting HDI. } \examples{ \dontshow{if (require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(bayestestR) posterior <- rnorm(1000) eti(posterior) eti(posterior, ci = c(0.80, 0.89, 0.95)) df <- data.frame(replicate(4, rnorm(100))) eti(df) eti(df, ci = c(0.80, 0.89, 0.95)) \donttest{ model <- suppressWarnings( rstanarm::stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) ) eti(model) eti(model, ci = c(0.80, 0.89, 0.95)) eti(emmeans::emtrends(model, ~1, "wt", data = mtcars)) model <- brms::brm(mpg ~ wt + cyl, data = mtcars) eti(model) eti(model, ci = c(0.80, 0.89, 0.95)) bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) eti(bf) eti(bf, ci = c(0.80, 0.89, 0.95)) } \dontshow{\}) # examplesIf} } \seealso{ Other ci: \code{\link{bci}()}, \code{\link{ci}()}, \code{\link{cwi}()}, \code{\link{hdi}()}, \code{\link{si}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/area_under_curve.Rd0000644000176200001440000000305114407021360016746 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/area_under_curve.R \name{area_under_curve} \alias{area_under_curve} \alias{auc} \title{Area under the Curve (AUC)} \usage{ area_under_curve(x, y, method = c("trapezoid", "step", "spline"), ...) auc(x, y, method = c("trapezoid", "step", "spline"), ...) } \arguments{ \item{x}{Vector of x values.} \item{y}{Vector of y values.} \item{method}{Method to compute the Area Under the Curve (AUC). Can be \code{"trapezoid"} (default), \code{"step"} or \code{"spline"}. If "trapezoid", the curve is formed by connecting all points by a direct line (composite trapezoid rule). If "step" is chosen then a stepwise connection of two points is used. For calculating the area under a spline interpolation the splinefun function is used in combination with integrate.} \item{...}{Arguments passed to or from other methods.} } \description{ Based on the DescTools \code{AUC} function. It can calculate the area under the curve with a naive algorithm or a more elaborated spline approach. The curve must be given by vectors of xy-coordinates. This function can handle unsorted x values (by sorting x) and ties for the x values (by ignoring duplicates). } \examples{ library(bayestestR) posterior <- distribution_normal(1000) dens <- estimate_density(posterior) dens <- dens[dens$x > 0, ] x <- dens$x y <- dens$y area_under_curve(x, y, method = "trapezoid") area_under_curve(x, y, method = "step") area_under_curve(x, y, method = "spline") } \seealso{ DescTools } bayestestR/man/reshape_iterations.Rd0000644000176200001440000000262214307033260017331 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reshape_iterations.R \name{reshape_iterations} \alias{reshape_iterations} \alias{reshape_draws} \title{Reshape estimations with multiple iterations (draws) to long format} \usage{ reshape_iterations(x, prefix = c("draw", "iter", "iteration", "sim")) reshape_draws(x, prefix = c("draw", "iter", "iteration", "sim")) } \arguments{ \item{x}{A data.frame containing posterior draws obtained from \code{estimate_response} or \code{estimate_link}.} \item{prefix}{The prefix of the draws (for instance, \code{"iter_"} for columns named as \verb{iter_1, iter_2, iter_3}). If more than one are provided, will search for the first one that matches.} } \value{ Data frame of reshaped draws in long format. } \description{ Reshape a wide data.frame of iterations (such as posterior draws or bootsrapped samples) as columns to long format. Instead of having all iterations as columns (e.g., \verb{iter_1, iter_2, ...}), will return 3 columns with the \verb{\\*_index} (the previous index of the row), the \verb{\\*_group} (the iteration number) and the \verb{\\*_value} (the value of said iteration). } \examples{ \donttest{ if (require("rstanarm")) { model <- stan_glm(mpg ~ am, data = mtcars, refresh = 0) draws <- insight::get_predicted(model) long_format <- reshape_iterations(draws) head(long_format) } } } bayestestR/man/bci.Rd0000644000176200001440000001600214560763455014214 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bci.R \name{bci} \alias{bci} \alias{bcai} \alias{bci.numeric} \alias{bci.data.frame} \alias{bci.MCMCglmm} \alias{bci.sim.merMod} \alias{bci.sim} \alias{bci.emmGrid} \alias{bci.stanreg} \alias{bci.brmsfit} \alias{bci.BFBayesFactor} \alias{bci.get_predicted} \title{Bias Corrected and Accelerated Interval (BCa)} \usage{ bci(x, ...) bcai(x, ...) \method{bci}{numeric}(x, ci = 0.95, verbose = TRUE, ...) \method{bci}{data.frame}(x, ci = 0.95, verbose = TRUE, ...) \method{bci}{MCMCglmm}(x, ci = 0.95, verbose = TRUE, ...) \method{bci}{sim.merMod}( x, ci = 0.95, effects = c("fixed", "random", "all"), parameters = NULL, verbose = TRUE, ... ) \method{bci}{sim}(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) \method{bci}{emmGrid}(x, ci = 0.95, verbose = TRUE, ...) \method{bci}{stanreg}( x, ci = 0.95, effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = TRUE, ... ) \method{bci}{brmsfit}( x, ci = 0.95, effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, ... ) \method{bci}{BFBayesFactor}(x, ci = 0.95, verbose = TRUE, ...) \method{bci}{get_predicted}(x, ci = 0.95, use_iterations = FALSE, verbose = TRUE, ...) } \arguments{ \item{x}{Vector representing a posterior distribution, or a data frame of such vectors. Can also be a Bayesian model. \strong{bayestestR} supports a wide range of models (see, for example, \code{methods("hdi")}) and not all of those are documented in the 'Usage' section, because methods for other classes mostly resemble the arguments of the \code{.numeric} or \code{.data.frame}methods.} \item{...}{Currently not used.} \item{ci}{Value or vector of probability of the (credible) interval - CI (between 0 and 1) to be estimated. Default to \code{.95} (\verb{95\%}).} \item{verbose}{Toggle off warnings.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} \item{use_iterations}{Logical, if \code{TRUE} and \code{x} is a \code{get_predicted} object, (returned by \code{\link[insight:get_predicted]{insight::get_predicted()}}), the function is applied to the iterations instead of the predictions. This only applies to models that return iterations for predicted values (e.g., \code{brmsfit} models).} } \value{ A data frame with following columns: \itemize{ \item \code{Parameter} The model parameter(s), if \code{x} is a model-object. If \code{x} is a vector, this column is missing. \item \code{CI} The probability of the credible interval. \item \code{CI_low}, \code{CI_high} The lower and upper credible interval limits for the parameters. } } \description{ Compute the \strong{Bias Corrected and Accelerated Interval (BCa)} of posterior distributions. } \details{ Unlike equal-tailed intervals (see \code{eti()}) that typically exclude \verb{2.5\%} from each tail of the distribution and always include the median, the HDI is \emph{not} equal-tailed and therefore always includes the mode(s) of posterior distributions. While this can be useful to better represent the credibility mass of a distribution, the HDI also has some limitations. See \code{\link[=spi]{spi()}} for details. The \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{\verb{95\%} or \verb{89\%} Credible Intervals (CI)} are two reasonable ranges to characterize the uncertainty related to the estimation (see \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{here} for a discussion about the differences between these two values). The \verb{89\%} intervals (\code{ci = 0.89}) are deemed to be more stable than, for instance, \verb{95\%} intervals (\emph{Kruschke, 2014}). An effective sample size of at least 10.000 is recommended if one wants to estimate \verb{95\%} intervals with high precision (\emph{Kruschke, 2014, p. 183ff}). Unfortunately, the default number of posterior samples for most Bayes packages (e.g., \code{rstanarm} or \code{brms}) is only 4.000 (thus, you might want to increase it when fitting your model). Moreover, 89 indicates the arbitrariness of interval limits - its only remarkable property is being the highest prime number that does not exceed the already unstable \verb{95\%} threshold (\emph{McElreath, 2015}). However, \verb{95\%} has some \href{https://easystats.github.io/blog/posts/bayestestr_95/}{advantages too}. For instance, it shares (in the case of a normal posterior distribution) an intuitive relationship with the standard deviation and it conveys a more accurate image of the (artificial) bounds of the distribution. Also, because it is wider, it makes analyses more conservative (i.e., the probability of covering 0 is larger for the \verb{95\%} CI than for lower ranges such as \verb{89\%}), which is a good thing in the context of the reproducibility crisis. A \verb{95\%} equal-tailed interval (ETI) has \verb{2.5\%} of the distribution on either side of its limits. It indicates the 2.5th percentile and the 97.5h percentile. In symmetric distributions, the two methods of computing credible intervals, the ETI and the \link[=hdi]{HDI}, return similar results. This is not the case for skewed distributions. Indeed, it is possible that parameter values in the ETI have lower credibility (are less probable) than parameter values outside the ETI. This property seems undesirable as a summary of the credible values in a distribution. On the other hand, the ETI range does change when transformations are applied to the distribution (for instance, for a log odds scale to probabilities): the lower and higher bounds of the transformed distribution will correspond to the transformed lower and higher bounds of the original distribution. On the contrary, applying transformations to the distribution will change the resulting HDI. } \examples{ posterior <- rnorm(1000) bci(posterior) bci(posterior, ci = c(0.80, 0.89, 0.95)) } \references{ DiCiccio, T. J. and B. Efron. (1996). Bootstrap Confidence Intervals. Statistical Science. 11(3): 189–212. 10.1214/ss/1032280214 } \seealso{ Other ci: \code{\link{ci}()}, \code{\link{cwi}()}, \code{\link{eti}()}, \code{\link{hdi}()}, \code{\link{si}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/sensitivity_to_prior.Rd0000644000176200001440000000330614560763455017771 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sensitivity_to_prior.R \name{sensitivity_to_prior} \alias{sensitivity_to_prior} \alias{sensitivity_to_prior.stanreg} \title{Sensitivity to Prior} \usage{ sensitivity_to_prior(model, ...) \method{sensitivity_to_prior}{stanreg}(model, index = "Median", magnitude = 10, ...) } \arguments{ \item{model}{A Bayesian model (\code{stanreg} or \code{brmsfit}).} \item{...}{Arguments passed to or from other methods.} \item{index}{The indices from which to compute the sensitivity. Can be one or multiple names of the columns returned by \code{describe_posterior}. The case is important here (e.g., write 'Median' instead of 'median').} \item{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.} } \description{ 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). } \examples{ \dontshow{if (require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \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")) } \dontshow{\}) # examplesIf} } \seealso{ DescTools } bayestestR/man/ci.Rd0000644000176200001440000001242714461433341014045 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ci.R \name{ci} \alias{ci} \alias{ci.numeric} \alias{ci.data.frame} \alias{ci.sim.merMod} \alias{ci.sim} \alias{ci.stanreg} \alias{ci.brmsfit} \alias{ci.BFBayesFactor} \alias{ci.MCMCglmm} \title{Confidence/Credible/Compatibility Interval (CI)} \usage{ ci(x, ...) \method{ci}{numeric}(x, ci = 0.95, method = "ETI", verbose = TRUE, BF = 1, ...) \method{ci}{data.frame}(x, ci = 0.95, method = "ETI", verbose = TRUE, BF = 1, ...) \method{ci}{sim.merMod}( x, ci = 0.95, method = "ETI", effects = c("fixed", "random", "all"), parameters = NULL, verbose = TRUE, ... ) \method{ci}{sim}(x, ci = 0.95, method = "ETI", parameters = NULL, verbose = TRUE, ...) \method{ci}{stanreg}( x, ci = 0.95, method = "ETI", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, verbose = TRUE, BF = 1, ... ) \method{ci}{brmsfit}( x, ci = 0.95, method = "ETI", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, verbose = TRUE, BF = 1, ... ) \method{ci}{BFBayesFactor}(x, ci = 0.95, method = "ETI", verbose = TRUE, BF = 1, ...) \method{ci}{MCMCglmm}(x, ci = 0.95, method = "ETI", verbose = TRUE, ...) } \arguments{ \item{x}{A \code{stanreg} or \code{brmsfit} model, or a vector representing a posterior distribution.} \item{...}{Currently not used.} \item{ci}{Value or vector of probability of the CI (between 0 and 1) to be estimated. Default to \code{0.95} (\verb{95\%}).} \item{method}{Can be \link[=eti]{"ETI"} (default), \link[=hdi]{"HDI"}, \link[=bci]{"BCI"}, \link[=spi]{"SPI"} or \link[=si]{"SI"}.} \item{verbose}{Toggle off warnings.} \item{BF}{The amount of support required to be included in the support interval.} \item{effects}{Should results for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned. Meta-parameters (like \code{lp__} or \code{prior_}) are filtered by default, so only parameters that typically appear in the \code{summary()} are returned. Use \code{parameters} to select specific parameters for the output.} \item{component}{Should results for all parameters, parameters for the conditional model or the zero-inflated part of the model be returned? May be abbreviated. Only applies to \pkg{brms}-models.} } \value{ A data frame with following columns: \itemize{ \item \code{Parameter} The model parameter(s), if \code{x} is a model-object. If \code{x} is a vector, this column is missing. \item \code{CI} The probability of the credible interval. \item \code{CI_low}, \code{CI_high} The lower and upper credible interval limits for the parameters. } } \description{ Compute Confidence/Credible/Compatibility Intervals (CI) or Support Intervals (SI) for Bayesian and frequentist models. The Documentation is accessible for: } \details{ \itemize{ \item \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{Bayesian models} \item \href{https://easystats.github.io/parameters/reference/ci.default.html}{Frequentist models} } } \note{ When it comes to interpretation, we recommend thinking of the CI in terms of an "uncertainty" or "compatibility" interval, the latter being defined as "Given any value in the interval and the background assumptions, the data should not seem very surprising" (\emph{Gelman & Greenland 2019}). There is also a \href{https://easystats.github.io/see/articles/bayestestR.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \examples{ \dontshow{if (require("rstanarm", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(bayestestR) posterior <- rnorm(1000) ci(posterior, method = "ETI") ci(posterior, method = "HDI") df <- data.frame(replicate(4, rnorm(100))) ci(df, method = "ETI", ci = c(0.80, 0.89, 0.95)) ci(df, method = "HDI", ci = c(0.80, 0.89, 0.95)) model <- suppressWarnings( stan_glm(mpg ~ wt, data = mtcars, chains = 2, iter = 200, refresh = 0) ) ci(model, method = "ETI", ci = c(0.80, 0.89)) ci(model, method = "HDI", ci = c(0.80, 0.89)) \dontshow{\}) # examplesIf} \dontshow{if (require("BayesFactor", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} bf <- ttestBF(x = rnorm(100, 1, 1)) ci(bf, method = "ETI") ci(bf, method = "HDI") \dontshow{\}) # examplesIf} \dontshow{if (require("emmeans", quietly = TRUE) && require("rstanarm", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} model <- emtrends(model, ~1, "wt", data = mtcars) ci(model, method = "ETI") ci(model, method = "HDI") \dontshow{\}) # examplesIf} } \references{ Gelman A, Greenland S. Are confidence intervals better termed "uncertainty intervals"? BMJ 2019;l5381. 10.1136/bmj.l5381 } \seealso{ Other ci: \code{\link{bci}()}, \code{\link{cwi}()}, \code{\link{eti}()}, \code{\link{hdi}()}, \code{\link{si}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/diagnostic_draws.Rd0000644000176200001440000000150314560763455017003 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/diagnostic_draws.R \name{diagnostic_draws} \alias{diagnostic_draws} \title{Diagnostic values for each iteration} \usage{ diagnostic_draws(posterior, ...) } \arguments{ \item{posterior}{A \code{stanreg}, \code{stanfit}, \code{brmsfit}, or \code{blavaan} object.} \item{...}{Currently not used.} } \description{ Returns the accumulated log-posterior, the average Metropolis acceptance rate, divergent transitions, treedepth rather than terminated its evolution normally. } \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) } } } bayestestR/DESCRIPTION0000644000176200001440000001121614650205472014113 0ustar liggesusersType: Package Package: bayestestR Title: Understand and Describe Bayesian Models and Posterior Distributions Version: 0.14.0 Authors@R: c(person(given = "Dominique", family = "Makowski", role = c("aut", "cre"), email = "dom.makowski@gmail.com", comment = c(ORCID = "0000-0001-5375-9967", Twitter = "@Dom_Makowski")), person(given = "Daniel", family = "Lüdecke", role = "aut", email = "d.luedecke@uke.de", comment = c(ORCID = "0000-0002-8895-3206", Twitter = "@strengejacke")), person(given = "Mattan S.", family = "Ben-Shachar", role = "aut", email = "matanshm@post.bgu.ac.il", comment = c(ORCID = "0000-0002-4287-4801", Twitter = "@mattansb")), person(given = "Indrajeet", family = "Patil", role = "aut", email = "patilindrajeet.science@gmail.com", comment = c(ORCID = "0000-0003-1995-6531", Twitter = "@patilindrajeets")), person(given = "Michael D.", family = "Wilson", role = "aut", email = "michael.d.wilson@curtin.edu.au", comment = c(ORCID = "0000-0003-4143-7308")), person(given = "Brenton M.", family = "Wiernik", role = "aut", email = "brenton@wiernik.org", comment = c(ORCID = "0000-0001-9560-6336", Twitter = "@bmwiernik")), person(given = "Paul-Christian", family = "Bürkner", role = "rev", email = "paul.buerkner@gmail.com"), person(given = "Tristan", family = "Mahr", role = "rev", email = "tristan.mahr@wisc.edu", comment = c(ORCID = "0000-0002-8890-5116")), person(given = "Henrik", family = "Singmann", role = "ctb", email = "singmann@gmail.com", comment = c(ORCID = "0000-0002-4842-3657")), person(given = "Quentin F.", family = "Gronau", role = "ctb", comment = c(ORCID = "0000-0001-5510-6943")), person(given = "Sam", family = "Crawley", role = "ctb", email = "sam@crawley.nz", comment = c(ORCID = "0000-0002-7847-0411"))) Maintainer: Dominique Makowski Description: Provides utilities to describe posterior distributions and Bayesian models. It includes point-estimates such as Maximum A Posteriori (MAP), measures of dispersion (Highest Density Interval - HDI; Kruschke, 2015 ) and indices used for null-hypothesis testing (such as ROPE percentage, pd and Bayes factors). References: Makowski et al. (2021) . Depends: R (>= 3.6) Imports: insight (>= 0.20.1), datawizard (>= 0.10.0), graphics, methods, stats, utils Suggests: BayesFactor (>= 0.9.12-4.4), bayesQR, bayesplot, betareg, BH, blavaan, bridgesampling, brms, curl, effectsize, emmeans, gamm4, ggdist, ggplot2, glmmTMB, httr, httr2, KernSmooth, knitr, lavaan, lme4, logspline (>= 2.1.21), MASS, mclust, mediation, modelbased, ordbetareg, parameters, patchwork, performance, quadprog, posterior, RcppEigen, rmarkdown, rstan, rstanarm, see (>= 0.8.5), testthat, tweedie License: GPL-3 URL: https://easystats.github.io/bayestestR/ BugReports: https://github.com/easystats/bayestestR/issues VignetteBuilder: knitr Encoding: UTF-8 Language: en-US RoxygenNote: 7.3.2 Config/testthat/edition: 3 Config/testthat/parallel: true Config/rcmdcheck/ignore-inconsequential-notes: true Config/Needs/website: easystats/easystatstemplate Config/Needs/check: stan-dev/cmdstanr NeedsCompilation: no Packaged: 2024-07-24 13:24:58 UTC; domma Author: Dominique Makowski [aut, cre] (, @Dom_Makowski), Daniel Lüdecke [aut] (, @strengejacke), Mattan S. Ben-Shachar [aut] (, @mattansb), Indrajeet Patil [aut] (, @patilindrajeets), Michael D. Wilson [aut] (), Brenton M. Wiernik [aut] (, @bmwiernik), Paul-Christian Bürkner [rev], Tristan Mahr [rev] (), Henrik Singmann [ctb] (), Quentin F. Gronau [ctb] (), Sam Crawley [ctb] () Repository: CRAN Date/Publication: 2024-07-24 14:10:02 UTC