bayestestR/0000755000176200001440000000000015204610032012370 5ustar liggesusersbayestestR/tests/0000755000176200001440000000000014411241742013541 5ustar liggesusersbayestestR/tests/testthat/0000755000176200001440000000000015204610032015372 5ustar liggesusersbayestestR/tests/testthat/test-p_direction.R0000644000176200001440000000524615005370052021004 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) # converstion into frequentist p-value works p <- p_direction(x, as_p = TRUE) expect_equal(as.numeric(p), pd_to_p(pd$pd), tolerance = 0.1) expect_equal(as.vector(p), pd_to_p(pd$pd), tolerance = 0.1) # return NA expect_true(is.na(as.numeric(p_direction(c(x, NA), remove_na = FALSE)))) # works expect_equal(as.numeric(p_direction(c(x, NA))), 0.8413, tolerance = 0.1) expect_equal(as.vector(p_direction(c(x, NA))), 0.8413, tolerance = 0.1) # error if only NA expect_error(p_direction(c(NA_real_, NA_real_)), regex = "No valid values found") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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 ) # converstion into frequentist p-value works expect_equal( p_direction(m, effects = "all", as_p = TRUE)$p, pd_to_p(p_direction(m, effects = "all")$pd), tolerance = 1e-3 ) expect_equal( p_direction(m, effects = "all", as_p = TRUE)$p, as.numeric(p_direction(m, effects = "all", as_p = TRUE)), tolerance = 1e-3 ) expect_equal( p_direction(m, effects = "all", as_p = TRUE)$p, as.vector(p_direction(m, effects = "all", as_p = TRUE)), tolerance = 1e-3 ) }) test_that("p_direction", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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.R0000644000176200001440000000066114411241742020114 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.R0000644000176200001440000000544615005370052021157 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("BayesFactor") m <- insight::download_model("stanreg_merMod_5") skip_if(is.null(m)) expect_identical( map_estimate(m, effects = "all")$Parameter, colnames(as.data.frame(m))[c(1:5, 21)] ) expect_identical( map_estimate(m, effects = "full")$Parameter, colnames(as.data.frame(m))[1:21] ) }) # brms ---------------------- test_that("map_estimate", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("BayesFactor") m <- insight::download_model("brms_zi_3") skip_if(is.null(m)) expect_identical( map_estimate(m, effects = "all", component = "all")$Parameter, c( "b_Intercept", "b_child", "b_camper", "sd_persons__Intercept", "b_zi_Intercept", "b_zi_child", "b_zi_camper", "sd_persons__zi_Intercept" ) ) expect_identical( map_estimate(m, effects = "full", 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)) }) # edge cases test_that("map_estimate, constant vectors or sparse samples", { x <- c(2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.2, 2.2, 2.2, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5) out <- map_estimate(x, verbose = FALSE) expect_true(is.na(out$MAP_Estimate)) out <- map_estimate(c(3, 3, 3), verbose = FALSE) expect_identical(out$MAP_Estimate, 3) expect_message( map_estimate(x, verbose = TRUE), regex = "Could not calculate MAP estimate" ) expect_message( map_estimate(c(3, 3, 3), verbose = TRUE), regex = "Data is singular" ) }) bayestestR/tests/testthat/test-print.R0000644000176200001440000000071515005370052017635 0ustar liggesuserstest_that("print.describe_posterior", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("brms") m <- insight::download_model("brms_zi_3") skip_if(is.null(m)) 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.R0000644000176200001440000000343414510775166020011 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.R0000644000176200001440000000517515005370052017252 0ustar liggesusers# numeric ------------------------------- test_that("hdi", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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-equivalence_test.R0000644000176200001440000000333115005370052022036 0ustar liggesusersskip_on_cran() test_that("equivalence test, rstanarm", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") m <- insight::download_model("stanreg_merMod_5") out <- equivalence_test(m, verbose = FALSE) expect_snapshot(print(out)) out <- equivalence_test( m, range = list(c(-1, 1), "default", c(0, 2), c(-2, 0), "default"), verbose = FALSE ) expect_snapshot(print(out)) expect_error( equivalence_test( m, range = list(c(-1, 1), "default", c(0, 2), c(-2, 0)), verbose = FALSE ), regex = "Length of" ) expect_error( equivalence_test( m, range = list(c(-1, 1), "default", c(0, 2), c(-2, 0), "a"), verbose = FALSE ), regex = "should be 'default'" ) }) test_that("equivalence test, df", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") m <- insight::download_model("stanreg_merMod_5") params <- as.data.frame(m)[1:5] out <- equivalence_test(params, verbose = FALSE) expect_snapshot(print(out)) out <- equivalence_test( params, range = list(c(-1, 1), "default", c(0, 2), c(-2, 0), "default"), verbose = FALSE ) expect_snapshot(print(out)) expect_error( equivalence_test( params, range = list(c(-1, 1), "default", c(0, 2), c(-2, 0)), verbose = FALSE ), regex = "Length of" ) expect_error( equivalence_test( params, range = list(c(-1, 1), "default", c(0, 2), c(-2, 0), "a"), verbose = FALSE ), regex = "should be 'default'" ) }) bayestestR/tests/testthat/test-describe_prior.R0000644000176200001440000001046615005370052021500 0ustar liggesuserstest_that("describe_prior", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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.R0000644000176200001440000000345715005370052017603 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_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.R0000644000176200001440000000537015005370052023412 0ustar liggesusersskip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_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 <- suppressWarnings(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 <- suppressWarnings(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-marginaleffects.R0000644000176200001440000001036515055047701021644 0ustar liggesusersskip_on_cran() skip_if_not_installed("withr") skip_if_not_installed("rstanarm") skip_if_not_installed("marginaleffects", minimum_version = "0.29.0") skip_if_not_installed("collapse") withr::with_environment( new.env(), test_that("marginaleffects descrive_posterior", { data("mtcars") mtcars$cyl <- factor(mtcars$cyl) mod <- rstanarm::stan_glm(mpg ~ cyl + hp * am, data = mtcars, refresh = 0) mfx <- marginaleffects::avg_slopes(mod, by = "am") mfx_samps <- data.frame(suppressWarnings(marginaleffects::get_draws( mfx, shape = "DxP" ))) results <- describe_posterior( mfx, centrality = "MAP", ci_method = "hdi", test = c("pd", "rope", "p_map", "equivalence_test") ) results_draws <- describe_posterior( mfx_samps, centrality = "MAP", ci_method = "hdi", test = c("pd", "rope", "p_map", "equivalence_test"), verbose = FALSE ) expect_true(all(c("term", "contrast") %in% colnames(results))) expect_equal( results[setdiff(colnames(results), c("term", "contrast", "am"))], results_draws[setdiff(colnames(results_draws), "Parameter")], ignore_attr = TRUE ) # multi ci levels res <- hdi(mfx, ci = c(0.8, 0.9)) expect_identical( as.data.frame(res[1:3]), data.frame( term = c( "am", "am", "am", "am", "cyl", "cyl", "cyl", "cyl", "cyl", "cyl", "cyl", "cyl", "hp", "hp", "hp", "hp" ), contrast = c( "1 - 0", "1 - 0", "1 - 0", "1 - 0", "6 - 4", "6 - 4", "8 - 4", "8 - 4", "6 - 4", "6 - 4", "8 - 4", "8 - 4", "dY/dX", "dY/dX", "dY/dX", "dY/dX" ), am = c(0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1), stringsAsFactors = FALSE ) ) # estimate_density mfx <- marginaleffects::comparisons( mod, variables = "cyl", newdata = marginaleffects::datagrid(hp = 100, am = 0) ) samps <- insight::get_parameters(mod)[c("cyl6", "cyl8")] res <- estimate_density(mfx) resref <- estimate_density(samps) expect_equal( res[intersect(colnames(res), colnames(resref))], resref[intersect(colnames(res), colnames(resref))], ignore_attr = TRUE ) }) ) withr::with_environment( new.env(), test_that("marginaleffects bayesfactors", { data("mtcars") mtcars$cyl <- factor(mtcars$cyl) mod <- rstanarm::stan_glm(mpg ~ cyl + hp * am, data = mtcars, refresh = 0) modp <- unupdate(mod, verbose = FALSE) mfx <- marginaleffects::avg_slopes(mod, by = "am") mfxp <- marginaleffects::avg_slopes(modp, by = "am") mfx_samps <- as.data.frame(suppressWarnings(marginaleffects::get_draws( mfx, shape = "DxP" ))) mfxp_samps <- as.data.frame(suppressWarnings(marginaleffects::get_draws( mfxp, shape = "DxP" ))) # SI outsi <- si(mfx, prior = mfxp, verbose = FALSE) outsiref <- si(mfx_samps, prior = mfxp_samps, verbose = FALSE) expect_true(all(c("term", "contrast", "am") %in% colnames(outsi))) expect_equal( outsi[setdiff(colnames(outsi), c("term", "contrast", "am"))], outsiref[setdiff(colnames(outsiref), "Parameter")], ignore_attr = TRUE ) # bayesfactor_parameters bfp <- bayesfactor_parameters(mfx, prior = mfxp, verbose = FALSE) bfpref <- bayesfactor_parameters( mfx_samps, prior = mfxp_samps, verbose = FALSE ) expect_equal( bfp[setdiff(colnames(bfp), c("term", "contrast", "am"))], bfpref[setdiff(colnames(bfpref), "Parameter")], ignore_attr = TRUE ) }) ) test_that("marginaleffects bayesfactors", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_installed("brms") skip_if_not_installed("modelbased") m <- insight::download_model("brms_mv_1") skip_if(is.null(m)) p <- modelbased::get_marginalmeans(m, "wt") out <- describe_posterior(p) expect_named( out, c( "wt", "group", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage" ) ) expect_identical(dim(out), c(30L, 11L)) }) bayestestR/tests/testthat/test-bayesfactor_parameters.R0000644000176200001440000001024415005370052023224 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(-0.1, 0.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(-0.1, 0.1), direction = 1) expect_equal(bfsd$log_BF, c(0.47, -0.39), tolerance = 0.1) bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = c(-0.1, 0.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(-0.1, Inf)) expect_equal(bfsd$log_BF, c(-0.81, 0.80), tolerance = 0.1) bfsd <- bayesfactor_parameters(Xposterior, prior = Xprior, null = c(-Inf, 0.1)) expect_equal(bfsd$log_BF, c(0.80, -0.81), tolerance = 0.1) }) test_that("bayesfactor_parameters RSTANARM", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("logspline", "2.1.21") skip_if_not_or_load_if_installed("rstanarm") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("logspline", "2.1.21") skip_if_not_or_load_if_installed("brms") skip_if_not_or_load_if_installed("cmdstanr") skip_if_not(dir.exists(cmdstanr::cmdstan_default_install_path())) 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.R0000644000176200001440000000346514357736006017651 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.R0000644000176200001440000000501715005370052017274 0ustar liggesusers# numeric ------------------------------- test_that("spi", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") skip_if_not_or_load_if_installed("BayesFactor") expect_equal(spi(distribution_normal(1000), ci = 0.90)$CI_low[1], -1.65, tolerance = 0.02) expect_equal(nrow(spi(distribution_normal(1000), ci = c(0.80, 0.90, 0.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(0.80, 0.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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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( 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.R0000644000176200001440000000545714704176606022620 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), ignore_attr = TRUE) 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), ignore_attr = TRUE) }) 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, tolerance = 1e-4) expect_equal(res_BT1$CI, res_brms1$CI, tolerance = 1e-4) expect_equal(res_BT1$CI_low, res_brms1$CI_low, tolerance = 1e-4) expect_equal(res_BT1$CI_high, res_brms1$CI_high, tolerance = 1e-4) }) bayestestR/tests/testthat/test-emmGrid.R0000644000176200001440000001743614747200255020106 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_identical(colnames(xhdi)[1:2], c("group", "contrast")) 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_identical(xhdi$CI_low, xhdi2$CI_low) xhdi3 <- hdi(all_, ci = c(0.9, 0.95)) expect_identical( as.data.frame(xhdi3[1:2]), data.frame( group = c("1", "1", "2", "2", ".", "."), contrast = c(".", ".", ".", ".", "group1 - group2", "group1 - group2"), stringsAsFactors = FALSE ) ) }) test_that("emmGrid point_estimate", { xpest <- point_estimate(all_, centrality = "all", dispersion = TRUE) expect_identical(colnames(xpest)[1:2], c("group", "contrast")) expect_equal(xpest$Median, all_summ$emmean, tolerance = 0.1) xpest2 <- point_estimate(emc_, centrality = "all", dispersion = TRUE) expect_identical(xpest$Median, xpest2$Median) }) # Basics ------------------------------------------------------------------ test_that("emmGrid ci", { xci <- ci(all_, ci = 0.9) expect_identical(colnames(xci)[1:2], c("group", "contrast")) expect_length(xci$CI_low, 3) expect_length(xci$CI_high, 3) }) test_that("emmGrid eti", { xeti <- eti(all_, ci = 0.9) expect_identical(colnames(xeti)[1:2], c("group", "contrast")) expect_length(xeti$CI_low, 3) expect_length(xeti$CI_high, 3) }) test_that("emmGrid equivalence_test", { xeqtest <- equivalence_test(all_, ci = 0.9, range = c(-0.1, 0.1)) expect_identical(colnames(xeqtest)[1:2], c("group", "contrast")) expect_length(xeqtest$ROPE_Percentage, 3) expect_length(xeqtest$ROPE_Equivalence, 3) }) test_that("emmGrid estimate_density", { xestden <- estimate_density(c_, method = "logspline", precision = 5) expect_identical(colnames(xestden)[1], "contrast") expect_length(xestden$x, 5) }) test_that("emmGrid map_estimate", { xmapest <- map_estimate(all_, method = "kernel") expect_identical(colnames(xmapest)[1:2], c("group", "contrast")) expect_length(xmapest$MAP_Estimate, 3) }) test_that("emmGrid p_direction", { xpd <- p_direction(all_, method = "direct") expect_identical(colnames(xpd)[1:2], c("group", "contrast")) expect_length(xpd$pd, 3) }) test_that("emmGrid p_map", { xpmap <- p_map(all_, precision = 2^9) expect_identical(colnames(xpmap)[1:2], c("group", "contrast")) expect_length(xpmap$p_MAP, 3) }) test_that("emmGrid p_rope", { xprope <- p_rope(all_, range = c(-0.1, 0.1)) expect_identical(colnames(xprope)[1:2], c("group", "contrast")) expect_length(xprope$p_ROPE, 3) }) test_that("emmGrid p_significance", { xsig <- p_significance(all_, threshold = c(-0.1, 0.1)) expect_identical(colnames(xsig)[1:2], c("group", "contrast")) expect_length(xsig$ps, 3) }) test_that("emmGrid rope", { xrope <- rope(all_, range = "default", ci = 0.9) expect_identical(colnames(xrope)[1:2], c("group", "contrast")) expect_length(xrope$ROPE_Percentage, 3) }) # describe_posterior ------------------------------------------------------ test_that("emmGrid describe_posterior", { expect_identical( describe_posterior(all_)$median, describe_posterior(emc_)$median ) expect_identical(colnames(describe_posterior(all_))[1:2], c("group", "contrast")) skip_on_cran() expect_identical( 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_identical(colnames(xbfp)[1:2], c("group", "contrast")) 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_length(xrbf$log_BF, 2) expect_length(xrbf$p_prior, 2) expect_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_identical(colnames(xrsi)[1:2], c("group", "contrast")) expect_length(xrsi$CI_low, 3) expect_length(xrsi$CI_high, 3) xrsi2 <- si(emc_, prior = model_p, verbose = FALSE) expect_identical(xrsi$CI_low, xrsi2$CI_low) expect_identical(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.R0000644000176200001440000000415315005370052017074 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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( 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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( 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.R0000644000176200001440000001155415005370052020532 0ustar liggesuserstest_that("mp-posterior-draws", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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.R0000644000176200001440000001673215203314503022353 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, tolerance = 1e-4, ignore_attr = TRUE) expect_equal(BFM1, BFM3, tolerance = 1e-4, ignore_attr = TRUE) expect_equal( BFM1, bayesfactor_models(list(mo2 = mo2, mo3 = mo3, mo4 = mo4, mo1 = mo1), denominator = 4), tolerance = 1e-4, ignore_attr = TRUE ) # 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")) }) test_that("bayesfactor_models | bayesfactor_matrix", { data("mtcars") 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) BFM1 <- bayesfactor_models(lm1, lm2, lm3, lm4, denominator = 1) BFM2 <- update(BFM1, reference = 2) bfmat <- as.matrix(BFM1) expect_identical(as.matrix(BFM2), bfmat) expect_identical(unname(diag(bfmat)), rep(0, 4)) expect_identical(-t(bfmat)[upper.tri(bfmat)], bfmat[upper.tri(bfmat)]) expect_output(print(bfmat), regexp = "Denominator\\\\Numerator") }) # 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_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)), tolerance = 1e-4, ignore_attr = TRUE ) }) 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.R0000644000176200001440000000653714510775166022041 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.R0000644000176200001440000000050414411241742017002 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.R0000644000176200001440000000454715055605666023263 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, 0.4, 0.2), X1 = distribution_normal(100, -0.2, 0.2), X3 = distribution_normal(100, 0.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")) }) test_that("bayesfactor_restricted | bayesfactor_matrix", { set.seed(444) 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) bfmat <- as.matrix(b) expect_identical(unname(bfmat[1, -1]), b$log_BF) expect_identical(unname(diag(bfmat)), rep(0, 4)) expect_identical(-t(bfmat)[upper.tri(bfmat)], bfmat[upper.tri(bfmat)]) expect_output(print(bfmat), regexp = "Denominator\\\\Numerator") expect_output(print(bfmat), regexp = "Restricted") }) # 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.R0000644000176200001440000000037414502413050020123 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.R0000644000176200001440000000312614357736006021420 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-diagnostic_posterior.R0000644000176200001440000000235115204535065022741 0ustar liggesuserstest_that("diagnostic_posterior default", { skip_on_os("mac") skip_if_not_or_load_if_installed("rstan") ## same as example("diagnostic_posterior") set.seed(101) mkdata <- function(nrow = 1000, ncol = 2, parnm = LETTERS[1:ncol]) { x <- as.data.frame(replicate(ncol, rnorm(nrow))) names(x) <- parnm x } dd <- replicate(5, mkdata(), simplify = FALSE) dp <- diagnostic_posterior(dd) expect_equal(dp$Parameter, c("A", "B")) expect_equal(dp$Rhat, c(1.001218705610197, 0.9997185343161158), tolerance = 1e-3) expect_true(is.numeric(dp$ESS)) expect_true(all(dp$ESS > 0)) expect_equal(dp$MCSE, c(0.02455353655881737, 0.019981604021430396), tolerance = 1e-3) adims <- list(npar = 2, nchains = 4, nsamp = 1000) dd2 <- with( adims, array( rnorm(npar * nchains * nsamp), dim = c(nsamp, nchains, npar), dimnames = list(NULL, NULL, LETTERS[1:npar]) ) ) skip_on_os("linux") dp2 <- diagnostic_posterior(dd2) expect_equal(dp2$Parameter, c("A", "B")) expect_equal(dp2$Rhat, c(1.00125536, 1.00087302), tolerance = 1e-3) expect_true(is.numeric(dp2$ESS)) expect_true(all(dp2$ESS > 0)) expect_equal(dp2$MCSE, c(0.03291257, 0.03590011), tolerance = 1e-3) }) bayestestR/tests/testthat/test-rope_range.R0000644000176200001440000000313214747200255020627 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.R0000644000176200001440000000246415005370052022005 0ustar liggesuserstest_that("effective_sample", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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") skip_if(is.null(brms_1)) res <- effective_sample(brms_1) expect_equal( res, data.frame( Parameter = c("b_Intercept", "b_wt", "b_cyl"), ESS = c(5283, 2120, 2001), ESS_tail = c(3255, 2003, 2227), stringsAsFactors = FALSE ), ignore_attr = TRUE, tolerance = 1e-1 ) brms_null_1 <- insight::download_model("brms_null_1") skip_if(is.null(brms_null_1)) res <- effective_sample(brms_null_1) expect_equal( res, data.frame( Parameter = "b_Intercept", ESS = 2912, ESS_tail = 2388, stringsAsFactors = FALSE ), ignore_attr = TRUE, tolerance = 1e-1 ) brms_null_2 <- insight::download_model("brms_null_2") skip_if(is.null(brms_null_2)) res <- effective_sample(brms_null_2) expect_equal( res, data.frame( Parameter = "b_Intercept", ESS = 1098, ESS_tail = 954, stringsAsFactors = FALSE ), ignore_attr = TRUE, tolerance = 1e-1 ) }) bayestestR/tests/testthat/test-p_rope.R0000644000176200001440000000117115005370052017762 0ustar liggesuserstest_that("p_rope", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") m <- insight::download_model("stanreg_merMod_5") expect_equal( p_rope(as.data.frame(m)[2:4], range = list(c(0, 40), "default", c(-1, 0.8)))$p_ROPE, c(0.598, 0.002, 0.396), tolerance = 1e-3 ) expect_error( p_rope(as.data.frame(m)[2:4], range = list(c(0, 40), c(-1, 0.8))), regex = "Length of" ) expect_error( p_rope(as.data.frame(m)[2:4], range = list(c(0, 40), "a", c(-1, 0.8))), regex = "should be 'default'" ) }) bayestestR/tests/testthat/test-density_at.R0000644000176200001440000000031414266336540020653 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.R0000644000176200001440000000270614623110564022062 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.R0000644000176200001440000000017614266336540022600 0ustar liggesuserstest_that("as.data.frame.density", { expect_s3_class(as.data.frame(density(distribution_normal(1000))), "data.frame") }) bayestestR/tests/testthat/test-brms.R0000644000176200001440000001220715174322463017455 0ustar liggesuserstest_that("brms mixed", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("brms") set.seed(333) model <- insight::download_model("brms_mixed_1") skip_if(is.null(model)) expect_s3_class(hdi(model), "data.frame") expect_s3_class(ci(model), "data.frame") expect_s3_class(rope(model, verbose = FALSE), "data.frame") expect_s3_class(equivalence_test(model), "equivalence_test") 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_named( hdi(model), c("Parameter", "CI", "CI_low", "CI_high", "Effects", "Component") ) expect_named( hdi(model, effects = "all"), c("Parameter", "CI", "CI_low", "CI_high", "Effects", "Component") ) expect_identical(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_tail" ) ) 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[3], tolerance = 1e-3) expect_equal( as.vector(s$random$gear[, 1, drop = TRUE]), out$Mean[4:6], tolerance = 1e-3 ) }) test_that("brms standard", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_installed("posterior") skip_if_not_or_load_if_installed("brms") set.seed(333) model <- insight::download_model("brms_1") skip_if(is.null(model)) out <- describe_posterior( model, effects = "all", component = "all", centrality = "mean" ) s <- summary(model) expect_named( out, c( "Parameter", "Component", "Mean", "CI", "CI_low", "CI_high", "pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage", "Rhat", "ESS_tail" ) ) 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) # check for all ESS values out <- describe_posterior(model, diagnostic = "all") ref <- posterior::summarise_draws(model) expect_equal(out$ESS_tail, round(ref$ess_tail[1:3]), tolerance = 1) expect_equal(out$ESS_bulk, round(ref$ess_bulk[1:3]), tolerance = 1) expect_named( out, c( "Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage", "Rhat", "ESS_tail", "ESS_bulk", "MCSE" ) ) out <- effective_sample(model) ref <- posterior::summarise_draws(model) expect_equal(out$ESS_tail, round(ref$ess_tail[1:3]), tolerance = 1) expect_equal(out$ESS_bulk, round(ref$ess_bulk[1:3]), tolerance = 1) expect_named( out, c( "Parameter", "ESS_bulk", "ESS_tail" ) ) }) test_that("brms multivariate", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("brms") set.seed(333) model <- insight::download_model("brms_mv_2") skip_if(is.null(model)) 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_tail" ) ) 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 standard, 2", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("brms") set.seed(333) model <- insight::download_model("brms_2") skip_if(is.null(model)) 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.R0000644000176200001440000000601015005370052021434 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" ) ) # non-symmetric intervals ps <- p_significance(x, threshold = c(0.05, 0.2)) expect_equal(as.numeric(ps), 0.7881, tolerance = 0.1) # should be identical, both ranges have same distance to the mean 1 ps <- p_significance(x, threshold = c(1.8, 1.95)) expect_equal(as.numeric(ps), 0.7881, tolerance = 0.1) set.seed(333) x <- data.frame(replicate(4, rnorm(100))) pd <- p_significance(x) expect_identical(dim(pd), c(4L, 2L)) # error: expect_error(p_significance(x, threshold = 1:3)) }) test_that("stanreg", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("brms") m2 <- insight::download_model("brms_1") expect_equal( p_significance(m2, effects = "all")$ps, c(1.0000, 0.9985, 0.9785), tolerance = 0.01 ) out <- p_significance(m2, threshold = list(1, "default", 2), effects = "all") expect_equal( out$ps, c(1.00000, 0.99850, 0.12275), tolerance = 0.01 ) expect_equal( attributes(out)$threshold, list(c(-1, 1), c(-0.60269480520891, 0.60269480520891), c(-2, 2)), tolerance = 1e-4 ) expect_error( p_significance(m2, threshold = list(1, "a", 2), effects = "all"), regex = "should be one of" ) expect_error( p_significance(m2, threshold = list(1, 2, 3, 4), effects = "all"), regex = "Length of" ) }) test_that("stan", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") m <- insight::download_model("stanreg_merMod_5") expect_equal( p_significance(m, threshold = list("(Intercept)" = 1, period4 = 1.5, period3 = 0.5))$ps, p_significance(m, threshold = list(1, "default", "default", 0.5, 1.5))$ps, tolerance = 1e-4 ) expect_error( p_significance(m, threshold = list("(Intercept)" = 1, point = 1.5, period3 = 0.5)), regex = "Not all elements" ) expect_error( p_significance(m, threshold = list(1, "a", 2), effects = "all"), regex = "should be one of" ) expect_error( p_significance(m, threshold = list(1, 2, 3, 4), effects = "all"), regex = "Length of" ) }) bayestestR/tests/testthat/test-check_prior.R0000644000176200001440000001111415005370052020764 0ustar liggesusersskip_on_os(os = "mac") test_that("check_prior - stanreg", { skip_on_cran() skip_on_os(os = c("windows", "mac")) skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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") data(inhaler, package = "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" ) )) ## FIXME: this test returns inconsistent results across platforms and OSs # 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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.R0000644000176200001440000001604515174322463017463 0ustar liggesuserstest_that("rope, vector", { 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 ) set.seed(1234) x <- rnorm(4000, sd = 5) out <- rope(x, complement = TRUE) expect_named( out, c( "CI", "ROPE_low", "ROPE_high", "ROPE_Percentage", "Superiority_Percentage", "Inferiority_Percentage" ) ) expect_identical( capture.output(print(out)), c( "# Proportion of samples inside the ROPE [-0.10, 0.10]:", "", "Inside ROPE | Above ROPE | Below ROPE", "-------------------------------------", "1.53 % | 49.68 % | 48.79 %", "" ) ) out <- p_rope(x, complement = TRUE) expect_named( out, c("ROPE_low", "ROPE_high", "p_ROPE", "p_Superiority", "p_Inferiority") ) expect_equal(out$p_Superiority, 0.497, tolerance = 1e-3) expect_equal(out$p_Inferiority, 0.4885, tolerance = 1e-3) out <- suppressWarnings(capture.output(describe_posterior( x, test = "p_rope", complement = TRUE ))) expect_identical( out[3], "Parameter | Median | 95% CI | ROPE | p (ROPE) | p (Superiority) | p (Inferiority)" ) }) test_that("rope, bayes", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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 ) # list range expect_equal( rope( m, range = list(c(-1, 0.1), "default", "default", c(-1, 1), c(-1.5, -1)) )$ROPE_Percentage, c(0.15823, 1, 0, 0.3903, 0.38186), tolerance = 1e-3 ) # named elements, chooses "default" for unnamed expect_equal( rope( m, range = list(c(-1, 0.1), "default", "default", c(-1, 1), c(-1.5, -1)) )$ROPE_Percentage, rope( m, range = list( "(Intercept)" = c(-1, 0.1), period4 = c(-1.5, -1), period3 = c(-1, 1) ) )$ROPE_Percentage, tolerance = 1e-3 ) expect_error( rope(m, range = list(c(-0.1, 0.1), c(2, 2))), regex = "Length of" ) expect_error( rope(m, range = list(c(-0.1, 0.1), c(2, 2), "default", "a", c(1, 3))), regex = "should be 'default'" ) expect_error( rope( m, range = list( "(Intercept)" = c(-1, 0.1), pointout = c(-1.5, -1), period3 = c(-1, 1) ) ), regex = "Not all elements" ) }) test_that("rope, get_parameters", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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 ) }) test_that("rope BayesFactor", { skip_on_cran() skip_on_os(c("linux", "mac")) 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) }) test_that("rope (brms)", { skip_on_cran() skip_if_not_or_load_if_installed("brms") skip_on_os(c("windows", "mac")) set.seed(123) model <- suppressWarnings(brms::brm(mpg ~ wt + gear, data = mtcars, iter = 500)) rope <- rope(model, verbose = FALSE) 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) out <- describe_posterior(model, complement = TRUE) expect_equal(out$Superiority_Percentage, c(1, 0, 0.137895), tolerance = 0.01) expect_named( out, c( "Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage", "Superiority_Percentage", "Inferiority_Percentage", "Rhat", "ESS_tail" ) ) }) test_that("rope (brms, multivariate)", { skip_on_cran() skip_if_not_or_load_if_installed("brms") skip_on_os(c("windows", "mac")) model <- suppressWarnings(brm( bf(mvbind(mpg, disp) ~ wt + gear) + set_rescor(TRUE), data = mtcars, iter = 500, refresh = 0 )) rope <- rope(model, verbose = FALSE) 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 ) }) bayestestR/tests/testthat/test-BFBayesFactor.R0000644000176200001440000000632114565424105021123 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.R0000644000176200001440000000304315005370052021522 0ustar liggesuserstest_that("point_estimate: stanreg", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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( point_estimate(m, effects = "all")$Median, point_estimate(p)$Median, tolerance = 1e-3 ) }) test_that("point_estimate: brms", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") 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( point_estimate(m, effects = "all", component = "all")$Median, point_estimate(p)$Median, tolerance = 1e-3 ) }) # edge cases test_that("point_estimate, constant vectors or sparse samples", { x <- c(2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.2, 2.2, 2.2, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5) out <- point_estimate(x, centrality = "MAP", verbose = FALSE) expect_true(is.na(out$MAP)) out <- point_estimate(c(3, 3, 3), centrality = "MAP", verbose = FALSE) expect_identical(out$MAP, 3) expect_message( point_estimate(x, centrality = "MAP", verbose = TRUE), regex = "Could not calculate MAP estimate" ) expect_message( point_estimate(c(3, 3, 3), centrality = "MAP", verbose = TRUE), regex = "Data is singular" ) }) bayestestR/tests/testthat/test-data.frame-with-rvar.R0000644000176200001440000001021114747200255022425 0ustar liggesuserstest_that("data.frame w/ rvar_col descrive_posterior etc", { # skip_on_ci() skip_on_cran() skip_if_not_installed("posterior") dfx <- data.frame(mu = c(0, 0.5, 1), sigma = c(1, 0.5, 0.25)) dfx$my_rvar <- posterior::rvar_rng(rnorm, 3, mean = dfx$mu, sd = dfx$sigma) dfx$other_rvar <- posterior::rvar_rng(rnorm, 3, mean = dfx$mu + 0.5, sd = dfx$sigma - 0.1) dfx ## Errors expect_error(p_direction(dfx, rvar_col = "mu")) expect_error(p_direction(dfx, rvar_col = "my_rvarrrrrr")) ## describe_posterior res <- describe_posterior(dfx, rvar_col = "my_rvar", centrality = "MAP", ci_method = "hdi", ci = 0.8, test = c("pd", "p_map", "rope", "equivalence_test"), rope_ci = 1, rope_range = c(-1, 0.5) ) res.ref <- describe_posterior(dfx$my_rvar, centrality = "MAP", ci_method = "hdi", ci = 0.8, test = c("pd", "p_map", "rope", "equivalence_test"), rope_ci = 1, rope_range = c(-1, 0.5) ) expect_true(all(c("mu", "sigma") %in% colnames(res))) expect_equal(res[setdiff(colnames(res), c("mu", "sigma"))], res.ref[setdiff(colnames(res.ref), "Parameter")], ignore_attr = TRUE ) ## CIs res <- eti(dfx, rvar_col = "my_rvar") res.ref <- eti(dfx$my_rvar) expect_true(all(c("mu", "sigma") %in% colnames(res))) expect_identical(nrow(format(res)), 3L) expect_identical(ncol(format(res)), 3L) expect_equal(res[setdiff(colnames(res), c("mu", "sigma"))], res.ref[setdiff(colnames(res.ref), "Parameter")], ignore_attr = TRUE ) res <- eti(dfx, rvar_col = "my_rvar", ci = c(0.8, 0.95)) res.ref <- eti(dfx$my_rvar, ci = c(0.8, 0.95)) expect_true(all(c("mu", "sigma") %in% colnames(res))) expect_identical( as.data.frame(res[c("mu", "sigma")]), data.frame( mu = c(0, 0, 0.5, 0.5, 1, 1), sigma = c(1, 1, 0.5, 0.5, 0.25, 0.25) ) ) expect_identical(nrow(format(res)), 3L) expect_identical(ncol(format(res)), 4L) expect_equal(res[setdiff(colnames(res), c("mu", "sigma"))], res.ref[setdiff(colnames(res.ref), "Parameter")], ignore_attr = TRUE ) ## estimate_density res <- estimate_density(dfx, rvar_col = "my_rvar") res.ref <- estimate_density(dfx$my_rvar) expect_true(all(c("mu", "sigma") %in% colnames(res))) expect_equal(res[setdiff(colnames(res), c("mu", "sigma"))], res.ref[setdiff(colnames(res.ref), "Parameter")], ignore_attr = TRUE ) }) test_that("data.frame w/ rvar_col bayesfactors", { # skip_on_ci() skip_on_cran() skip_if_not_installed("posterior") skip_if_not_installed("logspline") dfx <- data.frame(mu = c(0, 0.5, 1), sigma = c(1, 0.5, 0.25)) dfx$my_rvar <- posterior::rvar_rng(rnorm, 3, mean = dfx$mu, sd = dfx$sigma) dfx$other_rvar <- posterior::rvar_rng(rnorm, 3, mean = dfx$mu + 0.5, sd = dfx$sigma - 0.1) dfx ## SIs res <- si(dfx, rvar_col = "my_rvar", prior = "other_rvar", verbose = FALSE) res.ref <- si(dfx$my_rvar, prior = dfx$other_rvar, verbose = FALSE) expect_true(all(c("mu", "sigma") %in% colnames(res))) expect_identical(nrow(format(res)), 3L) expect_identical(ncol(format(res)), 3L) expect_equal(res[setdiff(colnames(res), c("mu", "sigma"))], res.ref[setdiff(colnames(res.ref), "Parameter")], ignore_attr = TRUE ) res <- si(dfx, rvar_col = "my_rvar", prior = "other_rvar", BF = c(1, 3), verbose = FALSE ) res.ref <- si(dfx$my_rvar, prior = dfx$other_rvar, BF = c(1, 3), verbose = FALSE ) expect_true(all(c("mu", "sigma") %in% colnames(res))) expect_identical(nrow(format(res)), 3L) expect_identical(ncol(format(res)), 4L) expect_equal(format(res[setdiff(colnames(res), c("mu", "sigma"))]), format(res.ref[setdiff(colnames(res.ref), "Parameter")]), ignore_attr = TRUE ) ## bayesfactor_parameters res <- bayesfactor_parameters(dfx, rvar_col = "my_rvar", prior = "other_rvar", verbose = FALSE ) res.ref <- bayesfactor_parameters(dfx$my_rvar, prior = dfx$other_rvar, verbose = FALSE ) expect_equal(res[setdiff(colnames(res), c("mu", "sigma"))], res.ref[setdiff(colnames(res.ref), "Parameter")], ignore_attr = TRUE ) }) bayestestR/tests/testthat/test-rstanarm.R0000644000176200001440000001264015174322463020342 0ustar liggesuserstest_that("rstanarm-1", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") 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(inherits(equivalence_test(model), "equivalence_test")) 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-2", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") set.seed(333) model <- insight::download_model("stanreg_glm_3") out <- describe_posterior( model, effects = "all", component = "all", centrality = "mean" ) s <- summary(model) expect_named( out, c( "Parameter", "Mean", "CI", "CI_low", "CI_high", "pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage", "Rhat", "ESS_tail" ) ) 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) out <- diagnostic_posterior(model) expect_named( out, c("Parameter", "Rhat", "MCSE", "ESS_tail", "ESS_bulk") ) }) test_that("rstanarm-3", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") set.seed(333) model <- insight::download_model("stanreg_merMod_3") out <- describe_posterior( model, effects = "all", component = "all", centrality = "mean" ) s <- summary(model) expect_named( out, c( "Parameter", "Effects", "Mean", "CI", "CI_low", "CI_high", "pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage", "Rhat", "ESS_tail" ) ) expect_equal(as.vector(s[c(1:4, 8), 1, drop = TRUE]), out$Mean, tolerance = 1e-3) expect_equal(as.vector(s[c(1:4, 8), 8, drop = TRUE]), out$Rhat, tolerance = 1e-1) out <- describe_posterior( model, effects = "full", component = "all", centrality = "mean" ) s <- summary(model) 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-4", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") 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_named( out, c( "Parameter", "Response", "Mean", "CI", "CI_low", "CI_high", "Rhat", "ESS_tail" ) ) 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-5", { skip_on_cran() skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") 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_tail", "Prior_Distribution", "Prior_Location", "Prior_Scale" ) ) expect_equal(nrow(out), 5) }) bayestestR/tests/testthat/test-simulate_data.R0000644000176200001440000000145414632236542021330 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.R0000644000176200001440000000632315151511631020110 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("rstan") skip_if_not_or_load_if_installed("cmdstanr") skip_if_not(dir.exists(cmdstanr::cmdstan_default_install_path())) 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_warning( bayesfactor_models(bfit, bfit2), regex = "Bayes factors might not be precise" ) ## FIXME: rror in `Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx])`: ## ! non-conformable arrays # 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_identical(nrow(x), 8L) ## FIXME: Error in `Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx])`: ## ! non-conformable arrays # x <- check_prior(bfit, simulate_priors = FALSE) # expect_identical(nrow(x), 10L) x <- diagnostic_posterior(bfit) expect_identical(nrow(x), 10L) ## FIXME: no longer 13, but now 9? x <- simulate_prior(bfit) expect_identical(ncol(x), 8L) # YES this is 13! We have two parameters with the same prior. ## FIXME: no longer 13, but now 9? x <- describe_prior(bfit) expect_identical(nrow(x), 8L) # 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.R0000644000176200001440000000356014510775166017134 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.R0000644000176200001440000000045214453436111020154 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.R0000644000176200001440000005101015174322463022373 0ustar liggesuserstest_that("describe_posterior-1", { skip_if(getRversion() < "4.2") skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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-2", { skip_on_os(c("mac", "linux")) skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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_tail" ) ) 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)) # allow multiple ropes rez <- describe_posterior(x, rope_range = list(c(-1, 1), "default")) expect_identical(rez$ROPE_low, c(-1, -0.1), tolerance = 1e-3) expect_identical(rez$ROPE_high, c(1, 0.1), tolerance = 1e-3) expect_error( describe_posterior(x, rope_range = list(1, "default")), regex = "should be 'default'" ) expect_error( describe_posterior(x, rope_range = list(c(1, 1), c(2, 2), c(2, 3))), regex = "Length of" ) 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_tail" ) ) 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-3", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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-4", { skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_or_load_if_installed("rstanarm") skip_if_not_or_load_if_installed("brms") 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 ) }) test_that("describe_posterior: response column for marginaleffects", { skip_if_not(getRversion() >= "4.0", "Don't run with R < 4.0") skip_if_not_installed("marginaleffects", minimum_version = "0.29.0") skip_if_not_installed("curl") skip_if_offline() skip_if_not_installed("httr2") skip_if_not_installed("brms") m <- insight::download_model("brms_categorical_1_num") skip_if(is.null(m)) out2 <- marginaleffects::avg_predictions(m, variables = "mpg") post <- describe_posterior(out2) expect_named( post, c( "mpg", "group", "Median", "CI", "CI_low", "CI_high", "pd", "ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage" ) ) expect_identical( post$group, c("3", "3", "3", "3", "3", "4", "4", "4", "4", "4", "5", "5", "5", "5", "5") ) }) bayestestR/tests/testthat.R0000644000176200001440000000010414411241742015517 0ustar liggesuserslibrary(testthat) library(bayestestR) test_check("bayestestR") bayestestR/MD50000644000176200001440000002544315204610032012710 0ustar liggesusers041a1731457e85757dff0bcbb4006508 *DESCRIPTION 6663a6c3ce19bfea152a82c1144916c1 *NAMESPACE 751e66776265bd388ba9c216ebfec6ca *NEWS.md abba91dd712374c43b79205e4948a8b1 *R/append_datagrid.R 0604665d2ad6f0c6a2f0307b6993f2c6 *R/area_under_curve.R a990bddd4c54e18ca2bb3b5cf954cbee *R/as.list.R 62aec9223076427152c4e6cd90717656 *R/bayesfactor-methods.R 2bc49e776e7ba4cc4b1451ee68ca7b9a *R/bayesfactor.R 6464381c16bbe363a469e184f5322209 *R/bayesfactor_inclusion.R 0ee462fed3693176f87d996a917f347d *R/bayesfactor_models.R 8d618aa58eae39b5b8a21a99d6b9975a *R/bayesfactor_parameters.R 965310f889473aaceb0812afbcf16f0d *R/bayesfactor_restricted.R 89fb8182fcba929c2bf1034641601fcc *R/bayestestR-package.R cb60aba84503325d8acee0fc80cfc9c2 *R/bci.R bbb2088ef0c7c5672462636f122d4e11 *R/bic_to_bf.R 43616ef31ac8e512d66175b5a0d0e65f *R/check_prior.R 8ba4c2295f229011d038aada3062b4b4 *R/ci.R 1e7184d4d5b95d2a4430b8ba4cc092b0 *R/contr.equalprior.R 8fd49be9f215e98477326851e5d404e8 *R/convert_bayesian_to_frequentist.R 65cc8eb91d4971fec04f7b762bbb9d42 *R/convert_pd_to_p.R e87daed2f8a248c6d092f14fc1b1ce6e *R/datasets.R ed11a650c1cd945b3b7d6444719ce53a *R/describe_posterior.R 326d0d000f4eacfcffc5e599c248cb42 *R/describe_prior.R 09c09d21dea86f52bb652d54a47e19f9 *R/diagnostic_draws.R 16ab82852163b4be6b813b40a6536637 *R/diagnostic_posterior.R bfbff3b692b2ecf166ad10e43984a31f *R/display.R 77185016c05cc7a27dcca577c0e94fa1 *R/distribution.R d16bf36d01be7a3ce71229f3ac7e98f6 *R/effective_sample.R b93b680a4920673ebc5b37716864c9a1 *R/equivalence_test.R 13c1c46462ea2646909fdee11f406226 *R/estimate_density.R 7e0d7d7e84c20f80a00e9b8c41c06e8a *R/eti.R 5de2d646133727c80196de67ae40c0e1 *R/format.R 94bbe41efe6e740d9775fdd7a150ec8e *R/hdi.R 142973cf322b691ca66ae2e6e73a461c *R/is_baysian_grid.R f3a3dad38a5fa7a5a110939334b7c111 *R/map_estimate.R 04b6c745d706b4bc653d650bda1ed7a8 *R/mcse.R 7a574d64cd9bab41987126f575e1155e *R/mediation.R 6b0cf45761ef3da66bb673fc19088a9e *R/model_to_priors.R 6f32de81368af70989efd003036bb653 *R/overlap.R b23c330dcf6678e313c60eb1676c9cab *R/p_direction.R 083a68b90aaeb0d77c81eb7276356123 *R/p_map.R 72d8f2896c378b4c765dbc7e0f69fcde *R/p_rope.R be57d8d90e1c70399cf059d43b749d01 *R/p_significance.R 573b9a44e5e1caf234a703536cca20a3 *R/p_to_bf.R 1ba410a92cded6f84210c41c6f77dff2 *R/plot.R c1f510d0b5e7d9cf3f4b0355a5bc9582 *R/point_estimate.R a29971072f67b7bb7a20954074f446f9 *R/print.R a817a716640e9d5920dbd5a9a881a5be *R/print.equivalence_test.R 8c9543c2f2a2e385f6f819c2afbb618a *R/print.rope.R 83c779b78ae29075801eccb7f6c1b52a *R/print_html.R 4c35a276dd78e7e0ac62b82f738a7dd1 *R/print_md.R 830219c70153eccb1158f6d24283a100 *R/reexports.R b18d7f1c872653866dd87887788e3730 *R/reshape_iterations.R afd189e5d4777006aaf986a9870fa84b *R/rope.R 1648d3359acd7c6068b09c38ba438219 *R/rope_range.R 09ed6ff00bc3589a6ae5d64c59f103b8 *R/sensitivity_to_prior.R b10bbbb0c48408a9667597a2ead955fc *R/sexit.R fa40dedef3d2ef6c67c01df6200c6ab6 *R/sexit_thresholds.R 7737b9b9997dfc2071c41111592690e5 *R/si.R c971f7f875161259a20c83aed50fd453 *R/simulate_data.R ac41bee408d8b01db844defd0b592dd5 *R/simulate_priors.R fcb6577d3cf2712abe915d5a3271b842 *R/simulate_simpson.R 003e630c5914eace0549828eb2188938 *R/spi.R 428cc26ed56d7abd7accde35e361f5cd *R/unupdate.R b9918b49f34632dcf4af4fee900c6409 *R/utils.R 5fd30d4fc357260b31a85587265693aa *R/utils_bayesfactor.R f565c1eb2687ca070458578fd272a454 *R/utils_check_collinearity.R 8f119fdc5c2fbc997a14d40e46a35d66 *R/utils_clean_stan_parameters.R e67afb11093763e3fd7410d166f4ba50 *R/utils_hdi_ci.R 506839f138e42454411368529c153561 *R/utils_posterior.R a14aa93c5a25aa65bfb66f857a19ae6f *R/utils_print_data_frame.R f54dda2e44ae101951b1ba2bc81efb26 *R/weighted_posteriors.R 4533f523d6cb92676f1d7912e088e29b *R/zzz.R fd0b7b92b00eb38e211bf4d247efb62a *README.md 9d5d57306c989a862d29353812d857e7 *build/partial.rdb 9b12ebdc20a841396c5b242bbf46dca8 *build/vignette.rds 0ff3ea913147c5a1b14eb94d50333b98 *data/disgust.rdata c5cfd3e44877e6f8487a7d57c28dd0e2 *inst/CITATION 9d02fbd79bedbc645d765538ab6d0039 *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 9358e073ae5ce590d62f80c11f9222cb *man/bayesfactor.Rd 7fca54fa2f9a398313de443ec1238590 *man/bayesfactor_inclusion.Rd ff14483419147823105d44d5823f9504 *man/bayesfactor_methods.Rd bbb6923c0b28545f55c657445d302e65 *man/bayesfactor_models.Rd 2fa4890a0ebb1c36e6d1affbcc39d201 *man/bayesfactor_parameters.Rd 7cdfc86427ef2aee570421311b68fcf7 *man/bayesfactor_restricted.Rd 33674c88ef04fdac6d0902ee74b5aedf *man/bayestestR-package.Rd 9bea52cf7550c1a49ddceebb773490eb *man/bci.Rd 0be80726d814018e2b8a86480ff4c64f *man/bic_to_bf.Rd a55184c4dfbf6aa611357a0533cb12cc *man/check_prior.Rd 350ac381a3e33b34fbb3e81b37053df4 *man/ci.Rd 6d9a9b22a1cb63e55eca9c5ebf5484a3 *man/contr.equalprior.Rd 79d931300c25fcd0158316f15127049c *man/convert_bayesian_as_frequentist.Rd 3b8a829f3b094fa97dccb2f654445209 *man/density_at.Rd 53faaf592b13d03130a80c442a960773 *man/describe_posterior.Rd ad60537015e5f50ccfdf9327e73939ad *man/describe_prior.Rd 078a26d5074e8319deb81d871738b45e *man/diagnostic_draws.Rd 119e366839affef4e8b814955bb7d175 *man/diagnostic_posterior.Rd 933a334f0afcb213569e4ad5d3446e6e *man/disgust.Rd fb0dedb2d4574ae1de4d4727084cffd9 *man/display.describe_posterior.Rd cdcb6fb83ce251c84c2bf9a578665f95 *man/distribution.Rd 0b1d93b59d19425ddb3a0d40f38210c1 *man/dot-extract_priors_rstanarm.Rd e450b5ed09ce1a54bb53cf57a436a1a5 *man/dot-prior_new_location.Rd 1991efd66189082be157e0b5d706e148 *man/dot-select_nums.Rd d998a2b07a7df4a997c297c051d4885d *man/effective_sample.Rd 04f330200427506f7305d3e52e967123 *man/equivalence_test.Rd c97f66c4a122fca73bf305f2fe39bdb6 *man/estimate_density.Rd 382fc1d50696ce7a9e327368d0789213 *man/eti.Rd 82b48e6234c70892f31f1e948c67b23f *man/figures/logo.png 5cd2ecf73323178c3900084729d7eb77 *man/figures/unnamed-chunk-10-1.png 162c4f2f782ea561b07fe285adc50fb6 *man/figures/unnamed-chunk-12-1.png 57c46354ee7d74a42216d516b7bfc6c2 *man/figures/unnamed-chunk-14-1.png 837e9e0fbf0f37e751317abffbabf7d6 *man/figures/unnamed-chunk-16-1.png 8973eba55961d11bec3f672090a155de *man/figures/unnamed-chunk-7-1.png 5a6870fa2832c5e9fa6851edd34acf1a *man/figures/unnamed-chunk-8-1.png f76fc8808f88380f6f74ae6c77c946ea *man/hdi.Rd 95c3c4ecdbbf79a4dddda68ca5358a8c *man/map_estimate.Rd 977401bdb31a182b36626217db46a1f6 *man/mcse.Rd c37fbf6356631d6accae6ab4aa9acee4 *man/mediation.Rd 04325eac6de74b6fd291888e66cdfddd *man/model_to_priors.Rd 24a2f8e0c2e682c815c1884908edf1b4 *man/overlap.Rd 8fcfb064014e93abd67c2891d12b6fd9 *man/p_direction.Rd f5d27a6ffed3a5bac0a1ad8dc5168314 *man/p_map.Rd 7454b6683d7028150e5d94d30635601d *man/p_rope.Rd 3c1c2886d6ede22a6bba952570d71853 *man/p_significance.Rd 9f59b4c376211c53536733abf47db596 *man/p_to_bf.Rd 8b0852b820074c1b636763cc0ad798e7 *man/pd_to_p.Rd 63d379c3f321c7dcb7faef27cccf8b2c *man/point_estimate.Rd aaea683a58ad207efc4a82b7cca5fcdb *man/reexports.Rd f9baf506f3a47e5e259a7417091cbce2 *man/reshape_iterations.Rd dbf08a07d20b8db4588ca519d7690992 *man/rope.Rd c2ac3fa7e6970b345f54469384a2a4b5 *man/rope_range.Rd 8ea91aafcc67f002dfb2f9667a41029c *man/sensitivity_to_prior.Rd 74de4edbbdf60a1b678d247fa0682cf6 *man/sexit.Rd 88a10e6bed8b5ae44887dfaa551df89b *man/sexit_thresholds.Rd 75871d2a6b4fbd39649b2dc43e997c4f *man/si.Rd 28d3c1370752a0cd210c259d239c848c *man/simulate_correlation.Rd 4417b147d85fd831d0e5a8aa7be5ef28 *man/simulate_prior.Rd 09e3cd658e432db590ef8c7d5a9e0e5d *man/simulate_simpson.Rd ad7ea80ad8fc279ac17c9430eacc009a *man/spi.Rd 4767200807e55ea397bcbb466e3c40a7 *man/unupdate.Rd d3622083d781e8536a4a522f06da2e63 *man/weighted_posteriors.Rd ed019fb28c42d301a471042302b2215d *tests/testthat.R 0e84b6d82ae0c55225f7b5606bc6ab10 *tests/testthat/helper.R 77395e828ae6acde88f6ea2ca2f9b222 *tests/testthat/test-BFBayesFactor.R a9cbb2928bdc3e39c85d40383e12f538 *tests/testthat/test-as.data.frame.density.R 45091d385066e015b4877c950cccf3c1 *tests/testthat/test-bayesfactor_models.R 7b14d05694c2de7e3b92337ef688f747 *tests/testthat/test-bayesfactor_parameters.R 873c782f8dfefe42a18fe0ba169874ca *tests/testthat/test-bayesfactor_restricted.R 103719ca3c022cfe6de1258124a001aa *tests/testthat/test-bayesian_as_frequentist.R 422cf27c215482eb08d3e0ac614e8406 *tests/testthat/test-blavaan.R 5a9fe325da32e46deccb0e31c83a9adb *tests/testthat/test-brms.R ce45b9cc1832cfd8b0ee9db71e094fb1 *tests/testthat/test-check_prior.R e7ce4a136ba3a5e3e19802ad5fefed00 *tests/testthat/test-ci.R 43dfdbc876dff66ea3914899c32f73c0 *tests/testthat/test-contr.R 0cf623ea068683b85c865cbeb60e46a1 *tests/testthat/test-data.frame-with-rvar.R 8cfbb3b3a84cc76ad6fac4e191b705a7 *tests/testthat/test-density_at.R f3c3b2af5e9e8305c54a7d69b4c05bb6 *tests/testthat/test-describe_posterior.R 9bc4de70fb0a2519092112cfabb87bb4 *tests/testthat/test-describe_prior.R 9bdf03fff4471656bfd557b7771f9e8e *tests/testthat/test-diagnostic_posterior.R db725a1034057c4cc62159b861fd88a1 *tests/testthat/test-different_models.R ed8c019fa0e88ef258102036899bf543 *tests/testthat/test-distributions.R 970659f4f08135ae9a0715000b383684 *tests/testthat/test-effective_sample.R 479eaa60235fcef08a0beb277b9f2616 *tests/testthat/test-emmGrid.R eedd6b294f489213fe0318772801b548 *tests/testthat/test-equivalence_test.R 72390c0791e5b44a7550bb9d5a06a677 *tests/testthat/test-estimate_density.R a13a9f515a42098194c484317fc682e5 *tests/testthat/test-format.R 87ec8528931521a99cdc613329dc103e *tests/testthat/test-hdi.R 6510bfd5cacef3fdb6244d11deff089d *tests/testthat/test-map_estimate.R ee600e75284969c9e20c4e9c7bb7f7b5 *tests/testthat/test-marginaleffects.R 7a8d3e0aff4d56f414f9adbc6f657275 *tests/testthat/test-overlap.R d4fa9fe6d52388d3e9de5f2219edf8e8 *tests/testthat/test-p_direction.R 23f5abe86c57b57759aea6e6bfb67fd4 *tests/testthat/test-p_map.R 5d7f121f28245b414edd320b64ad87c6 *tests/testthat/test-p_rope.R 6769988ee9935fdb9e0279da5ebfd208 *tests/testthat/test-p_significance.R 339b310dff63000e06b2f5a03836fb71 *tests/testthat/test-p_to_bf.R 7af7475726cb85b9af8c37003d69e88a *tests/testthat/test-pd_to_p.R b467985ca7568a4c3feee9a57cbba1ca *tests/testthat/test-point_estimate.R dd3a759e9294282d61adeab750c07bd4 *tests/testthat/test-posterior.R 5eaaea7589929d5388952a1c61d9e1c3 *tests/testthat/test-print.R 2f0201bc5b4c54a6ddad6b1b4ada48a0 *tests/testthat/test-rope.R 6bc4cc8671708ca3624ae49aae4e4650 *tests/testthat/test-rope_range.R bad75ef9017565560e0ac68ae7ed0528 *tests/testthat/test-rstanarm.R ff4c3c90dc4dce37fae9e8c3fef3787a *tests/testthat/test-si.R 97679c198087bafee22b280e9069032c *tests/testthat/test-simulate_data.R eded0048e363bbada93da3ea320cc643 *tests/testthat/test-spi.R 987d3efdbf307afc2c43d907f6a5ffef *tests/testthat/test-weighted_posteriors.R d3047f8dd544e4791a13e4ede781199f *vignettes/overview_of_vignettes.Rmd bayestestR/R/0000755000176200001440000000000015204535252012603 5ustar liggesusersbayestestR/R/format.R0000644000176200001440000002230715203314503014213 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, ...) sgn <- sign(BFE$log_BF) if (any((sgn < 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, ...) sgn <- sign(BFE$log_BF) if (any((sgn < 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, show_names = TRUE, 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, ...) sgn <- sign(BFE$log_BF) if (any((sgn < 0)[!is.na(BFE$log_BF)])) { BFE$BF[sgn] <- paste0("-", BFE$BF[sgn]) } BFE$log_BF <- NULL colnames(BFE)[colnames(BFE) == "p_prior"] <- "P(Prior)" colnames(BFE)[colnames(BFE) == "p_posterior"] <- "P(Posterior)" if (isTRUE(show_names) && !is.null(rownames(BFE))) { BFE$Hypothesis <- paste0("[", rownames(BFE), "] ", BFE$Hypothesis) } # 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, ...) sgn <- sign(x$log_BF) if (any((sgn < 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.R0000644000176200001440000000323214704176606016262 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") nuts_parameters <- brms::nuts_params(posterior) nuts_parameters$idvar <- paste0( nuts_parameters$Chain, "_", nuts_parameters$Iteration ) out <- stats::reshape( nuts_parameters, 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/bayesfactor-methods.R0000644000176200001440000001706315203314503016671 0ustar liggesusers#' Methods for Bayes factors #' #' @param x,object Bayes factor object #' @param ... Additional arguments (currently not used). #' #' @return #' - `as.numeric()` / `as.double()`: a numeric vector of (log) #' Bayes factors. #' - `as.logical()`: a logical data frame with a column for each #' order-restricted hypothesis. #' - `as.matrix()`: a square matrix of (log) Bayes factors, with rows as #' denominators and columns as numerators. #' - `update()`: an updated `bayesfactor_models` object. #' #' @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). See also `effectsize::interpret_bf()`. #' #' @section Transitivity of Bayes factors: #' For multiple inputs (models or hypotheses), the function will return multiple #' Bayes factors between each model and _the same_ reference model (the #' `denominator` or un-restricted model). However, we can take advantage of the #' transitivity of Bayes factors - where if we have two Bayes factors for Model #' _A_ and model _B_ against the _same reference model C_, we can obtain a Bayes #' factor for comparing model _A_ to model _B_ by dividing them: #' \cr\cr #' \deqn{BF_{AB} = \frac{BF_{AC}}{BF_{BC}} = \frac{\frac{ML_{A}}{ML_{C}}}{\frac{ML_{B}}{ML_{C}}} = \frac{ML_{A}}{ML_{B}}} #' \cr\cr #' (Where _ML_ is the _marginal likelihood_.) #' \cr\cr #' A full matrix comparing all models can be obtained with `as.matrix()`. #' #' @section Prior and posterior considerations: #' 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. #' \cr\cr #' 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*) (Note that by default, `brms::brm()` uses flat priors for #' fixed-effects); Wide priors result in smaller marginal likelihoods, and thus #' models with wider priors are trivially less likely than models with narrower #' priors - where, at the extreme, that a model with completely flat priors is #' infinitely less favorable than a point null model (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 #' Additionally, for models using MCMC estimation 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, a warning is issued. #' #' @rdname bayesfactor_methods #' @name bayesfactor_methods NULL ## as.matrix ------------------------- #' @param log Return log(BF) (default), or BF values. #' #' @rdname bayesfactor_methods #' @export as.matrix.bayestestRBF <- function(x, log = TRUE, ...) { if (inherits(x, "bayesfactor_restricted")) { log_BFs <- c(0, x$log_BF) models <- c("(Un-restricted)", x$Hypothesis) bf_fun <- "bayesfactor_restricted()" } else if (inherits(x, "bayesfactor_models")) { log_BFs <- x$log_BF models <- x$Model bf_fun <- "bayesfactor_models()" } else { insight::format_error("Cannot extract a Bayes factor matrix from this object.") } out <- -outer(log_BFs, log_BFs, FUN = "-") rownames(out) <- colnames(out) <- models if (!log) { out <- exp(out) } class(out) <- c("bayesfactor_matrix", class(out)) attr(out, "model_names") <- rownames(x) attr(out, "log_BF") <- log attr(out, "bf_fun") <- bf_fun out } #' @export print.bayesfactor_matrix <- function(x, log = FALSE, show_names = FALSE, ...) { orig_x <- x orig_log <- attr(x, "log_BF") # Format values x <- unclass(x) if (log) { if (!orig_log) { x <- log(x) } sgn <- sign(x) < 0 x <- insight::format_value(abs(x), digits = 2, ...) if (any(sgn)) { x[sgn] <- paste0("-", x[sgn]) } diag(x) <- "0" } else { if (orig_log) { x <- exp(x) } x <- insight::format_bf(x, name = NULL, exact = TRUE, ...) diag(x) <- "1" } df <- as.data.frame(x) # Model names models <- colnames(df) models[models == "1"] <- "(Intercept only)" if (show_names && !is.null(attr(orig_x, "model_names"))) { model_names <- attr(orig_x, "model_names") if (attr(orig_x, "bf_fun") == "bayesfactor_restricted()") { model_names <- c(1, model_names) } } else { model_names <- seq_along(models) } rowmodels <- paste0("[", model_names, "] ", models) colmodels <- c("Denominator\\Numerator", paste0(" [", model_names, "] ")) rownames(df) <- colnames(df) <- NULL df <- cbind(modl = rowmodels, df) colnames(df) <- colmodels # caption and footer caption <- switch( attr(orig_x, "bf_fun"), "bayesfactor_restricted()" = "# Bayes Factors for Restricted Models", "# Bayes Factors for Model Comparison" ) footer <- if (log) c("\nBayes Factors are on the log-scale.\n", "red") out <- insight::export_table( df, caption = c(caption, "blue"), footer = footer ) # Fix spacing out <- sub("Denominator", " Denominator", out, fixed = TRUE) cat(out) invisible(orig_x) } ## update ------------------------- #' @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. #' #' @rdname bayesfactor_methods #' @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] } subset <- unique(c(denominator, subset)) object_subset <- datawizard::data_filter(object, subset) model_names <- attr(object, "model_names") if (!is.null(model_names)) { attr(object_subset, "model_names") <- model_names[subset] } attr(object_subset, "denominator") <- 1 object <- object_subset } object } ## as.numeric ------------------------------------------------------- #' @rdname bayesfactor_methods #' @export as.numeric.bayestestRBF <- function(x, log = FALSE, ...) { out <- x[["log_BF"]] if (!log) { out <- exp(out) } out } #' @export as.double.bayestestRBF <- as.numeric.bayestestRBF ## as.logical ----------------------------------------------------------------- #' @param which Should the logical matrix be of the posterior or prior distribution(s)? #' #' @rdname bayesfactor_methods #' @export as.logical.bayesfactor_restricted <- function(x, which = c("posterior", "prior"), ...) { which <- match.arg(which) as.matrix(attr(x, "bool_results")[[which]]) } bayestestR/R/effective_sample.R0000644000176200001440000001614715203314503016231 0ustar liggesusers#' Effective Sample Size (ESS) #' #' Effective Sample Size (ESS) is a measure of how much independent information #' there is in autocorrelated chains. It is used to assess the quality of MCMC #' samples. A higher ESS indicates more reliable estimates. For most #' applications, an effective sample size greater than 1,000 is sufficient for #' stable estimates (Bürkner, 2017). This function returns the effective sample #' size (ESS) for various Bayesian model objects. For `brmsfit`, `stanreg`, and #' `stanfit` objects, both **bulk-ESS** and **tail-ESS** are returned. #' #' @param model A `stanreg`, `stanfit`, `brmsfit`, `blavaan`, or `MCMCglmm` object. #' @param ... Currently not used. #' @inheritParams hdi #' #' @inheritSection hdi Model components #' #' @return A data frame with columns for the parameter name, bulk ESS (`ESS`), #' and (where available) tail ESS (`ESS_tail`). #' #' @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*). #' #' - **Bulk-ESS** is useful as a diagnostic for the sampling efficiency in #' the bulk of the posterior. It is defined as the effective sample size for #' rank normalized values using split chains. It can be interpreted as the #' reliability of indices of central tendency (mean, median, etc.). #' #' - **Tail-ESS** is useful as a diagnostic for the sampling efficiency in #' the tails of the posterior. It is defined as the minimum of the effective #' sample sizes for 5% and 95% quantiles. It can be interpreted as the #' reliability of indices that depend on the tails of the distribution (e.g., #' credible intervals, tail probabilities, etc.). #' #' @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 #' - Vehtari, A., Gelman, A., Simpson, D., Carpenter, B., & Bürkner, P.-C. #' (2021). Rank-normalization, folding, and localization: An improved R-hat #' for assessing convergence of MCMC. Bayesian Analysis, 16(2), 667-718. #' #' @examplesIf all(insight::check_if_installed(c("rstanarm", "brms", "posterior"), quietly = TRUE)) #' \donttest{ #' model <- suppressWarnings(rstanarm::stan_glm( #' mpg ~ wt + gear, #' data = mtcars, #' chains = 2, #' iter = 200, #' refresh = 0 #' )) #' effective_sample(model) #' #' model <- suppressWarnings(brms::brm( #' mpg ~ wt, #' 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 = "fixed", component = "conditional", parameters = NULL, ... ) { pars <- insight::find_parameters( model, effects = effects, component = component, parameters = parameters, flatten = TRUE ) insight::check_if_installed("posterior") idx <- as.data.frame(posterior::summarise_draws(model)) rows_to_keep <- idx$variable %in% pars # ess_*() functions are defined in: # https://github.com/stan-dev/posterior/blob/master/R/convergence.R data.frame( Parameter = idx$variable[rows_to_keep], ESS_bulk = round(idx[rows_to_keep, "ess_bulk"]), ESS_tail = round(idx[rows_to_keep, "ess_tail"]), stringsAsFactors = FALSE, row.names = NULL ) } #' @export effective_sample.stanreg <- function( model, effects = "fixed", component = "location", parameters = NULL, ... ) { effective_sample.brmsfit( model, effects = effects, component = component, parameters = parameters, ... ) } #' @export effective_sample.stanmvreg <- function( model, effects = "fixed", component = "location", parameters = NULL, ... ) { pars <- insight::get_parameters( model, effects = effects, component = component, parameters = parameters ) insight::check_if_installed("posterior") idx <- as.data.frame(posterior::summarise_draws(model)) rows_to_keep <- idx$variable %in% colnames(pars) # ess_*() functions are defined in: # https://github.com/stan-dev/posterior/blob/master/R/convergence.R data.frame( Parameter = idx$variable[rows_to_keep], ESS_bulk = round(idx[rows_to_keep, "ess_bulk"]), ESS_tail = round(idx[rows_to_keep, "ess_tail"]), stringsAsFactors = FALSE, row.names = NULL ) } #' @export effective_sample.stanfit <- function(model, effects = "fixed", parameters = NULL, ...) { pars <- insight::get_parameters( model, effects = effects, parameters = parameters ) insight::check_if_installed("posterior") idx <- as.data.frame(posterior::summarise_draws(model)) rows_to_keep <- idx$variable %in% colnames(pars) # ess_*() functions are defined in: # https://github.com/stan-dev/posterior/blob/master/R/convergence.R data.frame( Parameter = idx$variable[rows_to_keep], ESS_bulk = round(idx[rows_to_keep, "ess_bulk"]), ESS_tail = round(idx[rows_to_keep, "ess_tail"]), stringsAsFactors = FALSE, row.names = NULL ) } #' @export effective_sample.CmdStanFit <- function(model, ...) { diagnostic_posterior(model, diagnostic = c("ESS", "ESS_tail")) } #' @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 = "fixed", parameters = NULL, ...) { 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.R0000644000176200001440000000456514506267331013722 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.R0000644000176200001440000000230614704176606014645 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) { delta } else { exp(delta) } } bayestestR/R/spi.R0000644000176200001440000003460315203314503013520 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 #' @rdname spi #' @inheritParams p_direction spi.data.frame <- function(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::spi cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x, long = length(ci) > 1L)) } dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "spi") attr(dat, "object_name") <- obj_name dat } #' @export spi.draws <- function(x, ci = 0.95, verbose = TRUE, ...) { dat <- .compute_interval_dataframe( x = .posterior_draws_to_df(x), ci = ci, verbose = verbose, fun = "spi" ) attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export spi.rvar <- spi.draws #' @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 = "all", verbose = TRUE, ...) { 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 = "fixed", parameters = NULL, verbose = TRUE, ... ) { 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, verbose = verbose) out <- spi(xdf, ci = ci, verbose = verbose, ...) out <- .append_datagrid(out, x, long = length(ci) > 1L) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export spi.emm_list <- spi.emmGrid #' @export spi.slopes <- function(x, ci = 0.95, verbose = TRUE, ...) { xrvar <- .get_marginaleffects_draws(x) out <- spi(xrvar, ci = ci, verbose = verbose, ...) out <- .append_datagrid(out, x, long = length(ci) > 1L) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export spi.comparisons <- spi.slopes #' @export spi.predictions <- spi.slopes #' @export spi.stanreg <- function( x, ci = 0.95, effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ... ) { cleaned_parameters <- .get_cleaned_parameters(x, ...) out <- .prepare_output( spi( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, verbose = verbose ), 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.CmdStanFit <- spi.stanreg #' @export spi.blavaan <- spi.stanreg #' @rdname spi #' @export spi.brmsfit <- function( x, ci = 0.95, effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ... ) { 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] 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.R0000644000176200001440000005625215203314503015230 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, ...). #' @param as_p If `TRUE`, the p-direction (pd) values are converted to a #' frequentist p-value using [`pd_to_p()`]. #' @param remove_na Should missing values be removed before computation? Note #' that `Inf` (infinity) are *not* removed. #' @param rvar_col Name of an `rvar`-type column. If `NULL`, each column in the #' data frame is assumed to represent draws from a posterior distribution. #' @inheritParams hdi #' @inheritParams insight::get_parameters.BFBayesFactor #' #' @inheritSection hdi Model components #' #' @section 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). #' #' @section 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*): #' \ifelse{html}{\out{p = 2 * (1 - pd)}}{\eqn{p = 2 \times (1 - p_d)}} #' 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. #' #' @section 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. #' #' **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). #' #' **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). #' #' 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`). #' #' @section 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))} #' #' 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. #' #' 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} #' #' @examplesIf requireNamespace("rstanarm", quietly = TRUE) && requireNamespace("emmeans", quietly = TRUE) && requireNamespace("brms", quietly = TRUE) && requireNamespace("BayesFactor", quietly = TRUE) #' 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 #' # ----------------------------------------------- #' model <- rstanarm::stan_glm(mpg ~ wt + cyl, #' data = mtcars, #' chains = 2, refresh = 0 #' ) #' p_direction(model) #' p_direction(model, method = "kernel") #' #' # emmeans #' # ----------------------------------------------- #' p_direction(emmeans::emtrends(model, ~1, "wt", data = mtcars)) #' #' # brms models #' # ----------------------------------------------- #' model <- brms::brm(mpg ~ wt + cyl, data = mtcars) #' p_direction(model) #' p_direction(model, method = "kernel") #' #' # BayesFactor objects #' # ----------------------------------------------- #' bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) #' p_direction(bf) #' p_direction(bf, method = "kernel") #' } #' #' @examplesIf requireNamespace("posterior", quietly = TRUE) #' # Using "rvar_col" #' x <- data.frame(mu = c(0, 0.5, 1), sigma = c(1, 0.5, 0.25)) #' x$my_rvar <- posterior::rvar_rng(rnorm, 3, mean = x$mu, sd = x$sigma) #' x #' p_direction(x, rvar_col = "my_rvar") #' #' @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, as_p = FALSE, remove_na = TRUE, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) out <- p_direction( data.frame(Posterior = x), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) attr(out, "object_name") <- obj_name out } #' @rdname p_direction #' @param rvar_col A single character - the name of an `rvar` column in the data #' frame to be processed. See example in [p_direction()]. #' @export p_direction.data.frame <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, rvar_col = NULL, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::p_direction cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x)) } x <- .select_nums(x) if (ncol(x) == 1) { pd <- .p_direction( x[[1]], method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) } else { pd <- sapply( x, .p_direction, method = method, null = null, as_p = as_p, remove_na = remove_na, simplify = TRUE, ... ) } out <- data.frame( Parameter = names(x), pd = pd, row.names = NULL, stringsAsFactors = FALSE ) # rename column if (as_p) { colnames(out)[2] <- "p" } attr(out, "object_name") <- obj_name attr(out, "as_p") <- as_p class(out) <- unique(c("p_direction", "see_p_direction", class(out))) out } #' @export p_direction.draws <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { p_direction( .posterior_draws_to_df(x), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) } #' @export p_direction.rvar <- p_direction.draws #' @export p_direction.MCMCglmm <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { nF <- x$Fixed$nfl out <- p_direction(as.data.frame(x$Sol[, 1:nF, drop = FALSE]), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_direction.mcmc <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { p_direction( as.data.frame(x), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) } #' @export p_direction.BGGM <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { p_direction( as.data.frame(x), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) } #' @export p_direction.bcplm <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { p_direction( insight::get_parameters(x), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) } #' @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, as_p = FALSE, remove_na = TRUE, component = "all", ...) { out <- p_direction( insight::get_parameters(x, component = component), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) out <- .add_clean_parameters_attribute(out, x) out } #' @export p_direction.emmGrid <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { xdf <- insight::get_parameters(x) out <- p_direction( xdf, method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_direction.emm_list <- p_direction.emmGrid #' @export p_direction.slopes <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { xrvar <- .get_marginaleffects_draws(x) out <- p_direction( xrvar, method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_direction.comparisons <- p_direction.slopes #' @export p_direction.predictions <- p_direction.slopes #' @keywords internal .p_direction_models <- function(x, effects, component, parameters, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { p_direction( insight::get_parameters( x, effects = effects, component = component, parameters = parameters ), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) } #' @export p_direction.sim.merMod <- function(x, effects = "fixed", parameters = NULL, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { out <- .p_direction_models( x = x, effects = effects, component = "conditional", parameters = parameters, method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) attr(out, "data") <- insight::get_parameters( x, effects = effects, parameters = parameters ) out } #' @export p_direction.sim <- function(x, parameters = NULL, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { out <- .p_direction_models( x = x, effects = "fixed", component = "conditional", parameters = parameters, method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) attr(out, "data") <- insight::get_parameters(x, parameters = parameters) out } #' @export p_direction.stanreg <- function(x, effects = "fixed", component = "location", parameters = NULL, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { cleaned_parameters <- .get_cleaned_parameters(x, ...) out <- .prepare_output( p_direction( insight::get_parameters( x, effects = effects, component = component, parameters = parameters ), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ), 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)) attr(out, "as_p") <- as_p out } #' @export p_direction.stanfit <- p_direction.stanreg #' @export p_direction.CmdStanFit <- p_direction.stanreg #' @export p_direction.blavaan <- p_direction.stanreg #' @rdname p_direction #' @export p_direction.brmsfit <- function(x, effects = "fixed", component = "conditional", parameters = NULL, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { cleaned_parameters <- .get_cleaned_parameters(x, ...) out <- .prepare_output( p_direction( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, ... ), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ), 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)) attr(out, "as_p") <- as_p out } #' @export p_direction.BFBayesFactor <- function(x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ...) { out <- p_direction( insight::get_parameters(x), method = method, null = null, as_p = as_p, remove_na = remove_na, ... ) 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, as_p = FALSE, remove_na = TRUE, 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, as_p = as_p, remove_na = remove_na, 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, as_p = as_p, remove_na = remove_na, 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, as_p = FALSE, remove_na = TRUE, ...) { # handle missing values if (remove_na) { x <- x[!is.na(x)] } # sanity check if (length(x) == 0) { insight::format_error("No valid values found. Maybe the data contains only missing values.") } # sanity check if (anyNA(x)) { return(NA_real_) } # any inf values? then warn... if (any(is.infinite(x))) { insight::format_warning("Infinite values detected. These are not removed. Please check your results carefully!") } 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 } } # convert to frequentist p? if (as_p) { pdir <- pd_to_p(pdir) } 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")) { # check if we have frequentist p-values if (isTRUE(attributes(x)$as_p) && "p" %in% colnames(x)) { as.numeric(as.vector(x$p)) } else { as.numeric(as.vector(x$pd)) } } else { as.vector(x) } } #' @method as.double p_direction #' @export as.double.p_direction <- as.numeric.p_direction #' @method as.vector p_direction #' @export as.vector.p_direction <- as.numeric.p_direction bayestestR/R/bci.R0000644000176200001440000002042415203314503013456 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 #' #' @inheritSection hdi Model components #' #' @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 #' @inheritParams p_direction #' @export bci.data.frame <- function(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::bci cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x, long = length(ci) > 1L)) } dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "bci") attr(dat, "object_name") <- obj_name 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 #' @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 = "all", verbose = TRUE, ...) { d <- insight::get_parameters(x, component = component, verbose = verbose) 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, verbose = verbose) 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 #' @export bci.sim.merMod <- function(x, ci = 0.95, effects = "fixed", parameters = NULL, verbose = TRUE, ...) { 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 } #' @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 } #' @export bci.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) { xdf <- insight::get_parameters(x, verbose = verbose) dat <- bci(xdf, ci = ci, verbose = verbose, ...) dat <- .append_datagrid(dat, x, long = length(ci) > 1L) attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export bci.emm_list <- bci.emmGrid #' @export bci.slopes <- function(x, ci = 0.95, verbose = TRUE, ...) { xrvar <- .get_marginaleffects_draws(x) dat <- bci(xrvar, ci = ci, verbose = verbose, ...) dat <- .append_datagrid(dat, x, long = length(ci) > 1L) attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export bci.comparisons <- bci.slopes #' @export bci.predictions <- bci.slopes #' @export bci.stanreg <- function(x, ci = 0.95, effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ...) { out <- .prepare_output( bci( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, verbose = verbose ), ci = ci, verbose = verbose, ... ), .get_cleaned_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.CmdStanFit <- bci.stanreg #' @export bci.blavaan <- bci.stanreg #' @rdname bci #' @export bci.brmsfit <- function(x, ci = 0.95, effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ...) { out <- .prepare_output( bci( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, verbose = verbose ), ci = ci, verbose = verbose, ... ), .get_cleaned_parameters(x, ...) ) class(out) <- unique(c("bayestestR_eti", "see_eti", class(out))) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @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.R0000644000176200001440000001421115203314503014052 0ustar liggesusers#' @rdname display.describe_posterior #' @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, ...) { # check if we have multiple ROPE values if (insight::n_unique(x$ROPE_low) > 1) { caption <- "Proportion of samples inside the ROPE" } else { 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, ...) { threshold <- attributes(x)$threshold if (is.list(threshold)) { caption <- "Practical Significance" out <- as.data.frame(do.call(rbind, threshold)) colnames(out) <- c("ROPE_low", "ROPE_high") x$ROPE_low <- out$ROPE_low x$ROPE_high <- out$ROPE_high ci_string <- "ROPE" } else { caption <- sprintf( "Practical Significance (threshold: %s)", insight::format_value(attributes(x)$threshold, digits = digits) ) ci_string <- NULL } .print_default( x = x, digits = digits, caption = caption, ci_string = ci_string, ... ) } #' @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 = FALSE, 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, show_names = FALSE, caption = "Bayes Factor (Order-Restriction)", ... ) { .print_bf_default( x = x, digits = digits, log = log, show_names = show_names, 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.R0000644000176200001440000001547215024725704015232 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") } #' @rdname check_prior #' @export check_prior.brmsfit <- function(model, method = "gelman", simulate_priors = TRUE, effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ...) { 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 = .get_cleaned_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.R0000644000176200001440000000317314677052677016347 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. #' #' @examplesIf requireNamespace("MASS", quietly = TRUE) #' 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.R0000644000176200001440000002262715203314503017021 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 .weighted_posteriors(Mods, weighted_samps, missing, mnames) } #' @export #' @rdname weighted_posteriors weighted_posteriors.stanreg <- function( ..., prior_odds = NULL, missing = 0, verbose = TRUE, effects = "fixed", component = "conditional", parameters = NULL ) { Mods <- list(...) mnames <- sapply(match.call(expand.dots = FALSE)$`...`, insight::safe_deparse) # 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 # extract parameters params <- lapply( Mods, insight::get_parameters, effects = effects, component = component, parameters = parameters ) # Compute weighted number of samples iterations <- min(sapply(params, nrow)) weighted_samps <- round(iterations * postProbs) .weighted_posteriors(params, weighted_samps, missing, mnames) } #' @export weighted_posteriors.brmsfit <- weighted_posteriors.stanreg #' @export weighted_posteriors.blavaan <- weighted_posteriors.stanreg #' @export weighted_posteriors.CmdStanFit <- weighted_posteriors.stanreg #' @rdname weighted_posteriors #' @export 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) .weighted_posteriors(params, weighted_samps, missing, BFMods$Model) } .weighted_posteriors <- function(params, weighted_samps, missing, mnames) { par_names <- unique(unlist(sapply(params, colnames), recursive = TRUE)) # Table of weights weights <- data.frame( Model = mnames, weights = weighted_samps, pweights = weighted_samps / sum(weighted_samps) ) # 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 res <- do.call("rbind", params) attr(res, "weights") <- weights return(res) } bayestestR/R/unupdate.R0000644000176200001440000000753414766532531014575 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 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 } #' @rdname unupdate #' @export 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 } #' @rdname unupdate #' @export 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 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.R0000644000176200001440000004461115204535252017166 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; a #' list of data frames or matrices representing MCMC chains (rows as samples, #' columns as parameters); or a 3D array (dimensions: samples, chains, #' parameters) #' @param diagnostic Diagnostic metrics to compute. Character (vector) or list #' with one or more of these options: `"ESS"`, `"ESS_bulk"`, `"Rhat"`, `"MCSE"` #' or `"all"`. `"ESS"` returns the **tail-ESS** (the minimum of the effective #' sample sizes for the 5% and 95% quantiles), which is the most relevant #' diagnostic for assessing the reliability of credible intervals and other #' tail-based quantities. `"ESS_bulk"` additionally returns the **bulk-ESS** #' (the effective sample size for the bulk of the posterior, useful for #' assessing the reliability of central tendency estimates such as the mean or #' median). `"all"` includes both tail and bulk `"ESS"`, `"Rhat"`, and `"MCSE"`. #' @param centrality The point-estimate (centrality index) for which to compute #' the MCSE. Can be `"median"` (default) or `"mean"`. To not break other #' functions like `describe_posterior()` or `diagnostic_posterior()`, all other #' values are silently converted to `"median"`. #' #' @inheritSection hdi Model components #' #' @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 returned by #' `diagnostic_posterior()` is the **tail-ESS**: it corresponds to the #' minimum of the effective sample sizes for the 5% and 95% quantiles, and #' is a diagnostic for the sampling efficiency in the tails of the posterior #' distribution. It is more relevant than the bulk-ESS for assessing #' the reliability of credible intervals, probabilities of direction, and #' other tail-based quantities. Note that the tail-ESS may differ from the #' ESS reported by `brms` (`Bulk_ESS`) or other tools; use `"ESS_bulk"` to #' also retrieve the bulk-ESS. #' #' **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) #' } #' @examplesIf require("rstan") #' set.seed(101) #' mkdata <- function(nrow = 1000, ncol = 2, parnm = LETTERS[1:ncol]) { #' x <- as.data.frame(replicate(ncol, rnorm(nrow))) #' names(x) <- parnm #' x #' } #' dd <- replicate(5, mkdata(), simplify = FALSE) #' diagnostic_posterior(dd) #' @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 = "all", ...) { ## check input, coerce to array if (is.list(posterior)) { for (i in seq_along(posterior)) { p <- posterior[[i]] if ( !((inherits(p, "data.frame") || inherits(p, "matrix")) && (length(dim(p)) == 2) && (ncol(p) == ncol(posterior[[1]]))) ) { insight::format_error( "'posterior' must be a 3D array or a list of data frames with equal numbers of columns." ) } } insight::check_if_installed("posterior") posterior <- posterior::as_draws_array(posterior) ## draws_array() class messes things up downstream ... class(posterior) <- "array" } if (!(inherits(posterior, "array") && length(dim(posterior)) == 3)) { insight::format_error("Expecting a 3D array for 'posterior'.") } ret <- data.frame(Parameter = colnames(posterior[[1]])) if (is.null(diagnostic)) { return(ret) } .diag_opts <- c("Rhat", "ESS", "ESS_bulk", "MCSE") if (diagnostic == "all") { diagnostic <- c("Rhat", "ESS", "MCSE") } ## need ESS for MCSE, so compute these in any case insight::check_if_installed("rstan") mon <- rstan::monitor(posterior, print = FALSE, probs = 0.5) mon_df <- as.data.frame(mon) # Use Tail_ESS if available (rstan >= 2.21), otherwise fall back to n_eff ess_col <- if ("Tail_ESS" %in% names(mon_df)) { round(mon_df[["Tail_ESS"]]) } else { mon_df[["n_eff"]] } ret <- data.frame( Parameter = rownames(mon), ESS = ess_col, Rhat = mon_df[["Rhat"]], MCSE = mon_df[["MCSE_Q50"]] ) if ("ESS_bulk" %in% diagnostic && "Bulk_ESS" %in% names(mon_df)) { ret$ESS_bulk <- round(mon_df[["Bulk_ESS"]]) } ret[c("Parameter", intersect(diagnostic, names(ret)))] } #' @inheritParams insight::get_parameters.BFBayesFactor #' @inheritParams insight::get_parameters #' #' @rdname diagnostic_posterior #' @export diagnostic_posterior.stanreg <- function( posterior, diagnostic = "all", effects = "fixed", component = "location", parameters = NULL, centrality = "median", ... ) { # Find parameters 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", "ESS_bulk", "Rhat", "MCSE", "all"), several.ok = TRUE ) if ("all" %in% diagnostic) { diagnostic <- c("ESS_tail", "ESS_bulk", "Rhat", "MCSE", "khat") } else { diagnostic <- diagnostic if ("Rhat" %in% diagnostic) { diagnostic <- c(diagnostic, "khat") } } # ESS: use tail ESS by default, with optional bulk ESS if ("ESS" %in% diagnostic) { diagnostic[diagnostic == "ESS"] <- "ESS_tail" } # Get indices and rename diagnostic_df <- as.data.frame(posterior$stan_summary) diagnostic_df$Parameter <- row.names(diagnostic_df) # special handling for MCSE, due to some parameters (like lp__) missing in rows MCSE <- mcse(posterior, effects = "full", centrality = centrality) diagnostic_df <- merge(diagnostic_df, MCSE, by = "Parameter", all = FALSE) # ESS: use tail ESS by default, with optional bulk ESS if (any(c("ESS_tail", "ESS_bulk") %in% diagnostic)) { ess_data <- effective_sample( posterior, effects = effects, component = component, parameters = parameters ) if ("ESS_tail" %in% diagnostic && "ESS_tail" %in% names(ess_data)) { # fmt: skip diagnostic_df$ESS_tail <- stats::setNames(ess_data$ESS_tail, ess_data$Parameter)[diagnostic_df$Parameter] } if ("ESS_bulk" %in% diagnostic && "ESS_bulk" %in% names(ess_data)) { # fmt: skip diagnostic_df$ESS_bulk <- stats::setNames(ess_data$ESS_bulk, ess_data$Parameter)[diagnostic_df$Parameter] } } # 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 = "fixed", parameters = NULL, centrality = "median", ... ) { # Find parameters 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", "ESS_bulk", "Rhat", "MCSE", "all"), several.ok = TRUE ) if ("all" %in% diagnostic) { diagnostic <- c("ESS_tail", "ESS_bulk", "Rhat", "MCSE", "khat") } else { diagnostic <- diagnostic if ("Rhat" %in% diagnostic) diagnostic <- c(diagnostic, "khat") } # ESS: use tail ESS by default, with optional bulk ESS if ("ESS" %in% diagnostic) { diagnostic[diagnostic == "ESS"] <- "ESS_tail" } # Get indices and rename diagnostic_df <- as.data.frame(posterior$stan_summary) diagnostic_df$Parameter <- row.names(diagnostic_df) # special handling for MCSE, due to some parameters (like lp__) missing in rows MCSE <- mcse(posterior, effects = effects, centrality = centrality) diagnostic_df <- merge(diagnostic_df, MCSE, by = "Parameter", all = FALSE) # ESS: use tail ESS by default, with optional bulk ESS if (any(c("ESS_tail", "ESS_bulk") %in% diagnostic)) { ess_data <- effective_sample( posterior, effects = effects, parameters = parameters ) if ("ESS_tail" %in% diagnostic && "ESS_tail" %in% names(ess_data)) { # fmt: skip diagnostic_df$ESS_tail <- stats::setNames(ess_data$ESS_tail, ess_data$Parameter)[diagnostic_df$Parameter] } if ("ESS_bulk" %in% diagnostic && "ESS_bulk" %in% names(ess_data)) { # fmt: skip diagnostic_df$ESS_bulk <- stats::setNames(ess_data$ESS_bulk, ess_data$Parameter)[diagnostic_df$Parameter] } } # 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) # Select rows diagnostic_df <- diagnostic_df[diagnostic_df$Parameter %in% params, ] # clean parameters for (i in unique(diagnostic_df$Response)) { diagnostic_df$Parameter <- gsub( sprintf("%s|", i), "", diagnostic_df$Parameter, fixed = TRUE ) } diagnostic_df } #' @inheritParams insight::get_parameters #' @export diagnostic_posterior.brmsfit <- function( posterior, diagnostic = "all", effects = "fixed", component = "conditional", parameters = NULL, centrality = "median", ... ) { # Find parameters 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", "ESS_bulk", "Rhat", "MCSE", "all"), several.ok = TRUE ) if ("all" %in% diagnostic) { diagnostic <- c("ESS_tail", "ESS_bulk", "Rhat", "MCSE") } # ESS: use tail ESS by default, with optional bulk ESS if ("ESS" %in% diagnostic) { diagnostic[diagnostic == "ESS"] <- "ESS_tail" } # Initialize diagnostic dataframe diagnostic_df <- data.frame(Parameter = params, stringsAsFactors = FALSE) # Use posterior::summarise_draws() as single source for Rhat and ESS if (any(c("ESS_tail", "ESS_bulk", "Rhat") %in% diagnostic)) { insight::check_if_installed("posterior") idx <- as.data.frame(posterior::summarise_draws(posterior)) idx <- idx[idx$variable %in% params, ] if ("Rhat" %in% diagnostic) { rhat_df <- data.frame( Parameter = idx$variable, Rhat = idx$rhat, stringsAsFactors = FALSE ) diagnostic_df <- merge(diagnostic_df, rhat_df, by = "Parameter", all.x = TRUE) } if ("ESS_tail" %in% diagnostic) { ess_df <- data.frame( Parameter = idx$variable, ESS_tail = round(idx$ess_tail), stringsAsFactors = FALSE ) diagnostic_df <- merge(diagnostic_df, ess_df, by = "Parameter", all.x = TRUE) } if ("ESS_bulk" %in% diagnostic) { ess_bulk_df <- data.frame( Parameter = idx$variable, ESS_bulk = round(idx$ess_bulk), stringsAsFactors = FALSE ) diagnostic_df <- merge(diagnostic_df, ess_bulk_df, by = "Parameter", all.x = TRUE) } } # MCSE if ("MCSE" %in% diagnostic) { MCSE <- mcse( posterior, effects = effects, component = component, parameters = parameters, centrality = centrality ) diagnostic_df <- merge(diagnostic_df, MCSE, by = "Parameter", all.x = TRUE) } row.names(diagnostic_df) <- NULL # Remove columns with all NAs 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 = "fixed", parameters = NULL, centrality = "median", ... ) { # Find parameters 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", "ESS_bulk", "Rhat", "MCSE", "all"), several.ok = TRUE ) if ("all" %in% diagnostic) { diagnostic <- c("ESS_tail", "ESS_bulk", "Rhat", "MCSE") } # ESS: use tail ESS by default, with optional bulk ESS if ("ESS" %in% diagnostic) { diagnostic[diagnostic == "ESS"] <- "ESS_tail" } 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 (any(c("ESS_tail", "ESS_bulk") %in% diagnostic)) { ess_data <- effective_sample(posterior, effects = effects, parameters = parameters) if ("ESS_tail" %in% diagnostic && "ESS_tail" %in% names(ess_data)) { # fmt: skip diagnostic_df$ESS_tail <- stats::setNames(ess_data$ESS_tail, ess_data$Parameter)[diagnostic_df$Parameter] } if ("ESS_bulk" %in% diagnostic && "ESS_bulk" %in% names(ess_data)) { # fmt: skip diagnostic_df$ESS_bulk <- stats::setNames(ess_data$ESS_bulk, ess_data$Parameter)[diagnostic_df$Parameter] } } if ("MCSE" %in% diagnostic) { diagnostic_df$MCSE <- mcse(posterior, effects = effects, centrality = centrality)$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.CmdStanFit <- function( posterior, diagnostic = "all", parameters = NULL, ... ) { if ("all" %in% diagnostic) { diagnostic <- c("ESS", "Rhat", "MCSE") } insight::check_if_installed("posterior") insight::check_if_installed("cmdstanr") pars <- insight::find_parameters(posterior, flatten = TRUE) if (!is.null(parameters)) { pars <- pars[!grepl(parameters, pars)] } draws <- posterior$draws(format = "draws_df", variables = pars) out <- posterior::summarize_draws( draws, posterior::default_convergence_measures(), MCSE = posterior::mcse_mean ) out <- datawizard::data_rename( as.data.frame(out), c( Parameter = "variable", ESS = "ess_bulk", ESS_tail = "ess_tail", Rhat = "rhat" ) ) out[, c("Parameter", diagnostic), drop = FALSE] } #' @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.R0000644000176200001440000003041615203314503014017 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 #' #' @inheritSection hdi Model components #' #' @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 #' @rdname p_map #' @inheritParams p_direction p_map.data.frame <- function(x, null = 0, precision = 2^10, method = "kernel", rvar_col = NULL, ...) { x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::p_map cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(x)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x)) } 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, ...) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_map.emm_list <- p_map.emmGrid #' @export p_map.slopes <- function(x, null = 0, precision = 2^10, method = "kernel", ...) { xrvar <- .get_marginaleffects_draws(x) out <- p_map(xrvar, null = null, precision = precision, method = method, ...) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_map.comparisons <- p_map.slopes #' @export p_map.predictions <- p_map.slopes #' @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 = "all", parameters = NULL, ...) { 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 = "fixed", parameters = NULL, ...) { 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 } #' @export p_map.stanreg <- function(x, null = 0, precision = 2^10, method = "kernel", effects = "fixed", component = "location", parameters = NULL, ...) { cleaned_parameters <- .get_cleaned_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.CmdStanFit <- 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 = "fixed", component = "conditional", parameters = NULL, ...) { cleaned_parameters <- .get_cleaned_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.R0000644000176200001440000003703315203314503015666 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, which can have following possible values: #' - `"default"`, in which case the range is set to `0.1` if input is a vector, #' and based on [`rope_range()`] if a (Bayesian) model is provided. #' - a single numeric value (e.g., 0.1), which is used as range around zero #' (i.e. the threshold range is set to -0.1 and 0.1, i.e. reflects a symmetric #' interval) #' - a numeric vector of length two (e.g., `c(-0.2, 0.1)`), useful for #' asymmetric intervals #' - a list of numeric vectors, where each vector corresponds to a parameter #' - a list of *named* numeric vectors, where names correspond to parameter #' names. In this case, all parameters that have no matching name in `threshold` #' will be set to `"default"`. #' @inheritParams rope #' @inheritParams hdi #' #' @inheritSection hdi Model components #' #' @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) #' # multiple thresholds - asymmetric, symmetric, default #' p_significance(model, threshold = list(c(-10, 5), 0.2, "default")) #' # named thresholds #' p_significance(model, threshold = list(wt = 0.2, `(Intercept)` = c(-10, 5))) #' } #' @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 #' @rdname p_significance #' @inheritParams p_direction p_significance.data.frame <- function(x, threshold = "default", rvar_col = NULL, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::p_significance cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x)) } threshold <- .select_threshold_ps(threshold = threshold, params = x) x <- .select_nums(x) if (ncol(x) == 1) { ps <- .p_significance(x[, 1], threshold = threshold, ...) } else if (is.list(threshold)) { # check if list of values contains only valid values threshold <- .check_list_range(threshold, x, larger_two = TRUE) # apply thresholds to each column ps <- mapply( function(p, thres) { .p_significance( p, threshold = thres ) }, x, threshold, SIMPLIFY = FALSE ) } 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 = "all", ...) { 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, ...) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_significance.emm_list <- p_significance.emmGrid #' @export p_significance.slopes <- function(x, threshold = "default", ...) { xrvar <- .get_marginaleffects_draws(x) out <- p_significance(xrvar, threshold = threshold, ...) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_significance.comparisons <- p_significance.slopes #' @export p_significance.predictions <- p_significance.slopes #' @export p_significance.stanreg <- function(x, threshold = "default", effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ...) { params <- insight::get_parameters( x, effects = effects, component = component, parameters = parameters ) threshold <- .select_threshold_ps( model = x, threshold = threshold, params = params, verbose = verbose ) result <- p_significance(params, threshold = threshold) cleaned_parameters <- .get_cleaned_parameters(x, ...) out <- .prepare_output(result, 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(result) out } #' @export p_significance.stanfit <- p_significance.stanreg #' @export p_significance.CmdStanFit <- p_significance.stanreg #' @export p_significance.blavaan <- p_significance.stanreg #' @rdname p_significance #' @export p_significance.brmsfit <- function(x, threshold = "default", effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ...) { params <- insight::get_parameters( x, effects = effects, component = component, parameters = parameters, ... ) threshold <- .select_threshold_ps( model = x, threshold = threshold, params = params, verbose = verbose ) result <- p_significance(params, threshold = threshold) cleaned_parameters <- .get_cleaned_parameters(x, ...) out <- .prepare_output(result, 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(result) out } .p_significance <- function(x, threshold, ...) { if (length(threshold) == 1) { psig <- max( c( length(x[x > abs(threshold)]) / length(x), # ps positive length(x[x < -abs(threshold)]) / length(x) # ps negative ) ) } else { psig <- max( c( length(x[x > threshold[2]]) / length(x), # ps positive length(x[x < threshold[1]]) / length(x) # ps negative ) ) } psig } # methods --------------------------- #' @rdname as.numeric.p_direction #' @export as.numeric.p_significance <- function(x, ...) { if (inherits(x, "data.frame")) { as.numeric(as.vector(x$ps)) } else { 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", params = NULL, verbose = TRUE) { if (is.list(threshold)) { # if we have named elements, complete list if (!is.null(params)) { named_threshold <- names(threshold) if (!is.null(named_threshold)) { # find out which name belongs to which parameter pos <- match(named_threshold, colnames(params)) # if not all element names were found, error if (anyNA(pos)) { insight::format_error(paste( "Not all elements of `threshold` were found in the parameters. Please check following names:", toString(named_threshold[is.na(pos)]) )) } # now "fill" non-specified elements with "default" out <- as.list(rep("default", ncol(params))) out[pos] <- threshold # overwrite former threshold threshold <- out } } lapply(threshold, function(i) { out <- .select_threshold_list(model = model, threshold = i, verbose = verbose) if (length(out) == 1) { out <- c(-1 * abs(out), abs(out)) } out }) } else { .select_threshold_list(model = model, threshold = threshold, verbose = verbose) } } #' @keywords internal .select_threshold_list <- function(model = NULL, threshold = "default", verbose = TRUE) { # If default if (all(threshold == "default")) { if (is.null(model)) { threshold <- 0.1 } else { threshold <- rope_range(model, verbose = verbose)[2] } } else if (!is.list(threshold) && (!all(is.numeric(threshold)) || length(threshold) > 2)) { insight::format_error( "`threshold` should be one of the following values:", "- \"default\", in which case the threshold is based on `rope_range()`", "- a single numeric value (e.g., 0.1), which is used as range around zero (i.e. the threshold range is set to -0.1 and 0.1)", # nolint "- a numeric vector of length two (e.g., `c(-0.2, 0.1)`)" ) } threshold } #' @keywords internal .check_list_range <- function(range, params, larger_two = FALSE) { # if we have named elements, complete list named_range <- names(range) if (!is.null(named_range)) { # find out which name belongs to which parameter pos <- match(named_range, colnames(params)) # if not all element names were found, error if (anyNA(pos)) { insight::format_error(paste( "Not all elements of `range` were found in the parameters. Please check following names:", toString(named_range[is.na(pos)]) )) } # now "fill" non-specified elements with "default" out <- as.list(rep("default", ncol(params))) out[pos] <- range # overwrite former range range <- out } if (length(range) != ncol(params)) { insight::format_error("Length of `range` (i.e. number of ROPE limits) should match the number of parameters.") } # check if list of values contains only valid values checks <- vapply(range, function(r) { if (larger_two) { !all(r == "default") || !all(is.numeric(r)) || length(r) > 2 } else { !all(r == "default") || !all(is.numeric(r)) || length(r) != 2 } }, logical(1)) if (!all(checks)) { insight::format_error("`range` should be 'default' or a vector of 2 numeric values (e.g., c(-0.1, 0.1)).") } range } bayestestR/R/print_html.R0000644000176200001440000001253215203314503015102 0ustar liggesusers#' @rdname display.describe_posterior #' @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, ...) { # check if we have multiple ROPE values if (insight::n_unique(x$ROPE_low) > 1) { caption <- "Proportion of samples inside the ROPE" } else { 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, ...) { threshold <- attributes(x)$threshold if (is.list(threshold)) { caption <- "Practical Significance" out <- as.data.frame(do.call(rbind, threshold)) colnames(out) <- c("ROPE_low", "ROPE_high") x$ROPE_low <- out$ROPE_low x$ROPE_high <- out$ROPE_high ci_string <- "ROPE" } else { caption <- sprintf( "Practical Significance (threshold: %s)", insight::format_value(attributes(x)$threshold, digits = digits) ) ci_string <- NULL } .print_html_default( x = x, digits = digits, caption = caption, ci_string = ci_string, ... ) } #' @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 = FALSE, caption = "Bayes Factors for Model Comparison", ... ) { .print_bf_html_default( x = x, digits = digits, log = log, show_names = show_names, caption = caption, align = "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 = "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 = .check_format_backend(...), ...) } # 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 = .check_format_backend(...), ... ) } .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 = .check_format_backend(...), ... ) } bayestestR/R/utils_check_collinearity.R0000644000176200001440000000540115203314503017772 0ustar liggesusers#' @keywords internal .check_multicollinearity <- function( model, method = "equivalence_test", threshold = 0.7, ... ) { if (inherits(model, "CmdStanFit")) { return() } 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.R0000644000176200001440000002150515203314503015372 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 #' #' @inheritSection hdi Model components #' #' @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", verbose = TRUE, ...) { out <- map_estimate( data.frame(x = x), precision, method = method, verbose = verbose, ... ) attr(out, "data") <- x out } .map_estimate <- function(x, precision = 2^10, method = "kernel", verbose = TRUE, ...) { # sanity check - if we have only one unique value (a vector of constant values) # density estimation doesn't work if (insight::n_unique(x) == 1) { if (verbose) { insight::format_alert("Data is singular, MAP estimate equals the unique value of the data.") } out <- stats::na.omit(x)[1] attr(out, "MAP_density") <- 1 } else { d <- try(estimate_density(x, precision = precision, method = method, ...), silent = TRUE) if (inherits(d, "try-error")) { if (verbose) { msg <- "Could not calculate MAP estimate." if (grepl("too sparse", d, fixed = TRUE)) { msg <- paste(msg, "The provided data is probably too sparse to calculate the density.") } insight::format_alert(msg) } return(NA) } 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, verbose = TRUE, ...) { l <- sapply( x, .map_estimate, precision = precision, method = method, verbose = verbose, 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 } #' @export map_estimate.stanreg <- function(x, precision = 2^10, method = "kernel", effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ...) { .map_estimate_models( x = insight::get_parameters( x, effects = effects, component = component, parameters = parameters ), precision = precision, method = method, verbose = verbose, ... ) } #' @export map_estimate.stanfit <- map_estimate.stanreg #' @export map_estimate.CmdStanFit <- 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 = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ...) { .map_estimate_models( x = insight::get_parameters( x, effects = effects, component = component, parameters = parameters ), precision = precision, method = method, verbose = verbose, ... ) } #' @rdname map_estimate #' @inheritParams p_direction #' @export map_estimate.data.frame <- function(x, precision = 2^10, method = "kernel", rvar_col = NULL, verbose = TRUE, ...) { x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::map_estimate cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(x)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x)) } .map_estimate_models(x, precision = precision, method = method, verbose = verbose, ...) } #' @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", ...) { xdf <- insight::get_parameters(x) out <- .map_estimate_models(xdf, precision = precision, method = method, ...) .append_datagrid(out, x) } #' @export map_estimate.emm_list <- map_estimate.emmGrid #' @export map_estimate.slopes <- function(x, precision = 2^10, method = "kernel", ...) { xrvar <- .get_marginaleffects_draws(x) out <- map_estimate(xrvar, precision = precision, method = method, ...) .append_datagrid(out, x) } #' @export map_estimate.comparisons <- map_estimate.slopes #' @export map_estimate.predictions <- map_estimate.slopes #' @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.R0000644000176200001440000002525215203314503013340 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*. #' \cr\cr #' \strong{For more info, 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. #' #' @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_methods Prior and posterior considerations #' #' @inheritSection bayesfactor_parameters Obtaining prior samples #' #' @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 = "fixed", component = "location", parameters = NULL, ... ) { cleaned_parameters <- .get_cleaned_parameters(posterior, ...) 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 } #' @export si.brmsfit <- si.stanreg #' @export si.blavaan <- si.stanreg #' @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, ... ) out <- .append_datagrid(out, posterior, long = length(BF) > 1L) attr(out, "ci_method") <- "SI" attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior)) out } #' @export si.emm_list <- si.emmGrid #' @export si.slopes <- si.emmGrid #' @export si.comparisons <- si.emmGrid #' @export si.predictions <- si.emmGrid #' @export si.stanfit <- function( posterior, prior = NULL, BF = 1, verbose = TRUE, effects = "fixed", ... ) { out <- si( insight::get_parameters(posterior, effects = effects, verbose = verbose), 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 #' @inheritParams p_direction #' @export si.data.frame <- function( posterior, prior = NULL, BF = 1, rvar_col = NULL, verbose = TRUE, ... ) { x_rvar <- .possibly_extract_rvar_col(posterior, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::si cl$posterior <- x_rvar cl$rvar_col <- NULL prior_rvar <- .possibly_extract_rvar_col(posterior, prior) if (length(prior_rvar) > 0L) { cl$prior <- prior_rvar } out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(posterior)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, posterior, long = length(BF) > 1L)) } 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 = if (!is.null(prior)) .posterior_draws_to_df(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, ...) } 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, log = TRUE) d_posterior <- logspline::dlogspline(x_axis, f_posterior, log = TRUE) relative_d <- d_posterior - d_prior crit <- relative_d >= log(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.R0000644000176200001440000006074615203314503013701 0ustar liggesusers#' Region of Practical Equivalence (ROPE) Analysis #' #' Compute the proportion of the CI (default to the 95% ETI) 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. For models #' with one response, `range` can be: #' #' - a vector of length two (e.g., `c(-0.1, 0.1)`), #' - a list of numeric vector of the same length as numbers of parameters (see #' 'Examples'). #' - a list of *named* numeric vectors, where names correspond to parameter #' names. In this case, all parameters that have no matching name in `range` #' will be set to `"default"`. #' #' In multivariate models, `range` should be a list with another list (one for #' each response variable) of numeric vectors . 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()`] is used. See 'Examples'. #' @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()`]. #' @param complement Should the probabilities above/below the ROPE (the #' _complementary_ probabilities) be returned as well? See #' [equivalence_test()] as well. #' #' @inheritParams hdi #' #' @inheritSection hdi Model components #' #' @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 [HDI][hdi] that #' falls within the ROPE as an index for "null-hypothesis" testing (as #' understood under the Bayesian framework, see [`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 all(insight::check_if_installed(c("rstanarm", "emmeans", "brms", "BayesFactor"), quietly = TRUE)) #' 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{ #' model <- suppressWarnings( #' rstanarm::stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) #' ) #' rope(model) #' rope(model, ci = c(0.90, 0.95)) #' #' # multiple ROPE ranges #' rope(model, range = list(c(-10, 5), c(-0.2, 0.2), "default")) #' #' # named ROPE ranges #' rope(model, range = list(gear = c(-3, 2), wt = c(-0.2, 0.2))) #' #' rope(emmeans::emtrends(model, ~1, "wt"), ci = c(0.90, 0.95)) #' #' model <- brms::brm(mpg ~ wt + cyl, data = mtcars, refresh = 0) #' rope(model) #' rope(model, ci = c(0.90, 0.95)) #' #' model <- brms::brm( #' brms::bf(brms::mvbind(mpg, disp) ~ wt + cyl) + brms::set_rescor(rescor = TRUE), #' data = mtcars, #' refresh = 0 #' ) #' rope(model) #' rope(model, ci = c(0.90, 0.95)) #' #' # different ROPE ranges for model parameters. For each response, a named #' # list (with the name of the response variable) is required as list-element #' # for the `range` argument. #' rope( #' model, #' range = list( #' mpg = list(b_mpg_wt = c(-1, 1), b_mpg_cyl = c(-2, 2)), #' disp = list(b_disp_wt = c(-5, 5), b_disp_cyl = c(-4, 4)) #' ) #' ) #' #' bf <- BayesFactor::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", complement = FALSE, 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, complement = complement, 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) { iv <- intersect( colnames(out), c("ROPE_Percentage", "Superiority_Percentage", "Inferiority_Percentage") ) out[iv] <- lapply(out[iv], as.numeric) } # 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", complement = FALSE, 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, complement = complement, 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, complement = complement, verbose = verbose, ... ) } out } #' @export #' @rdname rope #' @inheritParams p_direction rope.data.frame <- function( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, rvar_col = NULL, verbose = TRUE, ... ) { obj_name <- insight::safe_deparse_symbol(substitute(x)) x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::rope cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x)) } out <- .prepare_rope_df(x, range, ci, ci_method, complement, 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") <- obj_name class(dat) <- c("rope", "see_rope", "data.frame") dat } #' @export rope.draws <- function( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, verbose = TRUE, ... ) { rope( .posterior_draws_to_df(x), range = range, ci = ci, ci_method = ci_method, complement = complement, verbose = verbose, ... ) } #' @export rope.rvar <- rope.draws #' @export rope.emmGrid <- function( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, verbose = TRUE, ... ) { xdf <- insight::get_parameters(x, verbose = verbose) dat <- rope( xdf, range = range, ci = ci, ci_method = ci_method, complement = complement, verbose = verbose, ... ) dat <- .append_datagrid(dat, x) attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export rope.emm_list <- rope.emmGrid #' @export rope.slopes <- function( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, verbose = TRUE, ... ) { xrvar <- .get_marginaleffects_draws(x) dat <- rope( xrvar, range = range, ci = ci, ci_method = ci_method, complement = complement, verbose = verbose, ... ) dat <- .append_datagrid(dat, x) attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export rope.comparisons <- rope.slopes #' @export rope.predictions <- rope.slopes #' @export rope.BFBayesFactor <- function( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, verbose = TRUE, ... ) { if (all(range == "default")) { range <- rope_range(x, verbose = verbose) } out <- rope( insight::get_parameters(x, verbose = verbose), range = range, ci = ci, ci_method = ci_method, complement = complement, 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", complement = FALSE, 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, complement = complement, 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", complement = FALSE, verbose = TRUE, ... ) { out <- rope( as.data.frame(x), range = range, ci = ci, ci_method = ci_method, complement = complement, 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", complement = FALSE, verbose = TRUE, ... ) { out <- rope( insight::get_parameters(x, verbose = verbose), range = range, ci = ci, ci_method = ci_method, complement = complement, 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 #' @rdname rope #' @export rope.stanreg <- function( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ... ) { if (all(range == "default")) { range <- rope_range(x, verbose = verbose) } else if (!is.list(range) && (!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, verbose = verbose ), range = range, ci = ci, ci_method = ci_method, complement = complement, verbose = verbose, ... ) out <- .prepare_output( rope_data, .get_cleaned_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.CmdStanFit <- rope.stanreg #' @export rope.blavaan <- rope.stanreg #' @rdname rope #' @export rope.brmsfit <- function( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ... ) { # 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 with multiple lists (one for each response) of named numeric vectors with length 2." ) } } else if (!is.list(range) && (!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, verbose = verbose, ... ), range = range[[dv_item]], ci = ci, ci_method = ci_method, complement = complement, 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, .get_cleaned_parameters(x, ...), is_brms_mv = TRUE ) } else { rope_data <- rope( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, verbose = verbose ), range = range, ci = ci, ci_method = ci_method, complement = complement, verbose = verbose, ... ) out <- .prepare_output(rope_data, .get_cleaned_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", complement = FALSE, effects = "fixed", parameters = NULL, verbose = TRUE, ... ) { if (all(range == "default")) { range <- rope_range(x, verbose = verbose) } else if (!is.list(range) && (!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_list <- lapply(c("fixed", "random"), function(.x) { parms <- insight::get_parameters( x, effects = .x, parameters = parameters, verbose = verbose ) getropedata <- .prepare_rope_df(parms, range, ci, ci_method, complement, 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(rope_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(rope_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", complement = FALSE, parameters = NULL, verbose = TRUE, ... ) { if (all(range == "default")) { range <- rope_range(x, verbose = verbose) } else if (!is.list(range) && (!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, verbose = verbose) getropedata <- .prepare_rope_df(parms, range, ci, ci_method, complement, 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 } # helper ------------------------------------------------------------------- #' @keywords internal .rope <- function( x, range = c(-0.1, 0.1), ci = 0.95, ci_method = "ETI", complement = FALSE, verbose = TRUE ) { ci_bounds <- ci(x, ci = ci, method = ci_method, verbose = verbose) if (anyNA(ci_bounds)) { inferiority_percentage <- superiority_percentage <- rope_percentage <- NA } else { HDI_area <- x[x >= ci_bounds$CI_low & x <= ci_bounds$CI_high] rope_percentage <- mean(HDI_area >= min(range) & HDI_area <= max(range)) superiority_percentage <- mean(HDI_area > max(range)) inferiority_percentage <- mean(HDI_area < min(range)) } rope <- data.frame( CI = ci, ROPE_low = range[1], ROPE_high = range[2], ROPE_Percentage = rope_percentage ) if (isTRUE(complement)) { rope[["Superiority_Percentage"]] <- superiority_percentage rope[["Inferiority_Percentage"]] <- inferiority_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 } #' @keywords internal .prepare_rope_df <- function(parms, range, ci, ci_method, complement, verbose) { if (is.list(range)) { # check if list of values contains only valid values range <- .check_list_range(range, parms) # apply thresholds to each column tmp <- mapply( function(p, r) { rope( p, range = r, ci = ci, ci_method = ci_method, complement = complement, verbose = verbose ) }, parms, range, SIMPLIFY = FALSE ) } else { tmp <- sapply( parms, rope, range = range, ci = ci, ci_method = ci_method, complement = complement, 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.R0000644000176200001440000002454315203314503017461 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, 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). #' #' ## Additional methods #' The resulting output is supported by the following methods: #' #' - `as.matrix()`: Extract a full matrix of (log-)Bayes factors between all #' models (using the transitivity of Bayes factors). #' - `as.logical()`: Extract boolean vectors indicating which (prior/posterior) #' samples are included in the hypothesized restriction. #' - `as.numeric()`: Extract the (possibly log-)Bayes factor values. #' #' See examples and [bayesfactor_methods]. #' #' @inheritSection bayesfactor_parameters Obtaining prior samples #' #' @inheritSection bayesfactor_methods Transitivity of Bayes factors #' #' @inheritSection bayesfactor_methods 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)) #' #' # See the matrix of BFs #' as.matrix(b) #' #' 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/. #' #' @family Bayes factors #' #' @export bayesfactor_restricted <- function(posterior, ...) { 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 = "fixed", component = "conditional", ... ) { 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 #' @export bayesfactor_restricted.CmdStanFit <- bayesfactor_restricted.stanreg #' @export bayesfactor_restricted.stanfit <- 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 ) } #' @rdname bayesfactor_restricted #' @export bayesfactor_restricted.matrix <- function( posterior, hypothesis, prior = NULL, verbose = TRUE, ... ) { if (is.null(prior)) { prior <- posterior insight::format_warning( "Prior not specified! ", "Please specify priors (with column names matching 'posterior')", " to get meaningful results." ) } if (is.null(colnames(posterior)) || is.null(colnames(prior))) { insight::format_error("Posterior / Prior must have column names.") } bayesfactor_restricted.data.frame( posterior = as.data.frame(posterior), prior = as.data.frame(prior), hypothesis = hypothesis ) } #' @export bayesfactor_restricted.emm_list <- bayesfactor_restricted.emmGrid #' @export bayesfactor_restricted.slopes <- bayesfactor_restricted.emmGrid #' @export bayesfactor_restricted.predictions <- bayesfactor_restricted.emmGrid #' @export bayesfactor_restricted.comparisons <- bayesfactor_restricted.emmGrid #' @export #' @rdname bayesfactor_restricted #' @inheritParams p_direction bayesfactor_restricted.data.frame <- function( posterior, hypothesis, prior = NULL, rvar_col = NULL, ... ) { x_rvar <- .possibly_extract_rvar_col(posterior, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::bayesfactor_restricted cl$posterior <- x_rvar cl$rvar_col <- NULL prior_rvar <- .possibly_extract_rvar_col(posterior, prior) if (length(prior_rvar) > 0L) { cl$prior <- prior_rvar } return(eval.parent(cl)) } 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( "bayestestRBF", "bayesfactor_restricted", class(res) )) res } #' @export bayesfactor_restricted.draws <- function(posterior, hypothesis, prior = NULL, ...) { bayesfactor_restricted( .posterior_draws_to_df(posterior), hypothesis = hypothesis, prior = if (!is.null(prior)) .posterior_draws_to_df(prior), ... ) } #' @export bayesfactor_restricted.rvar <- bayesfactor_restricted.draws bayestestR/R/mediation.R0000644000176200001440000003215215174322463014706 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 95% 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 #' **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", ... ) } #' @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, verbose = FALSE) 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.R0000644000176200001440000001466214747200255015063 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, or a frequentist #' regression model. #' @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, ...) { # sanity check - if no model found, return default if (is.null(x)) { return(c(-0.1, 0.1)) } 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.parameters_model <- function(x, verbose = TRUE, ...) { model <- .retrieve_model(x) rope_range.default(x = model, verbose = verbose, ...) } #' @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, no_recursion = TRUE) 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, no_recursion = TRUE) 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.R0000644000176200001440000003414215203314503016263 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 95% [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 #' #' @inheritSection hdi Model components #' #' @details Using the [ROPE][rope] and the [HDI][hdi], \cite{Kruschke (2018)} #' suggests using the percentage of the 95% #' 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 is 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). #' #' Some attention is required for finding suitable values for the ROPE limits #' (argument `range`). See 'Details' in [`rope_range()`] for further #' information. #' #' **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. 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}). #' #' `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 all(insight::check_if_installed(c("rstanarm", "brms", "emmeans", "BayesFactor", "see"), quietly = TRUE)) #' 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) #' # multiple ROPE ranges - asymmetric, symmetric, default #' equivalence_test(model, range = list(c(10, 40), c(-5, -4), "default")) #' # named ROPE ranges #' equivalence_test(model, range = list(wt = c(-5, -4), `(Intercept)` = c(10, 40))) #' #' # 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 #' @inheritParams p_direction #' @export equivalence_test.data.frame <- function( x, range = "default", ci = 0.95, rvar_col = NULL, verbose = TRUE, ... ) { obj_name <- insight::safe_deparse_symbol(substitute(x)) x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::equivalence_test cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x)) } # multiple ranges for the parameters - iterate over parameters and range if (is.list(range)) { # check if list of values contains only valid values range <- .check_list_range(range, x) # apply thresholds to each column l <- insight::compact_list(mapply( function(p, r) { equivalence_test( p, range = r, ci = ci, verbose = verbose ) }, x, range, SIMPLIFY = FALSE )) } else { 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") <- obj_name 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, verbose = verbose) out <- equivalence_test(xdf, range = range, ci = ci, verbose = verbose, ...) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export equivalence_test.emm_list <- equivalence_test.emmGrid #' @export equivalence_test.slopes <- function( x, range = "default", ci = 0.95, verbose = TRUE, ... ) { xrvar <- .get_marginaleffects_draws(x) out <- equivalence_test(xrvar, range = range, ci = ci, verbose = verbose, ...) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export equivalence_test.comparisons <- equivalence_test.slopes #' @export equivalence_test.predictions <- equivalence_test.slopes #' @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 (!is.list(range) && (!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 ) equivalence_test(params, range = range, ci = ci, verbose = verbose) } #' @export equivalence_test.stanreg <- function( x, range = "default", ci = 0.95, effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ... ) { out <- .equivalence_test_models( x, range, ci, effects, component, parameters, verbose ) out <- .prepare_output( out, .get_cleaned_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.CmdStanFit <- 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 = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ... ) { out <- .equivalence_test_models( x, range, ci, effects, component, parameters, verbose ) out <- .prepare_output( out, .get_cleaned_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 = "all", parameters = NULL, verbose = TRUE, ... ) { 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/sensitivity_to_prior.R0000644000176200001440000000707515024725704017251 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 will 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.R0000644000176200001440000004646515203314503016603 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. #' \cr\cr #' \strong{For more info, see [the Bayes factors vignette](https://easystats.github.io/bayestestR/articles/bayes_factors.html).} #' #' @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`. #' #' @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 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. #' #' ## Additional methods #' The resulting output is supported by the following methods: #' #' - `as.matrix()`: Extract a full matrix of (log-)Bayes factors between all #' models (using the transitivity of Bayes factors). #' - `update()`: subset and/or re-reference the Bayes factors to a different model. #' - `as.numeric()`: Extract the (possibly log-)Bayes factor values. #' #' See examples and [bayesfactor_methods]. #' #' @inheritSection bayesfactor_methods Prior and posterior considerations #' #' @inheritSection bayesfactor_methods Transitivity of Bayes factors #' #' @inheritSection bayesfactor_methods 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. #' \cr\cr #' For `as.matrix()` a square matrix of (log) Bayes factors, with rows as #' denominators and columns as numerators. #' #' @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} #' #' @seealso [bayesfactor_inclusion()] for testing predictors across Bayesian models. #' @family Bayes factors #' #' @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)) { return(NA_integer_) } if (is.null(alg$iterations)) { alg$iterations <- alg$sample } (alg$iterations - alg$warmup) * alg$chains }) if (verbose) { if (any(n_samps < 4e4, na.rm = TRUE)) { insight::format_warning( "Bayes factors might not be precise.", "For precise Bayes factors, sampling at least 40,000 posterior samples is recommended." ) } else if (any(is.na(n_samps))) { insight::format_alert( "Unable to determine the number of posterior samples.", "Bayes factors might not be precise." ) } } 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 <- inherits(mods[[1]], c("stanfit", "CmdStanFit")) } .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) if (all(!sapply(resps, is.null))) { 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.") } } else if (verbose) { insight::format_alert( "Unable to validate that all models were fit with 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) mforms[!nzchar(mforms)] <- names(mforms)[!nzchar(mforms)] 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.stanfit <- bayesfactor_models.stanreg #' @export bayesfactor_models.CmdStanFit <- 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") ) } # 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/}." ) } if (is.null(model_names)) { model_names <- rownames(res) } 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( "bayestestRBF", "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) { caption <- "Proportion of samples inside the ROPE" } else { 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_md_default(x = x, digits = digits, caption = caption, ci_string = "ROPE", ...) } #' @export print_md.p_significance <- function(x, digits = 2, ...) { threshold <- attributes(x)$threshold if (is.list(threshold)) { caption <- "Practical Significance" out <- as.data.frame(do.call(rbind, threshold)) colnames(out) <- c("ROPE_low", "ROPE_high") x$ROPE_low <- out$ROPE_low x$ROPE_high <- out$ROPE_high ci_string <- "ROPE" } else { caption <- sprintf( "Practical Significance (threshold: %s)", insight::format_value(attributes(x)$threshold, digits = digits) ) ci_string <- NULL } .print_md_default(x = x, digits = digits, caption = caption, ci_string = ci_string, ...) } #' @export print_md.bayestestR_hdi <- function( x, digits = 2, caption = "Highest Density Interval", ... ) { .print_md_default(x = x, digits = digits, caption = caption, ci_string = "HDI", ...) } #' @export print_md.bayestestR_eti <- function( x, digits = 2, caption = "Equal-Tailed Interval", ... ) { .print_md_default(x = x, digits = digits, caption = caption, ci_string = "ETI", ...) } #' @export print_md.bayestestR_si <- function(x, digits = 2, caption = "Support Interval", ...) { .print_md_default(x = x, digits = digits, caption = caption, ci_string = "SI", ...) } # special handling for bayes factors ------------------ #' @export print_md.bayesfactor_models <- function( x, digits = 3, log = FALSE, show_names = FALSE, caption = "Bayes Factors for Model Comparison", ... ) { .print_bf_md_default( x = x, digits = digits, log = log, show_names = show_names, caption = caption, align = "llr", ... ) } #' @export print_md.bayesfactor_inclusion <- function( x, digits = 3, log = FALSE, caption = "Inclusion Bayes Factors (Model Averaged)", ... ) { .print_bf_md_default( x = x, digits = digits, log = log, caption = caption, align = "lrrr", ... ) } #' @export print_md.bayesfactor_restricted <- function( x, digits = 3, log = FALSE, caption = "Bayes Factor (Order-Restriction)", ... ) { .print_bf_md_default(x = x, digits = digits, log = log, caption = caption, ...) } #' @export print_md.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 = "markdown", ... ) insight::export_table(formatted_table, format = "markdown") } # util --------------- .print_md_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 = "markdown", 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 = "markdown" ) } .print_bf_md_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 = "markdown", ... ) insight::export_table( formatted_table, align = align, caption = caption, format = "markdown" ) } bayestestR/R/zzz.R0000644000176200001440000000023414266336540013570 0ustar liggesusers.onAttach <- function(libname, pkgname) { if (format(Sys.time(), "%m%d") == "0504") { packageStartupMessage("May the fourth be with you!") } } bayestestR/R/convert_bayesian_to_frequentist.R0000644000176200001440000001531614650436664021435 0ustar liggesusers#' Convert (refit) a Bayesian model to frequentist #' #' Refit Bayesian model as frequentist. Can be useful for comparisons. #' #' @param model A Bayesian model. #' @param data Data used by the model. If `NULL`, will try to extract it #' from the model. #' @param REML For mixed effects, should models be estimated using #' restricted maximum likelihood (REML) (`TRUE`, default) or maximum #' likelihood (`FALSE`)? #' @examplesIf require("rstanarm") #' \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) #' } #' #' @export convert_bayesian_as_frequentist <- function(model, data = NULL, REML = TRUE) { if (is.null(data)) { data <- insight::get_data(model) } info <- insight::model_info(model, verbose = FALSE) model_formula <- insight::find_formula(model) model_family <- insight::get_family(model) # fix exception: The 0 + Intercept syntax in brms can be used to facilitate # prior specification for the intercept, but but it leads to issues where it # wrongly can be believed that Intercept is a variable and not a special term. f_string <- insight::safe_deparse(model_formula$conditional) if (grepl("0 + Intercept", f_string, fixed = TRUE)) { model_formula$conditional <- stats::as.formula(gsub("0 + Intercept", "1", f_string, fixed = TRUE)) } if (inherits(model_family, "brmsfamily")) { insight::check_if_installed("glmmTMB") # exception: ordbetareg() if ("custom" %in% model_family$family && all(model_family$name == "ord_beta_reg")) { model_family <- glmmTMB::ordbeta() } else { # not all families return proper objects from "get", so we capture # some families via switch here... model_family <- .safe(switch(model_family$family, beta = glmmTMB::beta_family(link = model_family$link), beta_binomial = glmmTMB::betabinomial(link = model_family$link), negbinomial = glmmTMB::nbinom1(link = model_family$link), lognormal = glmmTMB::lognormal(link = model_family$link), student = glmmTMB::t_family(link = model_family$link), get(model_family$family)(link = model_family$link) )) } } # if family could not be identified, stop here if (is.null(model_family)) { insight::format_error("Model could not be automatically converted to frequentist model.") } # first attempt freq <- tryCatch(.convert_bayesian_as_frequentist( info = info, formula = model_formula, data = data, family = model_family, REML = REML ), error = function(e) e) if (inherits(freq, "error")) { # try again to extract family, using generic approach model_family <- get(model_family$family)(link = model_family$link) freq <- .convert_bayesian_as_frequentist( info = info, formula = model_formula, data = data, family = model_family, REML = REML ) } if (inherits(freq, "error")) { insight::format_error("Model could not be automatically converted to frequentist model.") } freq } # internal .convert_bayesian_as_frequentist <- function(info, formula, data, family, REML = TRUE) { # TODO: Check for # nonlinear formulas, # correlation structures, # weights, # offset, # subset, # knots, # meta-analysis if (info$is_dispersion || info$is_orderedbeta || info$is_beta || info$is_betabinomial || info$is_zero_inflated || info$is_zeroinf || info$is_hurdle || info$is_negbin) { # nolint insight::check_if_installed("glmmTMB") cond_formula <- .rebuild_cond_formula(formula) dispformula <- formula$dispersion if (is.null(dispformula)) dispformula <- formula$sigma if (is.null(dispformula)) dispformula <- ~1 ziformula <- formula$zero_inflated if (is.null(ziformula)) ziformula <- formula$zi if (is.null(ziformula)) ziformula <- ~0 freq <- tryCatch( glmmTMB::glmmTMB( formula = cond_formula, ziformula = ziformula, dispformula = dispformula, family = family, data = data, REML = REML ), error = function(e) e ) } else if (info$is_gam) { insight::check_if_installed("gamm4") freq <- tryCatch( gamm4::gamm4( formula = formula$conditional, random = formula$random, family = family, data = data ), error = function(e) e ) } else if (info$is_mixed) { insight::check_if_installed("lme4") insight::check_if_installed("glmmTMB") cond_formula <- .rebuild_cond_formula(formula) if (info$is_linear) { freq <- tryCatch( lme4::lmer( formula = cond_formula, data = data ), error = function(e) e ) } else { ## TODO: check if beta/Gamma are correctly captured freq <- tryCatch( lme4::glmer( formula = cond_formula, family = family, data = data ), error = function(e) e ) if (inherits(freq, "error")) { freq <- tryCatch( glmmTMB::glmmTMB( formula = cond_formula, family = family, data = data ), error = function(e) e ) } } } else if (info$is_linear) { freq <- stats::lm(formula$conditional, data = data) } else { freq <- stats::glm(formula$conditional, data = data, family = family) } freq } .rebuild_cond_formula <- function(formula) { if (is.null(formula$random)) { return(formula$conditional) } if (is.list(formula$random)) { random_formula <- paste( lapply( formula$random, function(x) { paste0("(", as.character(x)[-1], ")") } ), collapse = " + " ) } else { random_formula <- paste0("(", as.character(formula$random)[-1], ")") } fixed_formula <- paste(as.character(formula$conditional)[c(2, 1, 3)], collapse = " ") stats::as.formula(paste(fixed_formula, random_formula, sep = " + ")) } #' @rdname convert_bayesian_as_frequentist #' @export bayesian_as_frequentist <- convert_bayesian_as_frequentist bayestestR/R/utils_print_data_frame.R0000644000176200001440000000556314776266465017502 0ustar liggesusers.print_data_frame <- function(x, digits) { out <- list(x) names(out) <- "fixed" if (all(c("Effects", "Component") %in% colnames(x))) { x$split <- sprintf("%s_%s", x$Effects, x$Component) } else if ("Effects" %in% colnames(x)) { colnames(x)[which(colnames(x) == "Effects")] <- "split" } else if ("Component" %in% colnames(x)) { colnames(x)[which(colnames(x) == "Component")] <- "split" } if ("split" %in% colnames(x)) { if (anyNA(x$split)) { x$split[is.na(x$split)] <- "{other}" } out <- lapply( split(x, f = x$split), datawizard::data_remove, select = c("split", "Component", "Effects"), verbose = FALSE ) } for (i in names(out)) { header <- switch(i, conditional = , fixed_conditional = , fixed = "# Fixed Effects (Conditional Model)", fixed_sigma = "# Sigma (fixed effects)", sigma = "# Sigma (fixed effects)", zi = , zero_inflated = , fixed_zero_inflated = , fixed_zi = "# Fixed Effects (Zero-Inflated Model)", random = , random_conditional = "# Random Effects (Conditional Model)", random_zero_inflated = , random_zi = "# Random Effects (Zero-Inflated Model)", smooth_sd = , fixed_smooth_sd = "# Smooth Terms", # blavaan latent = "# Latent Loading", residual = "# Residual Variance", intercept = "# Intercept", regression = "# Regression", # Default paste0("# ", i) ) if ("Parameter" %in% colnames(out[[i]])) { # clean parameters names out[[i]]$Parameter <- gsub("(b_|bs_|bsp_|bcs_)(?!zi_)(.*)", "\\2", out[[i]]$Parameter, perl = TRUE) out[[i]]$Parameter <- gsub("(b_zi_|bs_zi_|bsp_zi_|bcs_zi_)(.*)", "\\2", out[[i]]$Parameter, perl = TRUE) # clean random effect parameters names out[[i]]$Parameter <- gsub("r_(.*)\\.(.*)\\.", "\\1", out[[i]]$Parameter) out[[i]]$Parameter <- gsub("b\\[\\(Intercept\\) (.*)\\]", "\\1", out[[i]]$Parameter) out[[i]]$Parameter <- gsub("b\\[(.*) (.*)\\]", "\\2", out[[i]]$Parameter) # clean smooth terms out[[i]]$Parameter <- gsub("^smooth_sd\\[(.*)\\]", "\\1", out[[i]]$Parameter) out[[i]]$Parameter <- gsub("^sds_", "\\1", out[[i]]$Parameter) # SD out[[i]]$Parameter <- gsub( "(.*)(__Intercept|__zi_Intercept)(.*)", "\\1 (Intercept)\\3", gsub("^sd_(.*)", "SD \\1", out[[i]]$Parameter) ) # remove ".1" etc. suffix out[[i]]$Parameter <- gsub("(.*)(\\.)(\\d)$", "\\1 \\3", out[[i]]$Parameter) # remove "__zi" out[[i]]$Parameter <- gsub("__zi", "", out[[i]]$Parameter, fixed = TRUE) } if (length(out) > 1) { insight::print_color(header, "blue") cat("\n\n") } cat(insight::export_table(out[[i]], digits = digits)) cat("\n") } } bayestestR/R/as.list.R0000644000176200001440000000140214357736006014310 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.R0000644000176200001440000001655515203314503017320 0ustar liggesusers#' Inclusion Bayes Factors for testing predictors across Bayesian models #' \cr\cr #' The `bf_*` function is an alias of the main function. #' \cr\cr #' \strong{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}? #' #' ## 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 contain the main effect terms from which the interaction #' term is comprised. #' #' ## Additional methods #' The resulting output is supported by the following methods: #' #' - `as.numeric()`: Extract the (possibly log-)Bayes factor values. #' #' See [bayesfactor_methods]. #' #' @inheritSection bayesfactor_methods 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. #' @family Bayes factors #' #' @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("bayestestRBF", "bayesfactor_inclusion", class(df.effect)) attr(df.effect, "matched") <- match_models attr(df.effect, "priorOdds") <- prior_odds 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 <- lengths(effnames_b) > 1 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.R0000644000176200001440000003367715203314503015763 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 #' #' @inheritSection hdi Model components #' #' @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 #' @rdname point_estimate #' @inheritParams p_direction point_estimate.data.frame <- function(x, centrality = "all", dispersion = FALSE, threshold = 0.1, rvar_col = NULL, ...) { x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::point_estimate cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(x)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x)) } 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 = "conditional", ...) { 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, ...) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export point_estimate.emm_list <- point_estimate.emmGrid #' @export point_estimate.slopes <- function(x, centrality = "all", dispersion = FALSE, ...) { xrvar <- .get_marginaleffects_draws(x) out <- point_estimate(xrvar, centrality = centrality, dispersion = dispersion, ...) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export point_estimate.comparisons <- point_estimate.slopes #' @export point_estimate.predictions <- point_estimate.slopes #' @export point_estimate.stanreg <- function(x, centrality = "all", dispersion = FALSE, effects = "fixed", component = "location", parameters = NULL, ...) { cleaned_parameters <- .get_cleaned_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.CmdStanFit <- point_estimate.stanreg #' @export point_estimate.blavaan <- point_estimate.stanreg #' @rdname point_estimate #' @export point_estimate.brmsfit <- function(x, centrality = "all", dispersion = FALSE, effects = "fixed", component = "conditional", parameters = NULL, ...) { cleaned_parameters <- .get_cleaned_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 = "fixed", parameters = NULL, ...) { 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 } #' @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.R0000644000176200001440000000664314766532531016171 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. #' @inheritParams hdi #' #' @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 = "fixed", component = "location", parameters = NULL, verbose = TRUE, ...) { 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 #' @rdname simulate_prior #' @export simulate_prior.brmsfit <- function(model, n = 1000, effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ...) { 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.R0000644000176200001440000000645214766532531015741 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, 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)] # nolint 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"))] # nolint } 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.R0000644000176200001440000000702215204535252013656 0ustar liggesusers#' Monte-Carlo Standard Error (MCSE) #' #' This function returns the Monte Carlo Standard Error (MCSE). #' #' @param centrality The point-estimate (centrality index) for which to compute #' the MCSE. Can be `"median"` (default) or `"mean"`. To not break other #' functions like `describe_posterior()` or `diagnostic_posterior()`, all other #' values are silently converted to `"median"`. #' @param ... Additional arguments to be passed to or from methods. #' @inheritParams effective_sample #' #' @inheritSection hdi Model components #' #' @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 = "fixed", component = "conditional", parameters = NULL, centrality = "median", ... ) { insight::check_if_installed("posterior") # check arguments if ( is.null(centrality) || length(centrality) > 1 || !centrality %in% c("median", "mean") ) { centrality <- "median" } params <- insight::get_parameters( model, effects = effects, component = component, parameters = parameters ) mcse <- switch( centrality, median = vapply(params, posterior::mcse_median, numeric(1)), mean = vapply(params, posterior::mcse_mean, numeric(1)) ) data.frame( Parameter = colnames(params), MCSE = mcse, stringsAsFactors = FALSE, row.names = NULL ) } #' @rdname mcse #' @export mcse.stanreg <- function( model, effects = "fixed", component = "location", parameters = NULL, centrality = "median", ... ) { mcse.brmsfit(model, effects, component, parameters, centrality, ...) } #' @export mcse.stanfit <- mcse.stanreg #' @export mcse.blavaan <- function( model, effects = "fixed", component = "location", parameters = NULL, ... ) { 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)) } #' @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 ) } #' @export mcse.CmdStanFit <- function(model, ...) { diagnostic_posterior(model, diagnostic = "MCSE") } bayestestR/R/contr.equalprior.R0000644000176200001440000001573614747200255016254 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.R0000644000176200001440000000510714447216720016625 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.R0000644000176200001440000004541715203314503017457 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 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 #' `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; see details). The `bf_*` #' functions are aliases of the main functions. #' \cr \cr #' \strong{For more info, 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. #' \cr \cr #' Note that the `logspline` package is used for estimating densities and #' probabilities, and must be installed for the function to work. #' #' #' ## 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))`. #' #' #' ## Additional methods #' The resulting output is supported by the following methods: #' #' - `as.numeric()`: Extract the (possibly log-)Bayes factor values. #' #' See [bayesfactor_methods]. #' #' @inheritSection bayesfactor_methods Prior and posterior considerations #' #' @section Obtaining prior samples: #' #' It is important to provide the correct `prior` for meaningful results, #' to match the `posterior`-type input: #' #' - **A numeric vector** - `prior` should also be a _numeric vector_, representing the prior-distribution #' - **A data frame** - `prior` should also be a _data frame_, representing the prior-estimates, in matching column order. #' - If `rvar_col` is specified, `prior` should be _the name of an `rvar` column_ that represents the prior-estimates. #' - **Supported Bayesian model (`stanreg`, `brmsfit`, etc.)** #' - `prior` should be _a model an equivalent model with MCMC samples from the priors **only**_. See [unupdate()]. #' - If `prior` is set to `NULL`, [unupdate()] is called internally (not supported for `brmsfit_multiple` model). #' - **Output from a `{marginaleffects}` function** - `prior` should also be _an equivalent output_ from a `{marginaleffects}` function based on a prior-model #' (See [unupdate()]). #' - **Output from an `{emmeans}` function** #' - `prior` should also be _an equivalent output_ from an `{emmeans}` function based on a prior-model (See [unupdate()]). #' - `prior` can also be _the original (posterior) model_, in which case the function #' will try to "unupdate" the estimates (not supported if the estimates have undergone #' any transformations -- `"log"`, `"response"`, etc. -- or any `regrid`ing). #' #' @inheritSection bayesfactor_methods Interpreting Bayes Factors #' #' @inheritSection hdi Model components #' #' @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 #' #' @family Bayes factors #' #' @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, effects = "fixed", component = "conditional", parameters = NULL, ..., verbose = TRUE ) { cleaned_parameters <- .get_cleaned_parameters(posterior, ...) 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 } #' @export bayesfactor_parameters.brmsfit <- bayesfactor_parameters.stanreg #' @export bayesfactor_parameters.CmdStanFit <- bayesfactor_parameters.stanreg #' @export bayesfactor_parameters.stanfit <- bayesfactor_parameters.stanreg #' @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 out <- bayesfactor_parameters.data.frame( posterior = samps$posterior, prior = samps$prior, direction = direction, null = null, verbose = verbose, ... ) .append_datagrid(out, posterior) } #' @export bayesfactor_parameters.emm_list <- bayesfactor_parameters.emmGrid #' @export bayesfactor_parameters.slopes <- bayesfactor_parameters.emmGrid #' @export bayesfactor_parameters.predictions <- bayesfactor_parameters.emmGrid #' @export bayesfactor_parameters.comparisons <- bayesfactor_parameters.emmGrid #' @rdname bayesfactor_parameters #' @inheritParams p_direction #' @export bayesfactor_parameters.data.frame <- function( posterior, prior = NULL, direction = "two-sided", null = 0, rvar_col = NULL, ..., verbose = TRUE ) { x_rvar <- .possibly_extract_rvar_col(posterior, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::bayesfactor_parameters cl$posterior <- x_rvar cl$rvar_col <- NULL prior_rvar <- .possibly_extract_rvar_col(posterior, prior) if (length(prior_rvar) > 0L) { cl$prior <- prior_rvar } out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(posterior)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, posterior)) } # 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( "bayestestRBF", "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 = if (!is.null(prior)) .posterior_draws_to_df(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.R0000644000176200001440000000617715052400212015025 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( attr(x, "idvars"), "Parameter", "ROPE_Percentage", "Superiority_Percentage", "Inferiority_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 iv <- intersect(colnames(x), c("ROPE_Percentage", "Superiority_Percentage", "Inferiority_Percentage")) x[iv] <- lapply(x[iv], function(v) sprintf("%.*f %%", digits, v * 100)) colnames(x)[colnames(x) == "ROPE_Percentage"] <- "Inside ROPE" colnames(x)[colnames(x) == "Superiority_Percentage"] <- "Above ROPE" colnames(x)[colnames(x) == "Inferiority_Percentage"] <- "Below 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.R0000644000176200001440000000166214357736006016461 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.R0000644000176200001440000000252015203314503020470 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 } # .get_cleaned_parameters ------------------------------------------------- #' @keywords internal .get_cleaned_parameters <- function(x, ...) { dots <- list(...) if ("cleaned_parameters" %in% names(dots)) { return(dots$cleaned_parameters) } UseMethod(".get_cleaned_parameters") } #' @keywords internal .get_cleaned_parameters.default <- function(x, ...) { insight::clean_parameters(x) } #' @keywords internal .get_cleaned_parameters.stanfit <- function(x, ...) { NULL } .get_cleaned_parameters.CmdStanFit <- .get_cleaned_parameters.stanfit bayestestR/R/bayesfactor.R0000644000176200001440000000640314766532531015244 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") #' \dontrun{ #' library(bayestestR) #' #' prior <- distribution_normal(1000, mean = 0, sd = 1) #' posterior <- distribution_normal(1000, mean = 0.5, sd = 0.3) #' #' bayesfactor(posterior, prior = prior, verbose = FALSE) #' #' # 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 = "fixed", verbose = TRUE, denominator = 1, match_models = FALSE, prior_odds = NULL) { mods <- list(...) 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.R0000644000176200001440000003045715203314503016452 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 ) } .clean_priors_and_posteriors.slopes <- 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." ) } } posterior <- .get_marginaleffects_draws(posterior) prior <- .get_marginaleffects_draws(prior) list( posterior = posterior, prior = prior ) } .clean_priors_and_posteriors.predictions <- .clean_priors_and_posteriors.slopes .clean_priors_and_posteriors.comparisons <- .clean_priors_and_posteriors.slopes .clean_priors_and_posteriors.stanfit <- function(posterior, prior, verbose = TRUE, ...) { posterior <- insight::get_parameters(posterior) # Get Priors if (!is.null(prior)) { prior <- insight::get_parameters(prior) } list( posterior = posterior, prior = prior ) } .clean_priors_and_posteriors.CmdStanFit <- .clean_priors_and_posteriors.stanfit # 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]]) ) } # 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.R0000644000176200001440000001660315055047701014075 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 .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 <- .safe(get(obj_name, envir = parent.frame())) if (is.null(model)) { # second try, global env model <- .safe(get(obj_name, envir = globalenv())) } if (is.null(model)) { # last try model <- .dynGet(obj_name, ifnotfound = NULL) } } model } #' @keywords internal .dynGet <- function(x, ifnotfound = stop(gettextf("%s not found", sQuote(x)), domain = NA, call. = FALSE), 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 } #' @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 } #' Prepare output data frame for printing #' #' @description #' This is an internal helper function to standardize and enrich the output of #' various `bayestestR` functions (like `ci()`, `hdi()`, `rope()`, etc.). #' Its main purpose is to merge a data frame containing analysis results #' (e.g., credible intervals) with a data frame of "cleaned" parameter #' information (from `insight::clean_parameters()`). #' #' This process adds human-readable parameter names and model component #' information (like fixed or random effects) to the output. It also includes #' special handling for complex models, such as multivariate models from #' `rstanarm` or `brms`, where response variables need to be parsed from #' parameter names. #' #' @param temp A data frame with estimation results, like CIs or point estimates. #' @param cleaned_parameters A data frame as returned by #' `insight::clean_parameters()`. #' @param is_stan_mv Logical, indicates if the model is a `stanmvreg` object. #' @param is_brms_mv Logical, indicates if the model is a `brms` multivariate #' model. #' #' @keywords internal #' @noRd .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") } } # safe add cleaned parameter names to a model object .add_clean_parameters_attribute <- function(params, model, ...) { cp <- tryCatch( { .get_cleaned_parameters(model, ...) }, error = function(e) { NULL } ) attr(params, "clean_parameters") <- cp params } #' @keywords internal .get_marginaleffects_draws <- function(object) { # errors and checks are handled by marginaleffects insight::check_if_installed("marginaleffects", minimum_version = "0.29.0") as.data.frame(marginaleffects::get_draws(object, shape = "DxP")) } #' @keywords internal .possibly_extract_rvar_col <- function(df, rvar_col) { if (missing(rvar_col) || is.null(rvar_col)) { return(NULL) } if (is.character(rvar_col) && length(rvar_col) == 1L && rvar_col %in% colnames(df) && inherits(df[[rvar_col]], "rvar")) { return(df[[rvar_col]]) } insight::format_error("The `rvar_col` argument must be a single, valid column name.") } bayestestR/R/utils_hdi_ci.R0000644000176200001440000000545315135612351015373 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, verbose = verbose) 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, verbose = verbose) 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, verbose = verbose) d <- .compute_interval_dataframe(fixed.data, ci, verbose, fun) list(result = d, data = fixed.data) } bayestestR/R/display.R0000644000176200001440000000663215055047701014403 0ustar liggesusers#' @title Print tables in different output formats #' @name display.describe_posterior #' #' @description Prints tables (i.e. data frame) in different output formats. #' #' @param object,x An object returned by one of the package's function, for #' example [`describe_posterior()`], [`point_estimate()`], or [`eti()`]. #' @param format String, indicating the output format. Can be `"markdown"` #' `"html"`, or `"tt"`. `format = "tt"` creates a `tinytable` object, which is #' either printed as markdown or HTML table, depending on the environment. See #' [`insight::export_table()`] for details. #' @param digits Integer, number of digits to round the table output. Defaults #' to 2. #' @param caption Character, caption for the table. If `NULL`, no caption is #' added. By default, a caption is created based on the object type. #' @param ... Arguments passed down to `print_html()` or `print_md()` (e.g., #' `digits`), or to `insight::export_table()`. #' #' @return If `format = "markdown"`, the return value will be a character #' vector in markdown-table format. If `format = "html"`, an object of #' class `gt_tbl`. If `format = "tt"`, an object of class `tinytable`. #' #' @details `display()` is useful when the table-output from functions, which is #' usually printed as formatted text-table to console, should be formatted for #' pretty table-rendering in markdown documents, or if knitted from rmarkdown #' to PDF or Word files. See #' [vignette](https://easystats.github.io/parameters/articles/model_parameters_formatting.html) #' for examples. #' #' @examplesIf all(insight::check_if_installed(c("tinytable", "gt"), quietly = TRUE)) #' \donttest{ #' d <- data.frame(replicate(4, rnorm(20))) #' result <- describe_posterior(d) #' #' # markdown format #' display(result) #' #' # gt HTML #' display(result, format = "html") #' #' # tinytable #' display(result, format = "tt") #' } #' @export display.describe_posterior <- function(object, format = "markdown", ...) { format <- .display_default_format(format) if (format %in% c("html", "tt")) { print_html(object, backend = format, ...) } else { print_md(object, ...) } } #' @export display.point_estimate <- display.describe_posterior #' @export display.map_estimate <- display.describe_posterior #' @export display.p_direction <- display.describe_posterior #' @export display.p_map <- display.describe_posterior #' @export display.p_rope <- display.describe_posterior #' @export display.p_significance <- display.describe_posterior #' @export display.bayestestR_hdi <- display.describe_posterior #' @export display.bayestestR_eti <- display.describe_posterior #' @export display.bayestestR_si <- display.describe_posterior #' @export display.bayesfactor_models <- display.describe_posterior #' @export display.bayesfactor_restricted <- display.describe_posterior #' @export display.bayesfactor_parameters <- display.describe_posterior #' @export display.bayesfactor_inclusion <- display.describe_posterior # we allow exporting HTML format based on "gt" or "tinytable" .check_format_backend <- function(...) { dots <- list(...) if (identical(dots$backend, "tt")) { "tt" } else { "html" } } .display_default_format <- function(format) { format <- getOption("easystats_display_format", format) insight::validate_argument(format, c("markdown", "html", "md", "tt")) } bayestestR/R/append_datagrid.R0000644000176200001440000000721315055047701016040 0ustar liggesusers#' @keywords internal .append_datagrid <- function(results, object, long = FALSE) { UseMethod(".append_datagrid", object = object) } #' @keywords internal .append_datagrid.emmGrid <- function(results, object, long = FALSE) { # results is assumed to be a data frame with "Parameter" column # object is an emmeans / marginaleffects that results is based on all_attrs <- attributes(results) # save attributes for later all_class <- class(results) # extract model info. if we have categorical, add "group" variable if (inherits(object, c("emmGrid", "emm_list"))) { model <- attributes(object)$model } else { insight::check_if_installed("marginaleffects", minimum_version = "0.29.0") model <- marginaleffects::components(object, "model") } if (!long && !is.null(model)) { m_info <- insight::model_info(model, response = 1, verbose = FALSE) # check if we have ordinal and alike if (!is.null(m_info)) { has_response_levels <- isTRUE( m_info$is_categorical | m_info$is_mixture | m_info$is_ordinal | m_info$is_multinomial | m_info$is_cumulative ) } else { has_response_levels <- FALSE } if ((has_response_levels || isTRUE(insight::is_multivariate(model))) && "group" %in% colnames(object)) { results <- .safe( cbind(data.frame(group = object$group), results), results ) } } datagrid <- insight::get_datagrid(object) grid_names <- colnames(datagrid) if (long || nrow(datagrid) < nrow(results)) { datagrid$Parameter <- unique(results$Parameter) results <- datawizard::data_merge(datagrid, results, by = "Parameter") results$Parameter <- NULL class(results) <- all_class } else { results[colnames(datagrid)] <- datagrid results$Parameter <- NULL results <- results[, c(grid_names, setdiff(colnames(results), grid_names)), drop = FALSE] # add back attributes most_attrs <- all_attrs[setdiff(names(all_attrs), names(attributes(datagrid)))] attributes(results)[names(most_attrs)] <- most_attrs } attr(results, "idvars") <- grid_names results } #' @keywords internal .append_datagrid.emm_list <- .append_datagrid.emmGrid #' @keywords internal .append_datagrid.slopes <- .append_datagrid.emmGrid #' @keywords internal .append_datagrid.predictions <- .append_datagrid.emmGrid #' @keywords internal .append_datagrid.comparisons <- .append_datagrid.emmGrid #' @keywords internal .append_datagrid.data.frame <- function(results, object, long = FALSE) { # results is assumed to be a data frame with "Parameter" column # object is a data frame with an rvar column that results is based on all_attrs <- attributes(results) # save attributes for later all_class <- class(results) is_rvar <- vapply(object, inherits, FUN.VALUE = logical(1), "rvar") grid_names <- colnames(object)[!is_rvar] datagrid <- data.frame(object[, grid_names, drop = FALSE]) if (long || nrow(datagrid) < nrow(results)) { datagrid$Parameter <- unique(results$Parameter) results <- datawizard::data_merge(datagrid, results, by = "Parameter") results$Parameter <- NULL class(results) <- all_class } else { results[grid_names] <- object[grid_names] results$Parameter <- NULL results <- results[, c(grid_names, setdiff(colnames(results), grid_names)), drop = FALSE] # add back attributes most_attrs <- all_attrs[setdiff(names(all_attrs), names(attributes(object)))] attributes(results)[names(most_attrs)] <- most_attrs } attr(results, "idvars") <- grid_names results } bayestestR/R/ci.R0000644000176200001440000002211615203314503013314 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 #' #' @inheritSection hdi Model components #' #' @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(rstanarm::stan_glm( #' mpg ~ wt, #' data = mtcars, chains = 2, iter = 200, refresh = 0 #' )) #' ci(model, method = "ETI", ci = c(0.80, 0.89, 0.95)) #' ci(model, method = "HDI", ci = c(0.80, 0.89, 0.95)) #' #' @examplesIf require("BayesFactor", quietly = TRUE) #' bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) #' ci(bf, method = "ETI") #' ci(bf, method = "HDI") #' #' @examplesIf require("emmeans", quietly = TRUE) && require("rstanarm", quietly = TRUE) #' model <- emmeans::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 = "fixed", component = "conditional", 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 #' @inheritParams p_direction #' @export ci.data.frame <- function( x, ci = 0.95, method = "ETI", BF = 1, rvar_col = NULL, verbose = TRUE, ... ) { x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::ci cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(x)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x, long = length(ci) > 1L)) } .ci_bayesian(x, ci = ci, method = method, verbose = verbose, BF = BF, ...) } #' @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_grid(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 } xdf <- insight::get_parameters(x) out <- ci(xdf, ci = ci, ...) out <- .append_datagrid(out, x, long = length(ci) > 1L) out } #' @export ci.emm_list <- ci.emmGrid #' @export ci.slopes <- function(x, ci = NULL, ...) { if (!.is_baysian_grid(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 } xrvar <- .get_marginaleffects_draws(x) out <- ci(xrvar, ci = ci, ...) out <- .append_datagrid(out, x, long = length(ci) > 1L) out } #' @export ci.comparisons <- ci.slopes #' @export ci.predictions <- ci.slopes #' @export ci.sim.merMod <- function( x, ci = 0.95, method = "ETI", effects = "fixed", parameters = NULL, verbose = TRUE, ... ) { .ci_bayesian( x, ci = ci, method = method, effects = effects, parameters = parameters, verbose = verbose, ... ) } #' @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, ... ) } #' @export ci.stanreg <- function( x, ci = 0.95, method = "ETI", effects = "fixed", component = "location", 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 = "fixed", component = "conditional", 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.CmdStanFit <- ci.stanreg #' @export ci.blavaan <- ci.stanreg #' @export ci.BFBayesFactor <- ci.numeric #' @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 = "all", verbose = TRUE, ... ) { ci( insight::get_parameters(x, component = component, verbose = verbose), 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.R0000644000176200001440000000132214357736006014544 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.R0000644000176200001440000000322314704176606016136 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) { param_subset <- params[params$Parameter == p, ] priors$prior[priors_params$Parameter == p] <- paste0( "normal(", insight::format_value(param_subset$Mean), ", ", insight::format_value(param_subset$SD * scale_multiply), ")" ) } } priors } bayestestR/R/sexit_thresholds.R0000644000176200001440000001215714747200255016332 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.R0000644000176200001440000001440715203314503014211 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 #' @param ... Other arguments passed to [rope()]. #' #' @inheritSection hdi Model components #' #' @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 #' @rdname p_rope #' @inheritParams p_direction p_rope.data.frame <- function(x, range = "default", rvar_col = NULL, verbose = TRUE, ...) { x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::p_rope cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(x)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x)) } 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.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, verbose = verbose) out <- p_rope(xdf, range = range, verbose = verbose) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.emm_list <- p_rope.emmGrid #' @export p_rope.slopes <- function(x, range = "default", verbose = TRUE, ...) { xrvar <- .get_marginaleffects_draws(x) out <- p_rope(xrvar, range = range, verbose = verbose) out <- .append_datagrid(out, x) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export p_rope.comparisons <- p_rope.slopes #' @export p_rope.predictions <- p_rope.slopes #' @export p_rope.BFBayesFactor <- p_rope.numeric #' @export p_rope.MCMCglmm <- p_rope.numeric #' @export p_rope.stanreg <- function(x, range = "default", effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ...) { 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.CmdStanFit <- p_rope.stanreg #' @export p_rope.blavaan <- p_rope.stanreg #' @rdname p_rope #' @export p_rope.brmsfit <- function(x, range = "default", effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ...) { 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 = "all", parameters = NULL, verbose = TRUE, ...) { 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", "Superiority_Percentage", "Inferiority_Percentage", "Effects", "Component" ) out <- as.data.frame(rope_rez)[cols[cols %in% names(rope_rez)]] names(out)[names(out) == "ROPE_Percentage"] <- "p_ROPE" if (all(c("Superiority_Percentage", "Inferiority_Percentage") %in% names(out))) { names(out)[names(out) == "Superiority_Percentage"] <- "p_Superiority" names(out)[names(out) == "Inferiority_Percentage"] <- "p_Inferiority" } class(out) <- c("p_rope", "see_p_rope", "data.frame") out } bayestestR/R/distribution.R0000644000176200001440000001507015037751621015454 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. When `random = FALSE`, these function return #' `q*(ppoints(n), ...)`. #' @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 #' #' @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_len(sd, 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, ...) } } bayestestR/R/eti.R0000644000176200001440000002116215203314503013502 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 #' #' @inheritSection hdi Model components #' #' @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 #' @rdname eti #' @inheritParams p_direction eti.data.frame <- function(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::eti cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x, long = length(ci) > 1L)) } dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "eti") attr(dat, "object_name") <- obj_name 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 = "all", verbose = TRUE, ...) { d <- insight::get_parameters(x, component = component, verbose = verbose) 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, verbose = verbose) 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 = "fixed", parameters = NULL, verbose = TRUE, ...) { 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, verbose = verbose) dat <- eti(xdf, ci = ci, verbose = verbose, ...) dat <- .append_datagrid(dat, x, long = length(ci) > 1L) attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.emm_list <- eti.emmGrid #' @export eti.slopes <- function(x, ci = 0.95, verbose = TRUE, ...) { xrvar <- .get_marginaleffects_draws(x) dat <- eti(xrvar, ci = ci, verbose = verbose, ...) dat <- .append_datagrid(dat, x, long = length(ci) > 1L) attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x)) dat } #' @export eti.comparisons <- eti.slopes #' @export eti.predictions <- eti.slopes #' @export eti.stanreg <- function(x, ci = 0.95, effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ...) { out <- .prepare_output( eti( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, verbose = verbose ), ci = ci, verbose = verbose, ... ), .get_cleaned_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 #' @export eti.CmdStanFit <- eti.stanreg #' @rdname eti #' @export eti.brmsfit <- function(x, ci = 0.95, effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ...) { out <- .prepare_output( eti( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, verbose = verbose ), ci = ci, verbose = verbose, ... ), .get_cleaned_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/is_baysian_grid.R0000644000176200001440000000142415055047701016056 0ustar liggesusers#' @keywords internal .is_baysian_grid <- function(x) { UseMethod(".is_baysian_grid") } #' @keywords internal .is_baysian_grid.emmGrid <- 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)) } #' @keywords internal .is_baysian_grid.emm_list <- .is_baysian_grid.emmGrid #' @keywords internal .is_baysian_grid.slopes <- function(x) { insight::check_if_installed("marginaleffects", minimum_version = "0.29.0") !is.null(suppressWarnings(marginaleffects::get_draws(x, "PxD"))) } #' @keywords internal .is_baysian_grid.predictions <- .is_baysian_grid.slopes #' @keywords internal .is_baysian_grid.comparisons <- .is_baysian_grid.slopes bayestestR/R/p_to_bf.R0000644000176200001440000001004114747200255014335 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.R0000644000176200001440000000416115203314503017414 0ustar liggesusers#' @export print.equivalence_test <- function(x, digits = 2, ...) { orig_x <- x insight::print_color("# Test for Practical Equivalence\n\n", "blue") # print ROPE limits, if we just have one set of ROPE values if (insight::has_single_value(x$ROPE_low, remove_na = TRUE)) { 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) && !is.data.frame(model)) { cp <- .get_cleaned_parameters(model) if (!is.null(cp) && !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 } } } } x$ROPE_Percentage <- sprintf("%.*f %%", digits, x$ROPE_Percentage * 100) x$HDI <- insight::format_ci(x$HDI_low, x$HDI_high, ci = NULL, digits = digits) ci <- unique(x$CI) keep.columns <- c( attr(x, "idvars"), "Parameter", "Effects", "Component", "ROPE_Equivalence", "ROPE_Percentage", "CI", "HDI" ) # keep ROPE columns for multiple ROPE values if (insight::n_unique(x$ROPE_low) > 1) { keep.columns <- c(keep.columns, "ROPE") x$ROPE <- insight::format_ci(x$ROPE_low, x$ROPE_high, ci = NULL, digits = digits) } 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") } } bayestestR/R/area_under_curve.R0000644000176200001440000000401614623110564016237 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.R0000644000176200001440000000160414404115100016160 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.R0000644000176200001440000005425015203314503016277 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. #' #' @inheritSection hdi Model components #' #' @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, ...) { 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 #' @inheritParams p_direction #' @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, rvar_col = NULL, ...) { x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::estimate_density cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(x)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) out <- .append_datagrid(out, x, long = TRUE) class(out) <- .set_density_class(out) return(out) } 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, ...) { 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", ...) { xdf <- insight::get_parameters(x) out <- estimate_density(xdf, method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ... ) out <- .append_datagrid(out, x, long = TRUE) class(out) <- .set_density_class(out) out } #' @export estimate_density.emm_list <- estimate_density.emmGrid #' @export estimate_density.slopes <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", ...) { xdf <- .get_marginaleffects_draws(x) out <- estimate_density(xdf, method = method, precision = precision, extend = extend, extend_scale = extend_scale, bw = bw, ... ) out <- .append_datagrid(out, x, long = TRUE) class(out) <- .set_density_class(out) out } #' @export estimate_density.predictions <- estimate_density.slopes #' @export estimate_density.comparisons <- estimate_density.slopes #' @export estimate_density.stanreg <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", effects = "fixed", component = "location", parameters = NULL, ...) { 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.CmdStanFit <- estimate_density.stanreg #' @export estimate_density.blavaan <- estimate_density.stanreg #' @rdname estimate_density #' @export estimate_density.brmsfit <- function(x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", effects = "fixed", component = "conditional", parameters = NULL, ...) { 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 = "all", parameters = NULL, ...) { 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.R0000644000176200001440000000044215033776022014763 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 #' @importFrom insight display #' @export insight::display bayestestR/R/hdi.R0000644000176200001440000004002015203314503013457 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 component Which type of parameters to return, such as parameters for #' the conditional model, the zero-inflated part of the model, the dispersion #' term, etc. See details in section _Model Components_. May be abbreviated. #' Note that the *conditional* component also refers to the *count* or *mean* #' component - names may differ, depending on the modeling package. There are #' three convenient shortcuts (not applicable to *all* model classes): #' - `component = "all"` returns all possible parameters. #' - If `component = "location"`, location parameters such as `conditional`, #' `zero_inflated`, `smooth_terms`, or `instruments` are returned (everything #' that are fixed or random effects - depending on the `effects` argument - #' but no auxiliary parameters). #' - For `component = "distributional"` (or `"auxiliary"`), components like #' `sigma`, `dispersion`, `beta` or `precision` (and other auxiliary #' parameters) are returned. #' @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. #' @inheritParams insight::get_parameters.BFBayesFactor #' @inheritParams insight::get_parameters #' #' @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}. #' #' @section Model components: #' #' Possible values for the `component` argument depend on the model class. #' Following are valid options: #' - `"all"`: returns all model components, applies to all models, but will only #' have an effect for models with more than just the conditional model #' component. #' - `"conditional"`: only returns the conditional component, i.e. "fixed #' effects" terms from the model. Will only have an effect for models with #' more than just the conditional model component. #' - `"smooth_terms"`: returns smooth terms, only applies to GAMs (or similar #' models that may contain smooth terms). #' - `"zero_inflated"` (or `"zi"`): returns the zero-inflation component. #' - `"location"`: returns location parameters such as `conditional`, #' `zero_inflated`, or `smooth_terms` (everything that are fixed or random #' effects - depending on the `effects` argument - but no auxiliary #' parameters). #' - `"distributional"` (or `"auxiliary"`): components like `sigma`, #' `dispersion`, `beta` or `precision` (and other auxiliary parameters) are #' returned. #' #' For models of class `brmsfit` (package **brms**), even more options are #' possible for the `component` argument, which are not all documented in detail #' here. See also [`?insight::find_parameters`](https://easystats.github.io/insight/reference/find_parameters.BGGM.html). #' #' @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. #' #' 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.5th #' 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. #' #' 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). #' #' @inherit ci return #' #' @family ci #' @seealso Other interval functions, such as [`hdi()`], [`eti()`], [`bci()`], #' [`spi()`], [`si()`]. #' #' @examplesIf all(insight::check_if_installed(c("rstanarm", "brms", "emmeans", "BayesFactor"), quietly = TRUE)) #' library(bayestestR) #' #' posterior <- rnorm(1000) #' hdi(posterior, ci = 0.89) #' hdi(posterior, ci = c(0.80, 0.90, 0.95)) #' #' hdi(iris[1:4]) #' 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) #' ) #' hdi(model) #' hdi(model, ci = c(0.80, 0.90, 0.95)) #' #' hdi(emmeans::emtrends(model, ~1, "wt", data = mtcars)) #' #' model <- brms::brm(mpg ~ wt + cyl, data = mtcars) #' hdi(model) #' hdi(model, ci = c(0.80, 0.90, 0.95)) #' #' bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) #' hdi(bf) #' 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 #' @inheritParams p_direction #' @export hdi.data.frame <- function(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) x_rvar <- .possibly_extract_rvar_col(x, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::hdi cl$x <- x_rvar cl$rvar_col <- NULL out <- eval.parent(cl) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, x, long = length(ci) > 1L)) } dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "hdi") attr(dat, "object_name") <- obj_name 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 = "all", verbose = TRUE, ...) { ci_fun <- .check_ci_fun(list(...)) d <- insight::get_parameters(x, component = component, verbose = verbose) 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, verbose = verbose) 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 = "fixed", parameters = NULL, verbose = TRUE, ... ) { ci_fun <- .check_ci_fun(list(...)) 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, verbose = verbose) out <- hdi(xdf, ci = ci, verbose = verbose, ...) out <- .append_datagrid(out, x, long = length(ci) > 1L) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export hdi.emm_list <- hdi.emmGrid #' @export hdi.slopes <- function(x, ci = 0.95, verbose = TRUE, ...) { xrvar <- .get_marginaleffects_draws(x) out <- hdi(xrvar, ci = ci, verbose = verbose, ...) out <- .append_datagrid(out, x, long = length(ci) > 1L) attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x)) out } #' @export hdi.comparisons <- hdi.slopes #' @export hdi.predictions <- hdi.slopes #' @export hdi.stanreg <- function( x, ci = 0.95, effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ... ) { cleaned_parameters <- .get_cleaned_parameters(x, ...) out <- .prepare_output( hdi( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, verbose = verbose ), 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.CmdStanFit <- hdi.stanreg #' @export hdi.blavaan <- hdi.stanreg #' @rdname hdi #' @export hdi.brmsfit <- function( x, ci = 0.95, effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ... ) { cleaned_parameters <- .get_cleaned_parameters(x, ...) out <- .prepare_output( hdi( insight::get_parameters( x, effects = effects, component = component, parameters = parameters, verbose = verbose ), 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) } # removes NA/NaN, but not Inf x_sorted <- unname(sort.int(x, method = "quick")) # See https://github.com/easystats/bayestestR/issues/39 window_size <- ceiling(ci * length(x_sorted)) 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.R0000644000176200001440000000511214704176606014405 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) approx_data <- data.frame(x = x_axis, y1 = fx(x_axis), y2 = fy(x_axis)) # calculate intersection densities approx_data$intersection <- pmin(approx_data$y1, approx_data$y2) approx_data$exclusion <- pmax(approx_data$y1, approx_data$y2) # integrate areas under curves area_intersection <- area_under_curve( approx_data$x, approx_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") <- approx_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 plot_data <- attributes(x)$data graphics::plot(plot_data$x, plot_data$exclusion, type = "l") graphics::polygon(plot_data$x, plot_data$intersection, col = "red") } bayestestR/R/simulate_data.R0000644000176200001440000001116214747200255015546 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.R0000644000176200001440000003323514747200255014073 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.R0000644000176200001440000012133415204535252016620 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 [`eti()`]), `"HDI"` (see [`hdi()`]), `"BCI"` (see [`bci()`]), #' `"SPI"` (see [`spi()`]), or `"SI"` (see [`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"`, `"p_significance"` (or `"ps"`), `"p_rope"`, #' `"equivalence_test"` (or `"equitest"`), `"bayesfactor"` (or `"bf"`) or #' `"all"` to compute all tests. For each "test", the corresponding #' **bayestestR** function is called (e.g. [`rope()`] or [`p_direction()`]) #' and its results included in the summary output. #' @param rope_range ROPE's lower and higher bounds. Should be a vector of two #' values (e.g., `c(-0.1, 0.1)`), `"default"` or a list of numeric vectors of #' the same length as numbers of parameters. 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 [`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 #' #' @inheritSection hdi Model components #' #' @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) #' #' @examplesIf all(insight::check_if_installed(c("logspline", "rstanarm", "emmeans", "BayesFactor"), quietly = TRUE)) #' library(bayestestR) #' #' 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 #' # ----------------------------------------------- #' model <- suppressWarnings( #' rstanarm::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)) #' describe_posterior(model, rope_range = list(c(-10, 5), c(-0.2, 0.2), "default")) #' #' # emmeans estimates #' # ----------------------------------------------- #' describe_posterior(emmeans::emtrends(model, ~1, "wt")) #' #' # BayesFactor objects #' # ----------------------------------------------- #' bf <- BayesFactor::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 (.check_if_need_to_compute_rope_range(rope_range, test)) { rope_range <- rope_range(x, verbose = verbose, ...) } if (!is.data.frame(x) && !is.numeric(x)) { is_stanmvreg <- inherits(x, "stanmvreg") cleaned_parameters <- .get_cleaned_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 = cleaned_parameters, ... ), 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 <- insight::validate_argument( 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, cleaned_parameters = cleaned_parameters, ... ) } else { uncertainty <- ci( x_df, ci = ci, method = ci_method, verbose = verbose, cleaned_parameters = cleaned_parameters, ... ) } 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"))) { 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 = cleaned_parameters, ...), 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 = cleaned_parameters, ...), 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 = cleaned_parameters, ... ), 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 = cleaned_parameters, ... ), 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 = cleaned_parameters, ... ), 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( do.call( equivalence_test, c( dot_args, list( x = x_df, range = rope_range, ci = rope_ci ) ) ), 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))) { # nolint 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, remove_na = TRUE) < 2) { remove_columns <- c(remove_columns, "Effects") } if (insight::n_unique(out$Component, remove_na = TRUE) < 2) { remove_columns <- c(remove_columns, "Component") } if (insight::n_unique(out$Response, remove_na = 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, "cleaned_parameters") <- cleaned_parameters 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 #' @rdname describe_posterior #' @inheritParams p_direction describe_posterior.data.frame <- 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, rvar_col = NULL, verbose = TRUE, ... ) { x_rvar <- .possibly_extract_rvar_col(posterior, rvar_col) if (length(x_rvar) > 0L) { cl <- match.call() cl[[1]] <- bayestestR::describe_posterior cl$posterior <- x_rvar cl$rvar_col <- NULL prior_rvar <- .possibly_extract_rvar_col(posterior, bf_prior) if (length(prior_rvar) > 0L) { cl$bf_prior <- prior_rvar } out <- eval.parent(cl) obj_name <- insight::safe_deparse_symbol(substitute(posterior)) attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col) return(.append_datagrid(out, 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, verbose = verbose, ... ) class(out) <- unique(c("describe_posterior", "see_describe_posterior", class(out))) out } #' @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 = if (!is.null(bf_prior)) .posterior_draws_to_df(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 out <- .append_datagrid(out, posterior) 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 #' @export describe_posterior.slopes <- 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 <- .get_marginaleffects_draws(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 out <- .append_datagrid(out, posterior) 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.comparisons <- describe_posterior.slopes #' @export describe_posterior.predictions <- describe_posterior.slopes # 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 = "fixed", component = "location", 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)) } 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, ... ) # intermediate step: save cleaned parameters cp <- attributes(out)$cleaned_parameters diagnostic <- diagnostic_posterior( posterior, diagnostic, effects = effects, component = component, parameters = parameters, centrality = centrality, ... ) 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, cleaned_parameters = cp) 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 = "fixed", component = "location", 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, bf_prior = bf_prior, effects = effects, parameters = parameters, verbose = verbose, ... ) # intermediate step: save cleaned parameters cp <- attributes(out)$cleaned_parameters if (is.null(out$Response)) { out$Response <- gsub("(b\\[)*(.*)\\|(.*)", "\\2", out$Parameter) } diagnostic <- diagnostic_posterior( posterior, diagnostic, effects = effects, parameters = parameters, centrality = centrality, ... ) 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, cleaned_parameters = cp) 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 = "fixed", parameters = NULL, priors = FALSE, 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 = effects, parameters = parameters, verbose = verbose, ... ) diagnostic <- diagnostic_posterior( posterior, diagnostic, effects = effects, parameters = parameters, centrality = centrality, ... ) 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 } #' @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 = "fixed", component = "conditional", parameters = NULL, BF = 1, priors = FALSE, 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)) } 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, ... ) # intermediate step: save cleaned parameters cp <- attributes(out)$cleaned_parameters if (!is.null(diagnostic)) { diagnostic <- diagnostic_posterior( posterior, diagnostic, effects = effects, component = component, parameters = parameters, centrality = centrality, ... ) 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, cleaned_parameters = cp) 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 #' @export describe_posterior.CmdStanFit <- 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 = "all", 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, 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 ) } #' @keywords internal .check_if_need_to_compute_rope_range <- function(rope_range, test) { if (is.numeric(rope_range) || is.list(rope_range)) { return(FALSE) } need_rope <- c( "all", "p_rope", "ps", "p_sig", "p_significance", "rope", "equivalence", "equivalence_test", "equitest" ) return(is.character(test) && length(test) > 0L && any(need_rope %in% tolower(test))) } bayestestR/R/convert_pd_to_p.R0000644000176200001440000000622114747200255016116 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). Can also #' be a data frame with a column named `pd`, `p_direction`, or `PD`, as returned #' by [`p_direction()`]. In this case, the column is converted to p-values and #' the new data frame is returned. #' @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. #' #' @return A p-value or a data frame with a p-value column. #' #' @details #' Conversion is done using the following equation (see _Makowski et al., 2019_): #' #' When `direction = "two-sided"` #' #' \ifelse{html}{\out{p = 2 * (1 - pd)}}{\eqn{p = 2 \times (1 - p_d)}} #' #' When `direction = "one-sided"` #' #' \ifelse{html}{\out{p = 1 - pd}}{\eqn{p = 1 - p_d}} #' #' 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, ...) { UseMethod("pd_to_p") } #' @export #' @rdname pd_to_p pd_to_p.numeric <- 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, indicating inconsistent direction of the probability mass.", "This usually happens when the parameters space is not continuous. Affected values are set to 1.", "See help('p_direction') for more info." )) } p[less_than_0.5] <- 1 } p } #' @export pd_to_p.data.frame <- function(pd, direction = "two-sided", verbose = TRUE, ...) { # check if data frame has an appropriate column pd_column <- intersect(c("pd", "p_direction", "PD"), colnames(pd))[1] if (is.na(pd_column) || length(pd_column) == 0) { insight::format_error("No column named `pd`, `p_direction`, or `PD` found.") } # add p-value column pd$p <- pd_to_p(as.numeric(pd[[pd_column]])) # remove pd-column pd[[pd_column]] <- NULL pd } #' @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/0000755000176200001440000000000015204544512014411 5ustar liggesusersbayestestR/vignettes/overview_of_vignettes.Rmd0000644000176200001440000000410014266336540021501 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/0000755000176200001440000000000014357736006013323 5ustar liggesusersbayestestR/data/disgust.rdata0000644000176200001440000000062414357736006016024 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)` now returns class `bayesfactor_matrix` and has a simpler printing. * `diagnostic_posterior()` works with 'raw' MCMC samples (i.e., lists of data frames or matrices representing samples of parameters from chains, or 3D arrays) as well as objects from rstanarm/brms/lavaan models. * `diagnostic_posterior()` now reports the **tail-ESS** (the minimum of the effective sample sizes for the 5% and 95% quantiles) in the `ESS` column, instead of the basic `n_eff` from older Stan versions. The tail-ESS is more relevant for assessing the reliability of credible intervals and other tail-based quantities. To also obtain the bulk-ESS (useful for central tendency estimates), pass `"ESS_bulk"` to the `diagnostic` argument. * `effective_sample()` for `stanfit` objects now also returns the tail-ESS (`ESS_tail`), consistent with `brmsfit` and `stanreg` objects. # bayestestR 0.17.0 ## Changes * `rope()` (and by extension `p_rope()`) gain a new `complement` argument such that `rope(x, complement = TRUE)` returns the ROPE posterior probability together with the posterior probabilities above/below the ROPE (the _complementary_ probabilities). * Added `display()` methods for *bayestestR* objects. The `display()` methods also get a new `format` option, `format = "tt"`, to produce tables with the `tinytable` package. * The long deprecated `rnorm_perfect()` function has been removed. Use `distribution_normal()` instead. * Prepare for upcoming changes in *marginaleffects* (0.29.0). # bayestestR 0.16.1 ## Changes * Improved efficiency for `describe_posterior()`. * Minor improvements for models with multinomial response variables. * Minor improvements for mixture models from package *brms*. # bayestestR 0.16.0 ## Changes * Revised code-base to address changes in latest *insight* update. Dealing with larger models (many parameters, many posterior samples) from packages *brms* and *rstanarm* is more efficient now. Furthermore, the options for the `effects` argument have a new behavior. `"all"` only returns fixed effects and random effects variance components, but no longer the group level estimates. Use `effects = "full"` to return all parameters. This change is mainly to be more flexible and gain more efficiency for models with many parameters and / or many posterior draws. # bayestestR 0.15.3 ## Changes * `effective_sample()`, and functions that call `effective_sample()` (like `describe_posterior()` with the respective `test` option) now also return the tail ESS. ## Bug fixes * `describe_posterior()` now returns a columns with response levels for *marginaleffects* objects applied to categorical or multinomial Stan models. * `describe_posterior()` now returns a columns with response variables for *marginaleffects* objects applied to multivariate response Stan models. * Fixed issue in `map_estimate()` and `point_estimate(centrality = "MAP")` for vectors with only one unique value. # bayestestR 0.15.2 ## Changes * `describe_posterior()` no longer re-samples a model when computing indices. * `describe_posterior()` calls tests only when needed. Before, there was a minimal overhead by calling tests that were not requested. ## Bug fixes * Fixed failing test for Mac OS. # bayestestR 0.15.1 ## Changes * Several minor changes to deal with recent changes in other packages. ## Bug fixes * Fix to `emmeans` / `marginaleffects` / `data.frame()` methods when using multiple credible levels (#688). # bayestestR 0.15.0 ## Changes * Support for `posterior::rvar`-type column in data frames. For example, a data frame `df` with an `rvar` column `".pred"` can now be called directly via `p_direction(df, rvar_col = ".pred")`. * Added support for `{marginaleffects}` * The ROPE or threshold ranges in `rope()`, `describe_posterior()`, `p_significance()` and `equivalence_test()` can now be specified as a list. This allows for different ranges for different parameters. * Results from objects generated by `{emmeans}` (`emmGrid`/`emm_list`) now return results with appended grid-data. * Usability improvements for `p_direction()`: - Results from `p_direction()` can directly be used in `pd_to_p()`. - `p_direction()` gets an `as_p` argument, to directly convert pd-values into frequentist p-values. - `p_direction()` gets a `remove_na` argument, which defaults to `TRUE`, to remove `NA` values from the input before calculating the pd-values. - Besides the existing `as.numeric()` method, `p_direction()` now also has an `as.vector()` method. * `p_significance()` now accepts non-symmetric ranges for the `threshold` argument. * `p_to_pd()` now also works with data frames returned by `p_direction()`. If a data frame contains a `pd`, `p_direction` or `PD` column name, this is assumed to be the pd-values, which are then converted to p-values. * `p_to_pd()` for data frame inputs gets a `as.numeric()` and `as.vector()` method. ## Bug fixes * Fixed warning in CRAN check results. # bayestestR 0.14.0 ## Breaking Changes * Arguments named `group`, `at`, `group_by` and `split_by` will be deprecated in future releases of _easystats_ packages. Please use `by` instead. This affects following functions in *bayestestR*: `estimate_density()`. ## Changes * `bayesian_as_frequentist()` now supports more model families from Bayesian models that can be successfully converted to their frequentists counterparts. * `bayesfactor_models()` now throws an informative error when Bayes factors for comparisons could not be calculated. ## Bug fixes * Fixed issue in `bayesian_as_frequentist()` for *brms* models with `0 + Intercept` specification in the model formula. # bayestestR 0.13.2 ## Breaking Changes * `pd_to_p()` now returns 1 and a warning for values smaller than 0.5. * `map_estimate()`, `p_direction()`, `p_map()`, and `p_significance()` now return a data-frame when the input is a numeric vector. (making the output consistently a data frame for all inputs.) * Argument `posteriors` was renamed into `posterior`. Before, there were a mix of both spellings, now it is consistently `posterior`. ## Changes * Retrieving models from the environment was improved. ## Bug fixes * Fixed issues in various `format()` methods, which did not work properly for some few functions (like `p_direction()`). * Fixed issue in `estimate_density()` for double vectors that also had other class attributes. * Fixed several minor issues and tests. # bayestestR 0.13.1 ## Changes * Improved speed performance when functions are called using `do.call()`. * Improved speed performance to `bayesfactor_models()` for `brmsfit` objects that already included a `marglik` element in the model object. ## New functionality * `as.logical()` for `bayesfactor_restricted()` results, extracts the boolean vector(s) the mark which draws are part of the order restriction. ## Bug fixes * `p_map()` gains a new `null` argument to specify any non-0 nulls. * Fixed non-working examples for `ci(method = "SI")`. * Fixed wrong calculation of rope range for model objects in `describe_posterior()`. * Some smaller bug fixes. # bayestestR 0.13.0 ## Breaking * The minimum needed R version has been bumped to `3.6`. * `contr.equalprior(contrasts = FALSE)` (previously `contr.orthonorm`) no longer returns an identity matrix, but a shifted `diag(n) - 1/n`, for consistency. ## New functionality * `p_to_bf()`, to convert p-values into Bayes factors. For more accurate approximate Bayes factors, use `bic_to_bf()`. * *bayestestR* now supports objects of class `rvar` from package *posterior*. * `contr.equalprior` (previously `contr.orthonorm`) gains two new functions: `contr.equalprior_pairs` and `contr.equalprior_deviations` to aide in setting more intuitive priors. ## Changes * has been renamed *`contr.equalprior`* to be more explicit about its function. * `p_direction()` now accepts objects of class `parameters_model()` (from `parameters::model_parameters()`), to compute probability of direction for parameters of frequentist models. # bayestestR 0.12.1 ## Breaking * `Bayesfactor_models()` for frequentist models now relies on the updated `insight::get_loglikelihood()`. This might change some results for REML based models. See documentation. * `estimate_density()` argument `group_by` is renamed `at`. * All `distribution_*(random = FALSE)` functions now rely on `ppoints()`, which will result in slightly different results, especially with small `n`s. * Uncertainty estimation now defaults to `"eti"` (formerly was `"hdi"`). ## Changes * *bayestestR* functions now support `draws` objects from package *posterior*. * `rope_range()` now handles log(normal)-families and models with log-transformed outcomes. * New function `spi()`, to compute shortest probability intervals. Furthermore, the `"spi"` option was added as new method to compute uncertainty intervals. ## Bug fixes * `bci()` for some objects incorrectly returned the equal-tailed intervals. # bayestestR 0.11.5 * Fixes failing tests in CRAN checks. # bayestestR 0.11.1 ## New functions * `describe_posterior()` gains a `plot()` method, which is a short cut for `plot(estimate_density(describe_posterior()))`. # bayestestR 0.11 ## Bug fixes * Fixed issues related to last *brms* update. * Fixed bug in `describe_posterior.BFBayesFactor()` where Bayes factors were missing from out put ( #442 ). # bayestestR 0.10.0 ## Breaking * All Bayes factors are now returned as `log(BF)` (column name `log_BF`). Printing is unaffected. To retrieve the raw BFs, you can run `exp(result$log_BF)`. ## New functions * `bci()` (and its alias `bcai()`) to compute bias-corrected and accelerated bootstrap intervals. Along with this new function, `ci()` and `describe_posterior()` gain a new `ci_method` type, `"bci"`. ## Changes * `contr.bayes` has been renamed *`contr.orthonorm`* to be more explicit about its function. # bayestestR 0.9.0 ## Breaking * The default `ci` width has been changed to 0.95 instead of 0.89 (see [here](https://github.com/easystats/bayestestR/discussions/250)). This should not come as a surprise to the long-time users of `bayestestR` as we have been warning about this impending change for a while now :) * Column names for `bayesfactor_restricted()` are now `p_prior` and `p_posterior` (was `Prior_prob` and `Posterior_prob`), to be consistent with `bayesfactor_inclusion()` output. * Removed the experimental function `mhdior`. ## General * Support for `blavaan` models. * Support for `blrm` models (*rmsb*). * Support for `BGGM` models (*BGGM*). * `check_prior()` and `describe_prior()` should now also work for more ways of prior definition in models from *rstanarm* or *brms*. ## Bug fixes * Fixed bug in `print()` method for the `mediation()` function. * Fixed remaining inconsistencies with CI values, which were not reported as fraction for `rope()`. * Fixed issues with special prior definitions in `check_prior()`, `describe_prior()` and `simulate_prior()`. # bayestestR 0.8.2 ## General * Support for `bamlss` models. * Roll-back R dependency to R >= 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/0000755000176200001440000000000015204544512013356 5ustar liggesusersbayestestR/inst/CITATION0000644000176200001440000000142214266336540014521 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/0000755000176200001440000000000015204544512014123 5ustar liggesusersbayestestR/inst/doc/overview_of_vignettes.Rmd0000644000176200001440000000410014266336540021213 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.R0000644000176200001440000000035515204544512020673 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.html0000644000176200001440000001622015204544512021434 0ustar liggesusers Overview of Vignettes

Overview of Vignettes

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

Function Overview

bayestestR/inst/WORDLIST0000644000176200001440000000360115037751621014555 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 codecov 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 marginaleffects maths mattansb mcmc mfx modelling nbinom neq notin objets operationalizing orthonormal osterior patilindrajeets pre preprint priori ps psyarxiv rOpenSci reconceptualisation replicability reproducibility richarddmorey riors rmsb rmarkdown rstanarm sIgnificance salis setosa setosas splinefun ss stanfit stanreg strengejacke summarise summarised th treedepth tweedie un underbrace unupdate versicolor versicolors virginica virgnica visualisation visualise warmup wil xy bayestestR/README.md0000644000176200001440000004735515174322463013703 0ustar liggesusers # bayestestR [![DOI](https://joss.theoj.org/papers/10.21105/joss.01541/status.svg)](https://doi.org/10.21105/joss.01541) [![downloads](https://cranlogs.r-pkg.org/badges/bayestestR)](https://cran.r-project.org/package=bayestestR) [![total](https://cranlogs.r-pkg.org/badges/grand-total/bayestestR)](https://cranlogs.r-pkg.org/) ***Become a Bayesian master you will*** 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](https://www.r-pkg.org/badges/version/bayestestR)](https://cran.r-project.org/package=bayestestR) [![bayestestR status badge](https://easystats.r-universe.dev/badges/bayestestR)](https://easystats.r-universe.dev) [![codecov](https://codecov.io/gh/easystats/bayestestR/branch/main/graph/badge.svg)](https://app.codecov.io/gh/easystats/bayestestR) 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 [![Documentation](https://img.shields.io/badge/documentation-bayestestR-orange.svg?colorB=E91E63)](https://easystats.github.io/bayestestR/) [![Blog](https://img.shields.io/badge/blog-easystats-orange.svg?colorB=FF9800)](https://easystats.github.io/blog/posts/) [![Features](https://img.shields.io/badge/features-bayestestR-orange.svg?colorB=2196F3)](https://easystats.github.io/bayestestR/reference/index.html) 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 | -5.70e-03 | [-2.00, 1.99] | 50.23% | 0.47 ``` `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 ## child | -1.16 | -1.16 | -1.16 | [-1.36, -0.94] | 100% | 1.00 | 0.996 | 278 ## camper | 0.73 | 0.72 | 0.73 | [ 0.54, 0.91] | 100% | 1.00 | 0.996 | 271 ## ## # 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 ## child | 1.85 | 1.86 | 1.81 | [ 1.19, 2.54] | 100% | 1.00 | 0.996 | 303 ## camper | -0.88 | -0.86 | -0.99 | [-1.61, -0.07] | 98.40% | 0.96 | 0.996 | 292 ## ## # 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 ## ## # 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 *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/centrality-2-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) ## 95% HDI: [0.08, 9.53] eti(posterior) ## 95% ETI: [0.48, 11.14] ``` ![](man/figures/uncertainty-plot-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/tests-plot-1.png) ### ROPE [`rope()`](https://easystats.github.io/bayestestR/reference/rope.html) computes the proportion (in percentage) of the CI (default to the 95% ETI) 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 CI 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/rope-2-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-1-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.39 ``` ## 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/0000755000176200001440000000000015204544512013500 5ustar liggesusersbayestestR/build/vignette.rds0000644000176200001440000000033015204544512016033 0ustar liggesusersb```b`a@&0rHK日eŗe祖妠)*TOS)DS$ݴ48U X%bZ]?4-ީE0=(jؠjX2sRad9.nP&c0Gq?gQ~iݣ9JI,IK+uX`bayestestR/build/partial.rdb0000644000176200001440000000007415204544464015634 0ustar liggesusersb```b`a 00 FN ͚Z d@$12^`7bayestestR/man/0000755000176200001440000000000015204535252013155 5ustar liggesusersbayestestR/man/distribution.Rd0000644000176200001440000000715615203314503016165 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} \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, ...) } \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}{number of observations. If \code{length(n) > 1}, the length is taken to be the number required.} \item{random}{Generate near-perfect or random (simple wrappers for the base R \verb{r*} functions) distributions. When \code{random = FALSE}, these function return \verb{q*(ppoints(n), ...)}.} \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}{alternative parametrization via mean: see \sQuote{Details}.} \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. } \examples{ library(bayestestR) x <- distribution(n = 10) plot(density(x)) x <- distribution(type = "gamma", n = 100, shape = 2) plot(density(x)) } bayestestR/man/mcse.Rd0000644000176200001440000001237215204535252014400 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 = "fixed", component = "location", parameters = NULL, centrality = "median", ... ) } \arguments{ \item{model}{A \code{stanreg}, \code{stanfit}, \code{brmsfit}, \code{blavaan}, or \code{MCMCglmm} object.} \item{...}{Additional arguments to be passed to or from methods.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{centrality}{The point-estimate (centrality index) for which to compute the MCSE. Can be \code{"median"} (default) or \code{"mean"}. To not break other functions like \code{describe_posterior()} or \code{diagnostic_posterior()}, all other values are silently converted to \code{"median"}.} } \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}. } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("rstanarm")) withAutoprint(\{ # 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/bayesfactor_methods.Rd0000644000176200001440000001004615203314503017463 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bayesfactor-methods.R \name{bayesfactor_methods} \alias{bayesfactor_methods} \alias{as.matrix.bayestestRBF} \alias{update.bayesfactor_models} \alias{as.numeric.bayestestRBF} \alias{as.logical.bayesfactor_restricted} \title{Methods for Bayes factors} \usage{ \method{as.matrix}{bayestestRBF}(x, log = TRUE, ...) \method{update}{bayesfactor_models}(object, subset = NULL, reference = NULL, ...) \method{as.numeric}{bayestestRBF}(x, log = FALSE, ...) \method{as.logical}{bayesfactor_restricted}(x, which = c("posterior", "prior"), ...) } \arguments{ \item{x, object}{Bayes factor object} \item{log}{Return log(BF) (default), or BF values.} \item{...}{Additional arguments (currently not used).} \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.} \item{which}{Should the logical matrix be of the posterior or prior distribution(s)?} } \value{ \itemize{ \item \code{as.numeric()} / \code{as.double()}: a numeric vector of (log) Bayes factors. \item \code{as.logical()}: a logical data frame with a column for each order-restricted hypothesis. \item \code{as.matrix()}: a square matrix of (log) Bayes factors, with rows as denominators and columns as numerators. \item \code{update()}: an updated \code{bayesfactor_models} object. } } \description{ Methods for Bayes factors } \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). See also \code{effectsize::interpret_bf()}. } \section{Transitivity of Bayes factors}{ For multiple inputs (models or hypotheses), the function will return multiple Bayes factors between each model and \emph{the same} reference model (the \code{denominator} or un-restricted model). However, we can take advantage of the transitivity of Bayes factors - where if we have two Bayes factors for Model \emph{A} and model \emph{B} against the \emph{same reference model C}, we can obtain a Bayes factor for comparing model \emph{A} to model \emph{B} by dividing them: \cr\cr \deqn{BF_{AB} = \frac{BF_{AC}}{BF_{BC}} = \frac{\frac{ML_{A}}{ML_{C}}}{\frac{ML_{B}}{ML_{C}}} = \frac{ML_{A}}{ML_{B}}} \cr\cr (Where \emph{ML} is the \emph{marginal likelihood}.) \cr\cr A full matrix comparing all models can be obtained with \code{as.matrix()}. } \section{Prior and posterior considerations}{ 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. \cr\cr 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}) (Note that by default, \code{brms::brm()} uses flat priors for fixed-effects); Wide priors result in smaller marginal likelihoods, and thus models with wider priors are trivially less likely than models with narrower priors - where, at the extreme, that a model with completely flat priors is infinitely less favorable than a point null model (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 Additionally, for models using MCMC estimation 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, a warning is issued. } bayestestR/man/equivalence_test.Rd0000644000176200001440000002625115174322463017016 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.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, rvar_col = NULL, verbose = TRUE, ... ) \method{equivalence_test}{brmsfit}( x, range = "default", ci = 0.95, effects = "fixed", component = "conditional", 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. For models with one response, \code{range} can be: \itemize{ \item a vector of length two (e.g., \code{c(-0.1, 0.1)}), \item a list of numeric vector of the same length as numbers of parameters (see 'Examples'). \item a list of \emph{named} numeric vectors, where names correspond to parameter names. In this case, all parameters that have no matching name in \code{range} will be set to \code{"default"}. } In multivariate models, \code{range} should be a list with another list (one for each response variable) of numeric vectors . 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. See 'Examples'.} \item{ci}{The Credible Interval (CI) probability, corresponding to the proportion of HDI, to use for the percentage in ROPE.} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{verbose}{Toggle off warnings.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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 95\% \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 95\% 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 is 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). 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. \strong{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. 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}). \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). } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (all(insight::check_if_installed(c("rstanarm", "brms", "emmeans", "BayesFactor", "see"), quietly = TRUE))) withAutoprint(\{ # 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) # multiple ROPE ranges - asymmetric, symmetric, default equivalence_test(model, range = list(c(10, 40), c(-5, -4), "default")) # named ROPE ranges equivalence_test(model, range = list(wt = c(-5, -4), `(Intercept)` = c(10, 40))) # 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.Rd0000644000176200001440000004004315203314503020163 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.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, effects = "fixed", component = "conditional", parameters = NULL, ..., verbose = TRUE ) \method{bayesfactor_parameters}{data.frame}( posterior, prior = NULL, direction = "two-sided", null = 0, rvar_col = NULL, ..., 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{...}{Arguments passed to and from other methods. (Can be used to pass arguments to internal \code{\link[logspline:logspline]{logspline::logspline()}}.)} \item{verbose}{Toggle off warnings.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} } \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 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 \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; see details). The \verb{bf_*} functions are aliases of the main functions. \cr \cr \strong{For more info, 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. \cr \cr Note that the \code{logspline} package is used for estimating densities and probabilities, and must be installed for the function to work. \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))}. } \subsection{Additional methods}{ The resulting output is supported by the following methods: \itemize{ \item \code{as.numeric()}: Extract the (possibly log-)Bayes factor values. } See \link{bayesfactor_methods}. } } \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{Obtaining prior samples}{ It is important to provide the correct \code{prior} for meaningful results, to match the \code{posterior}-type input: \itemize{ \item \strong{A numeric vector} - \code{prior} should also be a \emph{numeric vector}, representing the prior-distribution \item \strong{A data frame} - \code{prior} should also be a \emph{data frame}, representing the prior-estimates, in matching column order. \itemize{ \item If \code{rvar_col} is specified, \code{prior} should be \emph{the name of an \code{rvar} column} that represents the prior-estimates. } \item \strong{Supported Bayesian model (\code{stanreg}, \code{brmsfit}, etc.)} \itemize{ \item \code{prior} should be \emph{a model an equivalent model with MCMC samples from the priors \strong{only}}. See \code{\link[=unupdate]{unupdate()}}. \item If \code{prior} is set to \code{NULL}, \code{\link[=unupdate]{unupdate()}} is called internally (not supported for \code{brmsfit_multiple} model). } \item \strong{Output from a \code{{marginaleffects}} function} - \code{prior} should also be \emph{an equivalent output} from a \code{{marginaleffects}} function based on a prior-model (See \code{\link[=unupdate]{unupdate()}}). \item \strong{Output from an \code{{emmeans}} function} \itemize{ \item \code{prior} should also be \emph{an equivalent output} from an \code{{emmeans}} function based on a prior-model (See \code{\link[=unupdate]{unupdate()}}). \item \code{prior} can also be \emph{the original (posterior) model}, in which case the function will try to "unupdate" the estimates (not supported if the estimates have undergone any transformations -- \code{"log"}, \code{"response"}, etc. -- or any \code{regrid}ing). } } } \section{Prior and posterior considerations}{ 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. \cr\cr 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}) (Note that by default, \code{brms::brm()} uses flat priors for fixed-effects); Wide priors result in smaller marginal likelihoods, and thus models with wider priors are trivially less likely than models with narrower priors - where, at the extreme, that a model with completely flat priors is infinitely less favorable than a point null model (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 Additionally, for models using MCMC estimation 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, a warning is issued. } \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). See also \code{effectsize::interpret_bf()}. } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("logspline")) withAutoprint(\{ # 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")) withAutoprint(\{ # 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")) withAutoprint(\{ # 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} } } \seealso{ Other Bayes factors: \code{\link{bayesfactor_inclusion}()}, \code{\link{bayesfactor_models}()}, \code{\link{bayesfactor_restricted}()} } \author{ Mattan S. Ben-Shachar } \concept{Bayes factors} bayestestR/man/sexit.Rd0000644000176200001440000001765415174322463014621 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} (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.Rd0000644000176200001440000000456515151511631015062 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")) withAutoprint(\{ # 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.Rd0000644000176200001440000001566515174322463016766 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} \title{Effective Sample Size (ESS)} \usage{ effective_sample(model, ...) \method{effective_sample}{brmsfit}( model, effects = "fixed", component = "conditional", 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 variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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 columns for the parameter name, bulk ESS (\code{ESS}), and (where available) tail ESS (\code{ESS_tail}). } \description{ Effective Sample Size (ESS) is a measure of how much independent information there is in autocorrelated chains. It is used to assess the quality of MCMC samples. A higher ESS indicates more reliable estimates. For most applications, an effective sample size greater than 1,000 is sufficient for stable estimates (Bürkner, 2017). This function returns the effective sample size (ESS) for various Bayesian model objects. For \code{brmsfit}, \code{stanreg}, and \code{stanfit} objects, both \strong{bulk-ESS} and \strong{tail-ESS} are returned. } \details{ \itemize{ \item \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}). \item \strong{Bulk-ESS} is useful as a diagnostic for the sampling efficiency in the bulk of the posterior. It is defined as the effective sample size for rank normalized values using split chains. It can be interpreted as the reliability of indices of central tendency (mean, median, etc.). \item \strong{Tail-ESS} is useful as a diagnostic for the sampling efficiency in the tails of the posterior. It is defined as the minimum of the effective sample sizes for 5\% and 95\% quantiles. It can be interpreted as the reliability of indices that depend on the tails of the distribution (e.g., credible intervals, tail probabilities, etc.). } } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (all(insight::check_if_installed(c("rstanarm", "brms", "posterior"), quietly = TRUE))) withAutoprint(\{ # examplesIf} \donttest{ model <- suppressWarnings(rstanarm::stan_glm( mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0 )) effective_sample(model) model <- suppressWarnings(brms::brm( mpg ~ wt, 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 \item Vehtari, A., Gelman, A., Simpson, D., Carpenter, B., & Bürkner, P.-C. (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC. Bayesian Analysis, 16(2), 667-718. } } bayestestR/man/overlap.Rd0000644000176200001440000000250614704176606015127 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.Rd0000644000176200001440000002033215151511631016401 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.data.frame} \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}{data.frame}(x, threshold = "default", rvar_col = NULL, ...) \method{p_significance}{brmsfit}( x, threshold = "default", effects = "fixed", component = "conditional", 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, which can have following possible values: \itemize{ \item \code{"default"}, in which case 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 a single numeric value (e.g., 0.1), which is used as range around zero (i.e. the threshold range is set to -0.1 and 0.1, i.e. reflects a symmetric interval) \item a numeric vector of length two (e.g., \code{c(-0.2, 0.1)}), useful for asymmetric intervals \item a list of numeric vectors, where each vector corresponds to a parameter \item a list of \emph{named} numeric vectors, where names correspond to parameter names. In this case, all parameters that have no matching name in \code{threshold} will be set to \code{"default"}. }} \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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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}. } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("rstanarm")) withAutoprint(\{ # 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) # multiple thresholds - asymmetric, symmetric, default p_significance(model, threshold = list(c(-10, 5), 0.2, "default")) # named thresholds p_significance(model, threshold = list(wt = 0.2, `(Intercept)` = c(-10, 5))) } \dontshow{\}) # examplesIf} } bayestestR/man/bayesfactor_restricted.Rd0000644000176200001440000002643115203314503020175 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{bayesfactor_restricted.matrix} \alias{bayesfactor_restricted.data.frame} \title{Bayes Factors (BF) for Order Restricted Models} \usage{ bayesfactor_restricted(posterior, ...) bf_restricted(posterior, ...) \method{bayesfactor_restricted}{stanreg}( posterior, hypothesis, prior = NULL, verbose = TRUE, effects = "fixed", component = "conditional", ... ) \method{bayesfactor_restricted}{brmsfit}( posterior, hypothesis, prior = NULL, verbose = TRUE, effects = "fixed", component = "conditional", ... ) \method{bayesfactor_restricted}{blavaan}( posterior, hypothesis, prior = NULL, verbose = TRUE, ... ) \method{bayesfactor_restricted}{emmGrid}( posterior, hypothesis, prior = NULL, verbose = TRUE, ... ) \method{bayesfactor_restricted}{matrix}( posterior, hypothesis, prior = NULL, verbose = TRUE, ... ) \method{bayesfactor_restricted}{data.frame}( posterior, hypothesis, prior = NULL, rvar_col = NULL, ... ) } \arguments{ \item{posterior}{A \code{stanreg} / \code{brmsfit} object, \code{emmGrid} or a data frame - representing a posterior distribution(s) from (see Details).} \item{...}{Currently not used.} \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{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} } \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, 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). \subsection{Additional methods}{ The resulting output is supported by the following methods: \itemize{ \item \code{as.matrix()}: Extract a full matrix of (log-)Bayes factors between all models (using the transitivity of Bayes factors). \item \code{as.logical()}: Extract boolean vectors indicating which (prior/posterior) samples are included in the hypothesized restriction. \item \code{as.numeric()}: Extract the (possibly log-)Bayes factor values. } See examples and \link{bayesfactor_methods}. } } \section{Obtaining prior samples}{ It is important to provide the correct \code{prior} for meaningful results, to match the \code{posterior}-type input: \itemize{ \item \strong{A numeric vector} - \code{prior} should also be a \emph{numeric vector}, representing the prior-distribution \item \strong{A data frame} - \code{prior} should also be a \emph{data frame}, representing the prior-estimates, in matching column order. \itemize{ \item If \code{rvar_col} is specified, \code{prior} should be \emph{the name of an \code{rvar} column} that represents the prior-estimates. } \item \strong{Supported Bayesian model (\code{stanreg}, \code{brmsfit}, etc.)} \itemize{ \item \code{prior} should be \emph{a model an equivalent model with MCMC samples from the priors \strong{only}}. See \code{\link[=unupdate]{unupdate()}}. \item If \code{prior} is set to \code{NULL}, \code{\link[=unupdate]{unupdate()}} is called internally (not supported for \code{brmsfit_multiple} model). } \item \strong{Output from a \code{{marginaleffects}} function} - \code{prior} should also be \emph{an equivalent output} from a \code{{marginaleffects}} function based on a prior-model (See \code{\link[=unupdate]{unupdate()}}). \item \strong{Output from an \code{{emmeans}} function} \itemize{ \item \code{prior} should also be \emph{an equivalent output} from an \code{{emmeans}} function based on a prior-model (See \code{\link[=unupdate]{unupdate()}}). \item \code{prior} can also be \emph{the original (posterior) model}, in which case the function will try to "unupdate" the estimates (not supported if the estimates have undergone any transformations -- \code{"log"}, \code{"response"}, etc. -- or any \code{regrid}ing). } } } \section{Transitivity of Bayes factors}{ For multiple inputs (models or hypotheses), the function will return multiple Bayes factors between each model and \emph{the same} reference model (the \code{denominator} or un-restricted model). However, we can take advantage of the transitivity of Bayes factors - where if we have two Bayes factors for Model \emph{A} and model \emph{B} against the \emph{same reference model C}, we can obtain a Bayes factor for comparing model \emph{A} to model \emph{B} by dividing them: \cr\cr \deqn{BF_{AB} = \frac{BF_{AC}}{BF_{BC}} = \frac{\frac{ML_{A}}{ML_{C}}}{\frac{ML_{B}}{ML_{C}}} = \frac{ML_{A}}{ML_{B}}} \cr\cr (Where \emph{ML} is the \emph{marginal likelihood}.) \cr\cr A full matrix comparing all models can be obtained with \code{as.matrix()}. } \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). See also \code{effectsize::interpret_bf()}. } \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)) # See the matrix of BFs as.matrix(b) bool <- as.logical(b, which = "posterior") head(bool) \dontshow{if (require("see") && require("patchwork")) withAutoprint(\{ # 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")) withAutoprint(\{ # 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")) withAutoprint(\{ # 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/. } } \seealso{ Other Bayes factors: \code{\link{bayesfactor_inclusion}()}, \code{\link{bayesfactor_models}()}, \code{\link{bayesfactor_parameters}()} } \concept{Bayes factors} bayestestR/man/point_estimate.Rd0000644000176200001440000002044415151511631016470 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.data.frame} \alias{point_estimate.brmsfit} \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}{data.frame}( x, centrality = "all", dispersion = FALSE, threshold = 0.1, rvar_col = NULL, ... ) \method{point_estimate}{brmsfit}( x, centrality = "all", dispersion = FALSE, effects = "fixed", component = "conditional", parameters = NULL, ... ) \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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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}. } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")) withAutoprint(\{ # 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.Rd0000644000176200001440000000173014357736006015137 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.Rd0000644000176200001440000000232114447573266015367 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.Rd0000644000176200001440000000574415151511631015573 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, or a frequentist regression model.} \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")) withAutoprint(\{ # 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.Rd0000644000176200001440000001355515052400212014725 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.data.frame} \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}{data.frame}(x, range = "default", rvar_col = NULL, verbose = TRUE, ...) \method{p_rope}{brmsfit}( x, range = "default", effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ... ) } \arguments{ \item{x}{Vector representing a posterior distribution. Can also be a \code{stanreg} or \code{brmsfit} model.} \item{...}{Other arguments passed to \code{\link[=rope]{rope()}}.} \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. For models with one response, \code{range} can be: \itemize{ \item a vector of length two (e.g., \code{c(-0.1, 0.1)}), \item a list of numeric vector of the same length as numbers of parameters (see 'Examples'). \item a list of \emph{named} numeric vectors, where names correspond to parameter names. In this case, all parameters that have no matching name in \code{range} will be set to \code{"default"}. } In multivariate models, \code{range} should be a list with another list (one for each response variable) of numeric vectors . 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. See 'Examples'.} \item{verbose}{Toggle off warnings.} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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)}. } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \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.Rd0000644000176200001440000000057014266336540021217 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.Rd0000644000176200001440000000457115151511631017673 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)) withAutoprint(\{ # 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.Rd0000644000176200001440000001400015174322463014236 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.data.frame} \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}{data.frame}(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) \method{spi}{brmsfit}( x, ci = 0.95, effects = "fixed", component = "conditional", 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} (95\%).} \item{verbose}{Toggle off warnings.} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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")) withAutoprint(\{ # 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{eti}()}, \code{\link{hdi}()}, \code{\link{si}()} } \concept{ci} bayestestR/man/display.describe_posterior.Rd0000644000176200001440000000536615151511631021004 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/display.R, R/print.R, R/print_html.R, % R/print_md.R \name{display.describe_posterior} \alias{display.describe_posterior} \alias{print.describe_posterior} \alias{print_html.describe_posterior} \alias{print_md.describe_posterior} \title{Print tables in different output formats} \usage{ \method{display}{describe_posterior}(object, format = "markdown", ...) \method{print}{describe_posterior}(x, digits = 2, caption = "Summary of Posterior Distribution", ...) \method{print_html}{describe_posterior}(x, digits = 2, caption = "Summary of Posterior Distribution", ...) \method{print_md}{describe_posterior}(x, digits = 2, caption = "Summary of Posterior Distribution", ...) } \arguments{ \item{object, x}{An object returned by one of the package's function, for example \code{\link[=describe_posterior]{describe_posterior()}}, \code{\link[=point_estimate]{point_estimate()}}, or \code{\link[=eti]{eti()}}.} \item{format}{String, indicating the output format. Can be \code{"markdown"} \code{"html"}, or \code{"tt"}. \code{format = "tt"} creates a \code{tinytable} object, which is either printed as markdown or HTML table, depending on the environment. See \code{\link[insight:export_table]{insight::export_table()}} for details.} \item{...}{Arguments passed down to \code{print_html()} or \code{print_md()} (e.g., \code{digits}), or to \code{insight::export_table()}.} \item{digits}{Integer, number of digits to round the table output. Defaults to 2.} \item{caption}{Character, caption for the table. If \code{NULL}, no caption is added. By default, a caption is created based on the object type.} } \value{ If \code{format = "markdown"}, the return value will be a character vector in markdown-table format. If \code{format = "html"}, an object of class \code{gt_tbl}. If \code{format = "tt"}, an object of class \code{tinytable}. } \description{ Prints tables (i.e. data frame) in different output formats. } \details{ \code{display()} is useful when the table-output from functions, which is usually printed as formatted text-table to console, should be formatted for pretty table-rendering in markdown documents, or if knitted from rmarkdown to PDF or Word files. See \href{https://easystats.github.io/parameters/articles/model_parameters_formatting.html}{vignette} for examples. } \examples{ \dontshow{if (all(insight::check_if_installed(c("tinytable", "gt"), quietly = TRUE))) withAutoprint(\{ # examplesIf} \donttest{ d <- data.frame(replicate(4, rnorm(20))) result <- describe_posterior(d) # markdown format display(result) # gt HTML display(result, format = "html") # tinytable display(result, format = "tt") } \dontshow{\}) # examplesIf} } bayestestR/man/bayesfactor_inclusion.Rd0000644000176200001440000001117615203314503020030 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 \cr\cr The \verb{bf_*} function is an alias of the main function. \cr\cr \strong{For more info, see \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}.}} \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{ Inclusion Bayes Factors for testing predictors across Bayesian models \cr\cr The \verb{bf_*} function is an alias of the main function. \cr\cr \strong{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 contain the main effect terms from which the interaction term is comprised. } \subsection{Additional methods}{ The resulting output is supported by the following methods: \itemize{ \item \code{as.numeric()}: Extract the (possibly log-)Bayes factor values. } See \link{bayesfactor_methods}. } } \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). See also \code{effectsize::interpret_bf()}. } \examples{ \dontshow{if (require("BayesFactor")) withAutoprint(\{ # 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. Other Bayes factors: \code{\link{bayesfactor_models}()}, \code{\link{bayesfactor_parameters}()}, \code{\link{bayesfactor_restricted}()} } \author{ Mattan S. Ben-Shachar } \concept{Bayes factors} bayestestR/man/p_map.Rd0000644000176200001440000002051015151511631014532 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.data.frame} \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}{data.frame}(x, null = 0, precision = 2^10, method = "kernel", rvar_col = NULL, ...) \method{p_map}{brmsfit}( x, null = 0, precision = 2^10, method = "kernel", effects = "fixed", component = "conditional", 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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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. } } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")) withAutoprint(\{ # 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.Rd0000644000176200001440000000125114266336540020013 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.Rd0000644000176200001440000001000215151511631015733 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 = "fixed", 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 variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \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")) withAutoprint(\{ # examplesIf} \dontrun{ library(bayestestR) prior <- distribution_normal(1000, mean = 0, sd = 1) posterior <- distribution_normal(1000, mean = 0.5, sd = 0.3) bayesfactor(posterior, prior = prior, verbose = FALSE) # 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.Rd0000644000176200001440000002103615204535252017700 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} \title{Posteriors Sampling Diagnostic} \usage{ diagnostic_posterior(posterior, ...) \method{diagnostic_posterior}{default}(posterior, diagnostic = "all", ...) \method{diagnostic_posterior}{stanreg}( posterior, diagnostic = "all", effects = "fixed", component = "location", parameters = NULL, centrality = "median", ... ) } \arguments{ \item{posterior}{A \code{stanreg}, \code{stanfit}, \code{brmsfit}, or \code{blavaan} object; a list of data frames or matrices representing MCMC chains (rows as samples, columns as parameters); or a 3D array (dimensions: samples, chains, parameters)} \item{...}{Currently only used for models of class \code{brmsfit}, where a \code{variable} argument can be used, which is directly passed to the \code{as.data.frame()} method (i.e., \code{as.data.frame(x, variable = variable)}).} \item{diagnostic}{Diagnostic metrics to compute. Character (vector) or list with one or more of these options: \code{"ESS"}, \code{"ESS_bulk"}, \code{"Rhat"}, \code{"MCSE"} or \code{"all"}. \code{"ESS"} returns the \strong{tail-ESS} (the minimum of the effective sample sizes for the 5\% and 95\% quantiles), which is the most relevant diagnostic for assessing the reliability of credible intervals and other tail-based quantities. \code{"ESS_bulk"} additionally returns the \strong{bulk-ESS} (the effective sample size for the bulk of the posterior, useful for assessing the reliability of central tendency estimates such as the mean or median). \code{"all"} includes both tail and bulk \code{"ESS"}, \code{"Rhat"}, and \code{"MCSE"}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, the instrumental variables or marginal effects be returned? Applies to models with zero-inflated and/or dispersion formula, or to models with instrumental variables (so called fixed-effects regressions), or models with marginal effects (from \strong{mfx}). See details in section \emph{Model Components} .May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \item{parameters}{Regular expression pattern that describes the parameters that should be returned.} \item{centrality}{The point-estimate (centrality index) for which to compute the MCSE. Can be \code{"median"} (default) or \code{"mean"}. To not break other functions like \code{describe_posterior()} or \code{diagnostic_posterior()}, all other values are silently converted to \code{"median"}.} } \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 returned by \code{diagnostic_posterior()} is the \strong{tail-ESS}: it corresponds to the minimum of the effective sample sizes for the 5\% and 95\% quantiles, and is a diagnostic for the sampling efficiency in the tails of the posterior distribution. It is more relevant than the bulk-ESS for assessing the reliability of credible intervals, probabilities of direction, and other tail-based quantities. Note that the tail-ESS may differ from the ESS reported by \code{brms} (\code{Bulk_ESS}) or other tools; use \code{"ESS_bulk"} to also retrieve the bulk-ESS. \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". } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("rstanarm") && require("brms")) withAutoprint(\{ # 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} \dontshow{if (require("rstan")) withAutoprint(\{ # examplesIf} set.seed(101) mkdata <- function(nrow = 1000, ncol = 2, parnm = LETTERS[1:ncol]) { x <- as.data.frame(replicate(ncol, rnorm(nrow))) names(x) <- parnm x } dd <- replicate(5, mkdata(), simplify = FALSE) diagnostic_posterior(dd) \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.Rd0000644000176200001440000001613315151511631016114 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.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", verbose = TRUE, ...) \method{map_estimate}{brmsfit}( x, precision = 2^10, method = "kernel", effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ... ) \method{map_estimate}{data.frame}( x, precision = 2^10, method = "kernel", rvar_col = NULL, verbose = TRUE, ... ) \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{verbose}{Toggle off warnings.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \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 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"}). } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("rstanarm") && require("brms")) withAutoprint(\{ # 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.Rd0000644000176200001440000002431115203314503014051 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.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 = "fixed", component = "location", parameters = NULL, ... ) \method{si}{get_predicted}( posterior, prior = NULL, BF = 1, use_iterations = FALSE, verbose = TRUE, ... ) \method{si}{data.frame}(posterior, prior = NULL, BF = 1, rvar_col = NULL, 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 variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} } \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}. \cr\cr \strong{For more info, see \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}.} } \details{ This method is used to compute support intervals based on prior and 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}. } \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{Prior and posterior considerations}{ 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. \cr\cr 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}) (Note that by default, \code{brms::brm()} uses flat priors for fixed-effects); Wide priors result in smaller marginal likelihoods, and thus models with wider priors are trivially less likely than models with narrower priors - where, at the extreme, that a model with completely flat priors is infinitely less favorable than a point null model (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 Additionally, for models using MCMC estimation 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, a warning is issued. } \section{Obtaining prior samples}{ It is important to provide the correct \code{prior} for meaningful results, to match the \code{posterior}-type input: \itemize{ \item \strong{A numeric vector} - \code{prior} should also be a \emph{numeric vector}, representing the prior-distribution \item \strong{A data frame} - \code{prior} should also be a \emph{data frame}, representing the prior-estimates, in matching column order. \itemize{ \item If \code{rvar_col} is specified, \code{prior} should be \emph{the name of an \code{rvar} column} that represents the prior-estimates. } \item \strong{Supported Bayesian model (\code{stanreg}, \code{brmsfit}, etc.)} \itemize{ \item \code{prior} should be \emph{a model an equivalent model with MCMC samples from the priors \strong{only}}. See \code{\link[=unupdate]{unupdate()}}. \item If \code{prior} is set to \code{NULL}, \code{\link[=unupdate]{unupdate()}} is called internally (not supported for \code{brmsfit_multiple} model). } \item \strong{Output from a \code{{marginaleffects}} function} - \code{prior} should also be \emph{an equivalent output} from a \code{{marginaleffects}} function based on a prior-model (See \code{\link[=unupdate]{unupdate()}}). \item \strong{Output from an \code{{emmeans}} function} \itemize{ \item \code{prior} should also be \emph{an equivalent output} from an \code{{emmeans}} function based on a prior-model (See \code{\link[=unupdate]{unupdate()}}). \item \code{prior} can also be \emph{the original (posterior) model}, in which case the function will try to "unupdate" the estimates (not supported if the estimates have undergone any transformations -- \code{"log"}, \code{"response"}, etc. -- or any \code{regrid}ing). } } } \examples{ \dontshow{if (require("logspline") && require("rstanarm") && require("brms") && require("emmeans")) withAutoprint(\{ # 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{eti}()}, \code{\link{hdi}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/density_at.Rd0000644000176200001440000000170714447573266015633 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.Rd0000644000176200001440000000103215033776022015475 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} \alias{display} \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}}, \code{\link[insight:display]{print_html}}, \code{\link[insight:display]{print_md}}} }} bayestestR/man/weighted_posteriors.Rd0000644000176200001440000001663715005370052017544 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.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 = "fixed", component = "conditional", 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 variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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.Rd0000644000176200001440000000205114502413050016631 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/pd_to_p.Rd0000644000176200001440000000424614677160501015102 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{pd_to_p.numeric} \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, ...) \method{pd_to_p}{numeric}(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, ...) } \arguments{ \item{pd}{A Probability of Direction (pd) value (between 0 and 1). Can also be a data frame with a column named \code{pd}, \code{p_direction}, or \code{PD}, as returned by \code{\link[=p_direction]{p_direction()}}. In this case, the column is converted to p-values and the new data frame is returned.} \item{...}{Arguments passed to or from other methods.} \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{p}{A p-value.} } \value{ A p-value or a data frame with a p-value column. } \description{ Enables a conversion between Probability of Direction (pd) and p-value. } \details{ Conversion is done using the following equation (see \emph{Makowski et al., 2019}): When \code{direction = "two-sided"} \ifelse{html}{\out{p = 2 * (1 - pd)}}{\eqn{p = 2 \times (1 - p_d)}} When \code{direction = "one-sided"} \ifelse{html}{\out{p = 1 - pd}}{\eqn{p = 1 - p_d}} 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 \code{\link[=p_direction]{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.Rd0000644000176200001440000000222114766532531015277 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unupdate.R \name{unupdate} \alias{unupdate} \alias{unupdate.brmsfit} \alias{unupdate.brmsfit_multiple} \title{Un-update Bayesian models to their prior-to-data state} \usage{ unupdate(model, verbose = TRUE, ...) \method{unupdate}{brmsfit}(model, verbose = TRUE, ...) \method{unupdate}{brmsfit_multiple}(model, verbose = TRUE, newdata = NULL, ...) } \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.Rd0000644000176200001440000002272615174322463014225 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.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, rvar_col = NULL, verbose = TRUE, ...) \method{hdi}{brmsfit}( x, ci = 0.95, effects = "fixed", component = "conditional", 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} (95\%).} \item{verbose}{Toggle off warnings.} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{\link[=eti]{eti()}}) that typically exclude 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. 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.5th 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. The \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{95\% or 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). } \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{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (all(insight::check_if_installed(c("rstanarm", "brms", "emmeans", "BayesFactor"), quietly = TRUE))) withAutoprint(\{ # examplesIf} library(bayestestR) posterior <- rnorm(1000) hdi(posterior, ci = 0.89) hdi(posterior, ci = c(0.80, 0.90, 0.95)) hdi(iris[1:4]) 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) ) hdi(model) hdi(model, ci = c(0.80, 0.90, 0.95)) hdi(emmeans::emtrends(model, ~1, "wt", data = mtcars)) model <- brms::brm(mpg ~ wt + cyl, data = mtcars) hdi(model) hdi(model, ci = c(0.80, 0.90, 0.95)) bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) hdi(bf) 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()}}. Other ci: \code{\link{bci}()}, \code{\link{ci}()}, \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.Rd0000644000176200001440000003064515174322463014425 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.data.frame} \alias{rope.stanreg} \alias{rope.brmsfit} \title{Region of Practical Equivalence (ROPE) Analysis} \usage{ rope(x, ...) \method{rope}{numeric}( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, verbose = TRUE, ... ) \method{rope}{data.frame}( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, rvar_col = NULL, verbose = TRUE, ... ) \method{rope}{stanreg}( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, effects = "fixed", component = "location", parameters = NULL, verbose = TRUE, ... ) \method{rope}{brmsfit}( x, range = "default", ci = 0.95, ci_method = "ETI", complement = FALSE, effects = "fixed", component = "conditional", 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. For models with one response, \code{range} can be: \itemize{ \item a vector of length two (e.g., \code{c(-0.1, 0.1)}), \item a list of numeric vector of the same length as numbers of parameters (see 'Examples'). \item a list of \emph{named} numeric vectors, where names correspond to parameter names. In this case, all parameters that have no matching name in \code{range} will be set to \code{"default"}. } In multivariate models, \code{range} should be a list with another list (one for each response variable) of numeric vectors . 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. See 'Examples'.} \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{complement}{Should the probabilities above/below the ROPE (the \emph{complementary} probabilities) be returned as well? See \code{\link[=equivalence_test]{equivalence_test()}} as well.} \item{verbose}{Toggle off warnings.} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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 CI (default to the 95\% ETI) 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 \code{\link[=rope_range]{rope_range()}} function. Kruschke (2010, 2011, 2014) suggests using the proportion of \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. } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (all(insight::check_if_installed(c("rstanarm", "emmeans", "brms", "BayesFactor"), quietly = TRUE))) withAutoprint(\{ # 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{ model <- suppressWarnings( rstanarm::stan_glm(mpg ~ wt + gear, data = mtcars, chains = 2, iter = 200, refresh = 0) ) rope(model) rope(model, ci = c(0.90, 0.95)) # multiple ROPE ranges rope(model, range = list(c(-10, 5), c(-0.2, 0.2), "default")) # named ROPE ranges rope(model, range = list(gear = c(-3, 2), wt = c(-0.2, 0.2))) rope(emmeans::emtrends(model, ~1, "wt"), ci = c(0.90, 0.95)) model <- brms::brm(mpg ~ wt + cyl, data = mtcars, refresh = 0) rope(model) rope(model, ci = c(0.90, 0.95)) model <- brms::brm( brms::bf(brms::mvbind(mpg, disp) ~ wt + cyl) + brms::set_rescor(rescor = TRUE), data = mtcars, refresh = 0 ) rope(model) rope(model, ci = c(0.90, 0.95)) # different ROPE ranges for model parameters. For each response, a named # list (with the name of the response variable) is required as list-element # for the `range` argument. rope( model, range = list( mpg = list(b_mpg_wt = c(-1, 1), b_mpg_cyl = c(-2, 2)), disp = list(b_disp_wt = c(-5, 5), b_disp_cyl = c(-4, 4)) ) ) bf <- BayesFactor::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/0000755000176200001440000000000015204544512014620 5ustar liggesusersbayestestR/man/figures/unnamed-chunk-10-1.png0000644000176200001440000026054015174322463020453 0ustar liggesusersPNG  IHDR `oԒa'IDATx à7h@7n "q@ ' "q@ ' "q@ ' "q@ ' "q@ ' "q@ ' "q@ ' "q@ ' "k2G "s 0' "s 0' "s 0' "s @=KUs= b`AC MA,"ࠓO+zApuMAQ oWAH9@ DRN r+@dgar0{V.?ܨݥ|.{UN )`#:Su¢ܬ;(0zږz 9_2hN@T}`޺D>ͣ6D1"¸[sJwui\ ~4)@@MM#]>"]OB-"aɫ_ߟ߿~|Z8 |ic㬮<`B+ m^uUղqAYSr[l]vnjbzdYG=*sfT""Z(j:sίzTs!1n93_xwUK 9\==ɥ" ]j=v R=i٭Zr_|!\K",v^7~fp*e7̨_@}UWE@ܼӗLxӬ{m+C)W ,*D^Y(#]cE#}w/1r.ɽ>n8K==fP*ޘ^n(#_O\e@ DrΨ[#.Mj'5 .*D6N?Iq ]_+ɭg;.5`aㄚŅs r8$B^mjܒ 'ɮkH?V؇ ?PԜPT`q(#?+ Ry }HT $_T\C"@97oC^y!{F 2ׯn ʡ \S[T[5*D2Ҳِ?Ygk3]匉I䠱5C msTeclCg30:I Tޗ n/jv)D]Q!?ְ)%t"@ Dv>Vw.qB'"ۗx=J]yŗl[oz~)%t@dDz!~ґ._|iYB(imV|g_ylsue%(.s?'&ݿ9~O57R D]毳1_mQ p[c\5>]P(J~iOn3/]ԇznrKerA$'#:[Y*P +b .>`mvKO~󃋺!Czd^uXeq!2O+DD}ϬGjF}NлK]EU.s"WUQȫ8˫3_yaڮDk p0I3[⽑|٩SQ(u99r1@DuN(%E?PV(D DuLBɾ(:n y3*p$_%(@wo̸2 yQ7"J]v]Cm܆Z@)K}WD֕wݽ*A"5 H?#!/⊟mdVׯn R7ꗾJ[ՙ+zw7N0i{&B&%_wn8" yMӋ@I:g-M[\:^ Dݽ/!G})tB9釷Uu* Dr;[@ DZV%Ga/%SK!μr!/ +ٱnƫِKGcjO/.DgoT _~nɗĈ_cΪ7[Ámza=ߚ+'?vډߵp[mA^uM>G cqIʽ}W͡Q(:oCo۵Q Z6 j۸O8$]DGRf[r[ wOD=D_pWn.'a&l_ϝzQ(UZb 2L Dr~<tSm~ɾry"]ϻAcGnE=No}pCzDE^~K93 Dγk= מڧsԱy)G Se.8?.*fi⍁K55 tSg J֦fYrӖsfyI^M$P)-pX &3rP~<ǁ?~y0DAD?O"jC!&/cn  4w/ F5YnJxc?;m6׼j;,|Tn﫨Mꉧ罼 2?[ ntT " OєNP9((`,7^L  FpbCztN{uO<~'Dᨛ;d3C:2gњ8-+w)aǧdMݳ,n@R3m`D~m&C}=;}Ϋog?yDA0JAxg, }b5(Q.E=˫ݳjb;#(>GL]:"e JA-LD%%v)-zqʷ7n\ǏHh**>[p3h2F%\~kpOb8"\Lݧsݾ䑁mٸЙe-Unx\3Mۑe>5 "epYƌ"qeisY`fEx)^>gؗvu Qիn_NAC "`TDdw[IZc/sY !ϓ~쳿?jObntm兪:9Y+guKHH @=e4BQVVV\o\( Ȭ=I\{˲n QK<8l5CO;lҲc0l{MyAzAA!ʸQFZZL*]l[M8I2QVzDNjt۶T%?kY8Mz̵;?g]=a&zKJ*A0( "25&s*KuQ7R8:'t6Xw<&%DE1_*:Ƨ7f=r_漲T~ʒ}螋{tH2DAAgNqr+HlZd/\ 8M ;2"b,L'_;Rıs~;aڲW|#4 `(DC !h4XK*9TnyBwQZYߺVbyj;RRLVٷJQkoYZrC0$ YIapRcR_;`5=3=AkBfy^v6߱w'xB%jmTja/|{9=3-3ѣQUU%D5HKK>rrr$2AAB/_?ɓGw8;T^ ŏ;X֏k 7-n6<߹Bؙv/#!D.vUeZ]X|&2(Ŋ+SJ$8"Y{MlR%yKYj+E7庸pa~6OؤBJkő—y%R2›!<-kW~?&m"s'ąs3'=zn4S;KtD a]Rkvc\w9:nI 6.\ W H"-'n.`yC^mۚcO'm(+fbePODInn"EEEH#)..^#;;[%$R".:uJOOpQ `pD QcN`3mXC"XIYmv'q'(N P@8@q" D'r ^צq`9"k&r9~vݱu] L.Y P@8@q" D'(N P@8@q" D\>ϥ~ q/ D~4M0 @5q: z I7 ;&r(Dha1Ӑ;\֝~ǟ7x<@r" D$'HN @ 9@r" Dcim8`TynZ\'nβ,0u]kgN @ DRޝz>N5#ߠ2s A 9@r" D$'HN @ 9@r" Dcve QZ;4uv}:q:?vA [DI, Xbcl$2 eX]q[ @ pg)) @ 9@r" D$'HN @ 9@r" Dl):SX%3Mӫ0sj]WaN @ Dt].mj]>1sjY1 @ pg/0+z|>ߍRJt=97a螃@r" D$'HN @ 9@r" D$'2MSiZ4q "l۶6}^DZ6jp@;{@ON ~O="MPFG2J0 T` l]GBeYmwstpppppppppppp-@8u]ߍm }ߍeYw"DL x<~q\+R@&!Au0@z" D'(N P@8@q" D'/;wL0 P2I4JI 1PnW=_'ri;y@Vu;@mjg8Y%~'@ @"@.WgjW)= WRʺ" N 08"58 ܯ0@U(%AjPa*JEpD "bbA4B"7 l64Gw ~2֡1OL"LITkƧztչW:ZIyTte{N.dďPe\*#11Q8N % D.&>~Y'wM#؇ҏ*#k: 3cr]LpOF`H"XU" }P]ǭ}\Ԯ}ԕe>|"1'Bӯ/۲ WrT1 @$8/^OzzUFC2 ~-Z̓뒚ڤeC_o=靜ՕSє:Q1{WjC2 iӦ yTU@$(RSSԩS5H6M[)"bk0xlr:='?@CDD^J[{EDǾ8H?g^zWߐhH`=T+b G7zVخ6~dK\Dt S""ރo푊3q03,})KTI]Jtby IPe,p{;t,\=fWbr?x+C*{`~n;QRoX U ؼٻhq\ۧG~U^W~TXщMuۆKyTXCI xHTӧk?FJQePe< ̙3jœ}3S[5I®&""ڽATLTb⃃?5;Ӻ=R2 6h.eS [ĭE١&l-"n/2&]ĐJ2@>]DD̼Lޜϲ"""ig0R9mISD697stCKX#&GC.8Xb޵;CDDº%[iG Q6#m4fPB&"~oDDw#SW\Wڤ⊝ PMxc)!&"4!y`~ ''''϶mC|qhݫ?V^EDo]*ZDl o:uCSY!33s, f޽SdddTXj:{J5 RU$21en-" wsYzRI|eg""΍\.$ 1A(D| h;,>+?4>n 8ѭmr7SWJݘuRyY8i|_2 [^ml"=ߦ=30إ"?ڌ~QRރ|=|ehfM:th-x@QePe ={\dӽ{wI!o=}[E)_;ɵ2y=f,|7YU0scf`!'~\.Aq)Dt:5` K} Ws9 滟JRH"|T Dbav^jZ;q0>]&6\BHevhS"U0KAGF? " D'N @ 8@p" DuV)j[ap@o&Ҷ4M~KUM5_'{Iճ @ 8@p" D'N @ 8@p" DmK9eYu䜟8@|}O D?;wl0Pt :XZ KD .6% D\q|vcd5 ós: Md`ݶ =" D'(N P@8@q" D'r֙9Zy^=:ux  @ f n;!R@& Zk9s(N P@8@q" D'(N P@8@q7;woPa-Grp -3Api3Q NB {>gr ml6 ESNp;pWt:@Vp8v"DSdq}zy@r D*'@r D*'@r D*'@e^v]d? *n'r|/l6jݾyN @#F0 ix< `0L ="u`s]}#QLHo"tD#dO:C4"@~D#}'(tUhDF* FF\t|hD;6q0<5`gvr-F5bp ۃeXnM.cwͯyfx~xyЈDR,@\ ԓ1FDd;F%@ '2{f=3c$r:֙Ju\֙񘂓wR D0"2" ;@`&@ ZE Tg2:%[VvM D>ӶmBqjt]zy(A@ @ c * Pr"w>&"L_ A`$I"C D|aR(@/'"@un!s@a8dkO TgHz>oFD`>@$͗D$=@T)h,ϴmpeJ4M.G(jv xD,y練 5M"ش \K Zuj¸"!xP EB2&[р"lfgΩ`TM P8@ #/Vf @@  "Dnq@ Pl@n`{M\.z}MO Tg=%ct:=%m'W]| @@A @ LH۶/|j%X,GM K;=>/׶f P8]: {)Wf!FaP@"5+3P@@ j ( @$,0}b"UN eZ5~Yo~ph2l= j}B0 ]@wč .l B ].t kA eRB^% mdٳ3S?7_wtUyɳ 7Ė@ s<m2`"dN 9i>UML""'0CRtU@"i9Nۉnۉ99Ru\^'}$N "Q "WK 8~k%gӿUj"?oߋ>-{weq}I* 4c4L3MƓPA55<KQDEg*VH@GQQ@E`']v_xyc`>up @mR1;ǻe1]- qԸay58tʔsf JOyDԞS5j5":ASB(Tܹ0'k A*4I %LEgԅ~ijY3פ]`u"y,rʟc"{ ?iю7*$~[3k=: ֭H>S:*P[-#vj@nRªYúUY"oi역6l{-GKPP|5vR_=o>e`up4蘭i*K6Wջ URZZ*<> FuU 7pтr"U)e0I }%j~ onwt\C:6l)lF\[ `@Y &z5{1}',~z e}0"鲔\Ψ]YawfUXaA"yvwrW tw%dsW@D{ B B 1e'Q n.5 e"³FGjGz-C~"."ʧ̒@@0_}}̘>uB: ZujVIaIWjB |,9hD<9!+y=ԑAz5٭U!Q>e4"8Kx"IlM>_&l>$_WEINzRܪk7sJ,(?>{G6HςmIlO˺iy٦[>{Ic)>q~{p!Ju' zZ(23*;}N;WuѪ3¾Ҭ]k?Q SfA G w->?ݵ({56IͫGX[[eA*XEp">nAtAA.( Z>s b& xc?=_זl5}a.إ%?ⷾw q>gf" e=zxG,8vk#^}}xΘ?eݩ{6 sfA#8%\{;' SfMhwL lJ\*BРƕB)@}bq0!FD@]5=W*1#wά_9q( & 6ۧ֜k/qjMfmuPS)LN Dj;ޚ 5ɏд: ib95eì@ NšZ_ [@XzT *h~" `oOGVú+7Y|7mkEbsߕ{#ڹ"dnԼ284֑ yg,Ւ1ҝgcUQ*hUX  ekV[sLU`/(*O}gYߴZhViEn B\-u,((CSi'Pbh<|ˏsFǾ>C81ێN=,Lw!p]p:Pf%X{r`o.~i8y` D~о]{?a= #d^ N7r~W- 7HR5EDQP+~Fu_/e[{|᝱Xo+wJJ3Aux_;=*Ѧ%Р\.G]/Ll6 ˃ޏ-87[WSޝEYwPdQATDHdiRbb{L;mcjjY<-f5pAI4MYřa}0,G u_~$%Ξm^*B!ʰMVƒ3f?C:j"~G;W>HZׁ9UWO{Úm/pE:3guCa={ڼmp \1 NǛ#&xu3'R~Kؽz kAQS6\t[ޟ5^i9 2A4²ss}}Cv;iwq\Z>:U+^<\4n]?>UGsjBdG؋ˏ痔3*Ѕˮl 2ťUpԇ1נVƟ/3Vuٰf9Iz~xiu*1+H\9m% Ÿu:yNO'2qotyI?F~Nz{s^M.uBuj98lFB@YwbzV7q(8o*?!od*vqP|1zhD `Q PDjcr (؀tH "McgA<~ZEs6uOīDc^]_r|fdί2pP|13 hpLmJ%ɄQ~UU~tO\17y U&txtL_gF7H׎9'b Ѹhf7"Y0OIsWKXPחdgI},aQgKWtȑ˨3bTUi='UۡPeN'232BH-K陖ĩAjjɄ3UZy@&L#) ȌQ-8Se]w_]y7svv׿K~f_ޚKr1h,̴ Blr4ݣTawnLSP((4B*zM e/ ^p(>H2}Z2jZe^'P gS5w򶑓_}g~mH_`-GRK6ݺue+,Ȓe>\-yGxDoWnR ~54(> e74K R(ƙKܟX1MTdKIƵ׵IU[37fL:N5$5nyoB[zȻlޙék֬9b_pp00;ЈXs?e$k>,Q#=Dj!xxy$^xUG6ʏwU73UC*/Rռ#=‚RN5 ]b{sFH0ldc ) /*,dt΃:ns_gUC,+a#@hmvmTnUa}6d"% mܦg]<"L0~$=Z('CBt̙VO6p D\+,rgZV7LȖtaڄrn "`^Z fe>b7SH'59&@2In;wi%))TZ dbLyY#Y/ sќa2n!?MmNw cqMO;Q1[0~F?FRnJnȺuD ۪D*1?]@?9b#7H?F|nؔ yAÆww2e@qӓmZ/@Ĭ #+L:0o͓k#)j]ʜO^U([']^!>Ήv벗F?(UǗv lfm?yߚPj͚5\7jXcAL4u_R=?O3#+޹)F,2싎&+\bccʌ3x XTU` "u| #Qf Nlݸ?%_ǭC&~RuXttwSuq N!+#?ɨ^zw|m-_b *2ܮc72)Q6 R%͓81v`[ɥcUC7kՑ]/ &"1v`@ap 4!ygSF ޾:!~T~1~+="1ޟ%&}:b3_8_l$"B0esd:y1'?yDv6嫱aa^c.?@K&k8)`!:1(DqNnA1#2p2)J5pnf*"NtCHoО)$=-N'ϋ/ bp}rsSr{)Y=Ȯɪ}}qC.:K1>ҲSIt;|kNh'2- "r,Lgs͹k&Nybk[[#5׽S"V$ұShK=C/8lnjU~gPHZsVƿaHK{;,IUٮ-ذmwG_m< "-SrgQ@J&C  %y=wqRڧA Ov|ʜ }q]Nk!G~gwo˟DZ 2"a(C Ғ%g!$6awM}}BJ}ɸvF$ܒhJF(slHTYoU8^?(\<6.tfF2Nh]g-+Cڳ*4O8VW!I]h"<󮙻8h*̺[2O$\Ec@sWgryvvY%Z7C=ݎٽڽkY IL^OqWU<MGg֑H\۾Ee|eM-==:zjY4@kwVEת/4ǯcذaE:5ФrrrV1a„#/F{罺ӽ E3Gސ)Bm~qۥ@ NO24=Bub"=3GBmz+HY㞜5*m$^v-ۣ(slQ'?]!^G]XVN 6z#T|!_z _@RJ7q+Ӈl6L8{Տ,^[ bD|KO;-T{+4r==~ǟ$h@ӊ=/h)a謁I=c~{w},c]ĩE'D!H=֖8u9rviIh뷝zRztF!H"5F9guzЊ ԫl5k6Wf wgkTO(ܒ@@p_y37ffݕS)@+Z ̟?TK, $̱ZK#///4@YWٵco) XjՂ:6naUWܱuӆlڴiA1"I)^a 3{u鐚]{\'y,P'Ҳ_?4sν h@ѺD$Ƹ$&jX 1*ZTNƔ8{]ҺԺƸ XRncEEAP{ܚބsޜw7̖y.aߎ|[XF~^޾ 6 zץkNXɞ*p3ޟ1냭(R(.8kȉS'&?.v9vc(yۥq#;uҐz|X@5‹~줕;Et2YVv]~\h־ӈ=SqLel7^) RN*_]%NSG6tDGbbbٳһtd"LM+YF#fe:";V%D*_u!e4v#&|owͯe^7;E_ Y,9GIRyѓgecsOxegGD9.# 26 ץټ-'ob5.ۭ쯋T´b:Zٝn>Rb'77W1I |Q*ۅe}4) Y936QKL+L{kv)H (-vff3ciPAıK~-ݐbzvb{\TEǬǡUX5Oxk, )Pn9{KVbҬAW=>|4qIߣ.&{TuD;fݙBUc&ft ŷh@Pwof}`/)7sVH۶tvP4_#@ CAđbp]I/LWTAg_&UPͰ4ڟir‰%.Ѓ"dd&?oPQqvuskl-qMg~bq#,#4|Z%zÐ1nR ʹĤy֫שּk4:*[VΘAdg+1~ tq]ǧ4" V˳Vi'.2ngR]*&,+vvNfQe T7WPPq@oKS_KԝlbMG NlReY)ɗl#dMCLUt,bgǦ*}ן*1Y[ @ZGSQ.o=^(&ͣuD(8+"@iO[`WVi?e@zwWMSK]_C2v[z$O}{X *C]ZbzER~;d*n ؎"h^.&_~nB+81mbҼ^/ {'LlIWfxO3n}Tv'cW̉6f[MtXv΅ UG9ޗ%K7*{g֦S>+y<(;5e_am~6~ӹ\%^sNV֬YaF|k~SL֪u7gkJ*ΕSuJf x>" TN b96K}]fZugzA͚еo_Wn *vrssU'v֭[*^Z(r0n&AZZO=ո+ge^ttILLT5ƍδiTka6Cj "NIY=<[ifS "C(qtQd3 &}ɠ "D('Ib?a `oҾ9 y? 0 2*9F&Q"$&JB"iIhIDR!"h٠Q-&ҍuwIy:V$g I?h2??;䗗㻋Ӗ$SXWVj8 "]>EJ@??^Wpݞށ o\P ٱ >,0ũRQ`~bܿ qf^ Db <jk<{ȁ]۶Z*3'wM[w=\yF'6`džwԟWV 7'3#==#+'t֞'?ķ?{Lew@d! wMgX`Vf˖Vd,Jb."QKY1`Bf&%P 8p9?>ppJwcYOd}~"ſQiO۸yO0:nIFVnQy:Yw57nRJb`+ů (l$! /?Hƅmw9:=xK*%%%Cmd#;+fɄ/8_}O,A3` ɶǷ- ^pS:xqAƦ_kPK޺{ղu)ŷr%2Z{=?084,4hߩueÌ׳^Y5K󍼸^Lbd6aϬ CBB >}Y~8""KP|RoEx,zrg\%/祽k#&=@q,V83N `|XN.UFx-{&nFXYvѷw]>[MV b~qHQQfoUzS\'K[ѡ#g(! "đ\w&kxS?if/bL}Eso*(8k$(Xsks_˭29xT~"l ˻$@AD8T6{jCf+F3%j(؇F?:K qWTdVWf#b;#C}g{PqHcvlZEf8/SP'\F#i׺|,#aOTJξamgV[!Q~d)5C3W'FD7cBm{s-g09*(0]ɫP]/q4E.(Idw94D! *(}ZmW]fnI^o$mL"[.4`4T sg GA.~l=w7+Qaǟ9J3AP'(aoh"s0ZX xMn]EUT2 92b<3~>_~3T{d|pkikU8oI=}9)_כWvz"vd=)^~4;_8^@kceG;2$rSO"i@3ɢ^;#ȴm [F+2$rMݺPa @d_Zߩ)^V+Sixt$Lڪ8bzHV 2JCWUpsj{Gʀͥ,--?0Ofg R #WreFDFe Nː23z@29T*dٳU.Zg  D?ݱjS_)pn;HEQ`=d88HȖ5! 8CFSA8-Tpr\Pp4෤((*(80nDo^-(Jp]w;au4Xەϗ± fͫi+ D33il6; "[rˏ}zFx\wxrv%g'{2L2z^R%w`7Tn ""p"lܼg|F7^@^jnF \@<%vA$V+rςPRNOIgP,L@ DΠ @ Pbp@ Dؒy5 :"O9;瓕XnLW :&uT)uU㈣C;m82Ck\ѨhL2b0qݢҎ u} +1FBlvc^e| @^,6-3.#wnf (>8z!::ڜObbfZ\DEE x"OK.#wKxCsÂu?z"E|taOܜ68U{9w3ճ66n߮`h"Ţ\ٗ?[k!3bO=pYgwޱaQsM:*Kl Q'oгy`PӖl9'lηA9[9K#Kpa;dq(UT j L ϕsi_\讍+BѲ溜TE"l nq'h +)+Lr̡VB,v˶S@|RRRܢǬ] ):фE KAVmsB#ן@ <30p>tpmͪJA cwr@ <30 "/ ?E \$EdʍlBΧWcLخvyyzH%:*D@DS.WΕGOROGΉ{S"EE )1+˘pk\GH| `8uaAZ?Ñ>u*vLD@DSJfsѕJQA |"HIr>J?\&f_P|v/ߖv/O"ZD?ݴQ;T1f}!QA @DS#y%kӏS`V)7U00 "I\9W z;˕;NsD F b):+cǷ6&jpj̞+O@DxG?7 E!dC"ܶ+Oޯ@ se_>-1!!!1RǓyŷf٥I#܁- ڴ+S% l7X?% ImHBp\$1 "Pr3N&ӽY5?)4IK;ȩrf3}`?|CCL^@7^-jB57yoiάۗLho?CLpwRDW Ml͖',{>ˡ `8iVf?|ߜ{ҡ`"D 1x9ع84Ӌۨ #K (t E ]$^ XEJEe ХVJŽ➢6~?|_V“6Ucc\؅ã!YV1ꊳ^@ /ՃGw0}ZƦ"2 EĔ\ Dt1(p""4>:|vmm?6%97נJ䵭(bJ;nNU7DHzqojݧU?~ ˬU,} D1(p"SEJuqc/?rn(Wy^t: n7H'=]HyWɐ.(N$t@d6cMp8Dx$PȌ_ ʢ5MnoYn2t ~RPo~y^%⺺,@1h`rOF2NklXS*ߠ5֩-ϗa6DdPL-[D.̌Oon !M% ' jyêdB.?ͦ4q {,^@ L(qE]tt!AF&FBፚY// 48pͩs;?bnsŹz.T-W:&'䩋çD!g+x]s Xlزy =aBʞjӾUߺaE̯Z\UxءЯrY˚dW;BJ(2@'Ņ=/O:% lܘI}}=t 5<(yG'4iŦK^;Gr!G!@t\[DM7!e3Ks@5d7܊S͐ ce,zy8d^?2TpB˺}ʒ5} LnCFU<ճn \V9@t7hL['G)m~޵'}bpyjE=~7%t\{9oGNw!x??r *=ul ]b&T̞3%+w?MaƆMcAu<(؃; s*Dd" b6= e Qԃ4;LNXXJB}χs ;>}{CX>޻* "5@ :~g7 ,ݫ1??x%w޳dw[jxbf͵tO%n޼y֭[G _SZbrraٳg/\^!5b?đ@`sE OnkKT%~^m}Ǖx]vdž-'6Mrx100"=DgK@_~=D "DB!5b'S +uN }Dvjҁdu1xnl<ޜqj*{`GvhtfifF:{`R*o?j";-Nl*yT V\X"z2!G @@ @a ~+[{_-RxZ@ D-|Ň[[cۡo+qcIW@"DV!5WW_~ޝJ\[c||<P൹G-2w`WV211[ ԽuS"ɓ'\.,+= wD@XrlF QՓ  Z Dxy J\`xI<D9Ȣ'%n?6K׾Jh\yl8jrm$ѓ)<SH@ @Q ȲS骩KmɇFzs"4sũ35ۡљ٦ @UjJ &Tt:jd ig&FSO%7i ՘ iEhTBDM-BۈpA?(]XhYjQ "*VHZ"L Qh3`!<_q8/R%⦉ D)3`fc^[}b~h^^eUes"@zg>7<˘ s6Dl*ܾw_ҢhV DRN=okI|^$ęںvZH|Led+S}lm]-9)*nj m$/p0+$/_Qw}d6JJJ!+ft[_ƅ蚔͇/~a AwwwȊ)=..!$M9_qRSl$/zHkF:Ozul>.c[O_ ` ݽ4qqӴ3i)&\^mk[? yLIꂽ:[J`o#?/%<6%pnf5aQhM=wܽY{^Q)|Ϯ3E8N~z&_)J[/{_]r?/|1EUUxWQQ!4,q("A ?(W }DX݈5| Y[Jj %=.4l6% UC$#@g#R(ļG(E1f"|`:fhy.#R=tTNRе qɦ#z쵾I޽FQqٶtk R@}ؖZrQhmpPj0FA! \ BB$<(J%ĤQP^vue[wwnp&s??=!;>.qS9VP1u~׎oI*++D h;@Xl*{uy{tî53;OԜ oR^^.?i[J-YJl]+vj3b/ !WyŦ.R6cY&3qc/ W [%6O^ł>q;ҕs_ ݽ syB|)Pz A[[̉)(q 5_m/5yV` z*kRq3pr|Vg SYYJQ[|J^W{$P郺{>^7-M@j# 1jLsIںw—.\tٹYJn>#F/jvqbӕ 1# ^}3jQ 1# D:žy0"9#G\5-V\O D/.\0" Hnޘ=Ws) k DgX  -]Zcђm[F dh4ڜ"qҒ'5F"iɟx4v]իRTWW)ud2WdHTc߼곯ww[@f2!sV"X<np0>Oa\~2{!#ҷX*Ui.A E;L|wP Ɍ^>ß*•HqKLP&3\WbKX%نKšWOw!w/luh5.qg MKY$6kc4鮨Tr3-sC7E@]gL~4ay7y-9[! C#F3nD|~+te6߶m \8l*%mXI]"$'ux/Qܧn$UQ`%`A$XdC"iK-QSi}GPݾoZvߢ-X۹uZMwn\CDOsI8ԠishmnK, BIV xPWGkZZF& gh-b@b3:`A$0deY̙F\XKBእ2Ɖaqjƽ#e. *%yي+g ܱeŦuuyDs8$TObJ̚=rg'2$b;|a*++g=-=Mr1uĢϜihd4] p UUU)++4L8}n<&6}3g~^ݦĤ́A%bjll,&ǃ3ĦO7b. :jj,=5O)0n[N 2ѴT#W%.X cI4A >oL]lC(Z#)nPzRr2 &9Dq,ãnN%宑~uޔH?ԧgf& xH\vM.6Wxr@IǒFơuXɺtYY3!0sWO=!65c6>!%cV~ I3~͈j嗎Z%:`\}ؔŵzbǡ~O.td˖SooUqMS\Ee]{}P WsYzԲoVoI# C֊Ϯq\K\TrIϧ><Omnu.g?CLPniţ<-`ܜp)Ϯ~9]5̚5Ki4eZh1.*:󏙑-X$\-K l<:;/ ~Z\ˮX7o)kkkonkꔥmQG0~̈!vkgQ5*ǼE#´Ur-(ó}2b F ׬jT"^?a!Z -F31)2]S_l^6nJ_fGJv+3hDgX;GIe>}feGX|8ٹs'C 4LYa%Ugķ?XUlMZ61SIӌlD꒘(N.]J yLʏ"-GHƃkfURK{vTwRh"_}㙪2'ǘR6!ᄅTr~NY@>ӟ$YmRIy=).SFؽ.!h"vH%7jeAfq9hʺ=+SRAp&e#VՇ]oi #hֻKVR{9*IحiRAY~Ewqܒ%l_wQ/&'~۫vd 9G`O%W.Z@""":իr Z;e.r.<`ڌqG0TY[ChhB' ytIqJ~Y-C&mZ*:::ITT\KTP{-Ё Xeu$&&F"ORRA޾Jܣ|zkX (6U o%n2v-H=AT7ͬo Ν}4>#.#?'Lt/7'!L]:cP@0"zB-?mfhC"6>]z4hXʑjOge%Z8M{Dٿv{`M_}3*zB ;46#O4}q;8W>7&zg~B8g(%4 MޖE]h%R(b$82@3?VY3-y#(G%:.e4| n  />w| HnbJtj_f裴b5wwDArVՑM|;HZmm =ĂL}r4x]A-Y, TM6vwߨگ7g+O2-⢎sKh2+,j6] QGUZfD\fW}MI\cTSDVP|yB3?tx}$fIas 4,*_,h/̔%"26-&{5:I̒3v_3@:hXT D vh?-鲘#ɩE5._~{ql[\vyTO "( "?QF^(\=H۶i߼r9omõQGWuuޭ]{m5w;? Y~06ԟ:xgũ>&:w;'Aa"&2uPQ\0J66Y((jOi-pcdS3GD8[ oog=9& yqᅺPe{l߷_Ko=$˭w48Į/2R߯?(4bpWheRU2`3@i^RdJT@E8躅  i{^)=bOXd2_Q/5y!D &I Ma48=Փ[.CsQU$%%JKK%TF@ e)=OeǪYnߠkhܜ?ٔꓴCzt+e1_8"lU<<$H'C tϧDtWӲ4I cA C N@U;"$|!:r]v{">w<|pRRO9XjUl)0pt$\ܪx~H/C#?}A:2?f³UFtAuU^Z I>tKs Dtj"Ι/dUD3إUKXUljR[F>rG ÍS)Ǎ]}d! Dw L%[fsMI0ti^4*@@NƲ(~Rv}5¼ooK!Ι - 0)^N3?Ԑ1oٛ!6uE/.0!p_ꄕlܑ_l*D ⌹J>zٖ%1=[ik'J֞>R\'4zi{sq̈hpD766Lu4+Hwws0}RS;8=@I A,"a%r(Ӫ(VqAX+ "PCB@D$ (Kre$pa}3 [#&Sg!4v}[b~QAQDAT"rsiwkWU`SlC(*.sz& 2:u,WaH^19,YCoɽpu[)%pRfB4HssVRb ڻgőqUɆrWVTg;O{0Mֺ4B?cڿ|H277wHJKK&**&%I“YFEE%Qm! 5Q9]r) r9J| PJ"tiSq9,?ҥK7\8EY咦2 F>l~`M6zޢU ]LxYe^-"e&vsz""#QZdd&^uuN9!,hɳ\IPTUq.ɐ,XbH@@(4;}Zj&&Wy$՟,^wS6R& C6odHatJ1Ĥj>Yl xoOu]X"%Đ2J ",&?U{n3_۽G'1{~uJU[SbCN~~z6m$@v#= {9ĤOylUǧ,<3lCֳ͛j*`Pivzr֠#41w>n %'ǧUJLFb֠K">h_`Q[sB՚6|򒆥 ~nŊYn4 msJnSbrx}6!ʘ9sfIò?~ ,[L D;_TrbOWk)1i:(-:Ɵذ#ro|~pv77V⥅5s씩:$'ni{w{SOJ5  @zi/K9w?s;ՏWvߖ_{$.Ii/-&s7'*@DJ`!Fdxv-14I3/oC p5}z*Rz|'u_sLЌ>,Yf&Ei⧅>O-Y?shZ_X W~t6$hdaPH;;!~΍k7 2XElh2 z9&>z9Q<廷n,ૢ*@ϐROuuB~4] ׷{Djcu*^6Xblg MJ˻pjȉh 8ML fTBZx\fv8+)>2Dn{"J]kC3 stѩ?rrb?,óO?,( m֬=;C_9vT @ ;?~k|xku-!s+BquQ-hbRIKjAR$HȻ`(0= BKSAgYnqgszBt[;[g/^y^nX2E_md!:o}ْcXT.|햝~dWWו4ɤ4iȍD0:%O-YeOOVۺCGӿ_!M<Ȑ)Dn$A` һxӦ^WļXZuA%iR@3cj/' +N*&HɉEm5w)`TWW Krj_c'e੯/LSUUg Y=}#-riceQ,0'W=kZ3D2x- lY[VE?>I=ma]o_̮!( X,BrI$ $ "a χD<ڳ7Ewxp/RG~ĚPG:}&U試>Ƚ ݬ Hwv "Bw_&1\hAdh!iiIM&؎ƮgIuAP"̀r~rҫ0e[ TQDhOѦ߹I?߸K ']d3 "+|HCw?/Qq?:f&독{[eas.q]=PB7'1ѡ %L@ZB9A3SgQg==~Q[JO_bCauyi?8tCO\O+7 // /룈obSauU1::ڛ066l1H}}HSsȱo]vyi2>>ޛ022A Kr\!6Է~^Էv.&ʭ %O)6Oe099PVCȎHR% -vԔgi "5N P"@eￓbuuuIN&9Pv{(Ƿ>56 P"5N V@Sn9PŎjnl5(CO< p'+`}A T Pn$LOOΡl@ ïٻca0 =H@^ʴ@92W;#+pkx `P+|~2X\."P~8~)]0|(.Je?Pqsς@"@59D`MM4N 8Ԥs@J.@"@e9D`M4N t: +5Ju݆E@I,/U\9eY' "ߤn JUD|(ɯϗ(~@} DV"UD'h@*9@ [n w(jqi" v)ž@B XUbmi⫒جs @A"N P8f3Kk&_,^npCV[b@v[b\"D@b4'atUWxYz-z2@,N wnO D>/@ouDR]8@"@9 e DǏt \Nx D3|Z,t: @TW57K P8@"@^^ rx~~CtU׏ķȞ D 'JUM" END1J+QSXXf`tk]pE`!V[DAllMIL= x`5+}k8 s D8 n @"@n @"@ZF UW#?Pb4^ Ui+ =u7 @"i#l9r}}@J~H^_߷@NNN 9@" D6on"dN p@oI @" H@ s D P" D2'ҲZGmj=,؟@(l%R: D` !(@ s D4M39??TG... @ %LM_߷@a 5( -Rdiɞ2mjB+ubfDbHd9x DTu D 4L K@ @T% < 9@o HN @t2sd2 +3!icK)^i4rli&n'@ @ =]vs#,:" DVf' D$'z̄X@ h@r"`eX=t[U )@r""@l6~s8Hp804e@WvזbEQ8dR"x-HRBƍTETl200p0,,X7WW9)m#.gݾl6z~vP&r8)m  "x 1@r"{D"E}{"2^fHK @^cH 0!" D}62 Cj"9N|Z].fx<e |r@`Jji0V#" v=@M~| YHN xHN u ""Ddw@ Ӡv&]0M"wٻcԢ( HZ3NA^ (؉)bV;-@ iBbwιkMc[෬ \?DX.fnb_)ru>_.H ?2@"TN m۷x<+3%Fod @Q '@ z^4=D*'_2`eT D*'TN y D+3D W~ @ fe#r<_%ru^_!n':g>*r^GlIVf'Y( D*'4M ]ee ~M Àzx2v9%J4t: P9 P+39TN P9d P+3TN ݽKUasޫW$+j]DlKC/Q9ZBD䘮-Yj W1 Z:"*^χv~t8XAĖIA`SD2P(>l "-8Xj=]~ -C%<8\ooKV>LkJ(?~V\dϗ֕Ve?W@^$%' [M{gRO^NgB.߼I bMcO!M &EEohh6fxx8Z;فcKf0sytt =rw o>/kbo&~Mϯ|_]xNMQBGfμ⾌ԭ}Un!6-\ '?/~;wԦ/cF;.1QlQ󛝻3mGȝ'|w[\.gGV5ZIc?̰0 ԍpW "з^aEzŹrI)%"iӔ7F\":nU=4KD'?q5ݞ)/~6u砤#i\¢W!%DےC?Y"O@jUM#JG S09Y$& {IbQ\ 7stx"7N(6:+]pPD]6s_<`4)C)ȖGHֲK<,^ѫ [4GþE|r<+S$Zi϶ZX[V#^7~ ٸ{J%{6=/˞.lQrҖיV'eb(qH.U efMLkCB# /$к~7?7'kULb=Hù?s&׺TƓD/K7~L}@7p% |@"lyCTEihig7R6K aut~BYgڿ-K!-3u-=Jّ%2V7KUc7s  !_z}'S >B]*‹Axvh0Nn\inu1[n&/dFZ(FQЋ([0]H r_\(nXwXp_3QҦatO|t`8A(L\X46K!9xz߽EkD{bg,z߹hꁥ^tV} '55hii1+W W ykfiK׎ta_M|ҺF@~v"W\ae~u3WYoyl|n3ث7wӀaAU2R?{tU՝w^$! (/ ڂ¢8P5qPPЩtZ-Z+Tv2ԂP\Xj (@0 K %Y}nZ=[_(ЗݽV]\˟ u.)?v~UvJ:ݜ9sȢPAhuFzMڦIe%yZmQCYM%wM+.Q\@6YPYI mxT-4 j;>MK"{e@7{YPm+- :uG+ wKDȦ/ǒ_]e"]"Us꺲xKbϔԮ:$ e2|?'^4 ZAʿtKş,k*(5Ϯ?硯b@$ΦK6WKZ OUa@("]r@d ^ee6M]Y}sKP2U{'* ~Yco%h1u|GӠ*0T+U؁"or De%<89gշκG_4O= Jx Bo$ ϮlR'1:!uv/R֨RB0[mnFaJ??SHWk P&2G79iz7:M>}7W;ٺʕ"sv bK  OqI Sb9\Xh$S[+{BF^XYJWj;5Szh图ɨ?^QQc#u-C,ۏ"} SЋj(*\ħR=pD NE7jvF|/ِ߄Q|uIɓ^@|e ʀ Ō!F3JR "3 kqANT%IQ[xȈ q6kԪaY)gOt 3h󑐢SH0;g͜zz8xST:^^Zmbb(McԬ~ͣNG{=Nʹ,ǴZ!2E6fuFD`W\j VV)qo0 Vˎz 7&kO᫐db9<:2ebR2ZW?]e\-Q+Xͽ95iMQAz Oe-\gwT,1Zuh$h @bޏTK:yF;6,C0"RtRuJ yPS8a\kZ1}"E{+aY\\-QtY݅ҩkàD|`OϞgqKG!`zhKwIEpA=R5?@!@03]L>6J}#lMdI. [*jJ5$~L)Y@ !Rx03TCU͝FOuGκmWp{ @P'?Ҏp`!z}s?H{c.Fɪ}Fg0J'/+b ]u38r]pZȱIJE~Z6 dUv>%;)BzEI7NsG>Jt MrI&.nk D]Fglw8~~W*xt-N}ۼNᙷ?3S s?B(/)ss%KKͺ+|% 3Y( R\TPyUIډ`.(;N!OϚH?DQ,mlEHY~ 3:E`>$QeI˴ hD2.R6P>WdۖziP¸md )EҳO(x2fԬAPYWRl{tFaFstۢ!Lh2( E#!OE򍏶"Tvp`6RKcF&J SɌLNgt>MMfΨ9Nlv ewOKֱc'CUtaXUMYL$J%ve>2e\u{?Nv6qk(I8$;#Hb8[ O< jqJr41;k$fHBbN<.(yKnk~f͝!D!x @׃/?Ӥ4m|F^=6{:719XFڙvuYޜ̵+]ku=7 sl*uI,!9ɳǑB!B-e 8l޼Ih?HE,gD7sNuw|xqfNէf % 1sʏ?{z>}czuC\|&U-cs~\ۢ!B:Wg u黜xR${b!t7G1BAB!RA0m˝PtCp-Efi,הs]Zosȫ!Y#7 :a B="B!P)#⥌/\=AD~ us "!tQ'zmVwj.r]pk\A$~N "B!$ FB,1FED1(gOL>v$C u+i ?'8j=zCKOOhݺuoٷofa}Ws[ ƒ7N(dðlWJ۔~hA2Z4$wi+Vx'FWDjM2婷 禣PP+F- 6sw'<5GMR# "蘑YB!B@/eL<ʭ[Hߏ#PC"C# C<5(Ì򽭘aA7&x`kfz$CXn 3JDF"?}G`gumc>z ^X^Kq{2'91(B&mMnໜC{<_!B!A0v%bbaP ].7b q_9G`Ƹv=4Ǎ{!{kh:w}לw=$S )))P!xDْlZۙ $g۠<&1"ɉ YQCʋvy1Y//vkE#u󧏝9 S !֥_z3|DBrSk5;B vQ+ - _VP B!P)Jug羓 T[@Bc(@׹ Pc얛,P9nfYBdA)A䘺 w<yzbfbepPi f^cB!A\8L&&xX)xc,-{kϤ7x?i+_wzԎ}>lTW3#_A':6g& ;c1T'9As}C_B \C"I-j~!zĶ_'俴kBok- 1kWUW?*56 !g{J'T&]^sB!B@ *e\8W*P/q.ЙJm$Op1EKH0q9ATAbY#8Hߴ@(~V^YNc@(J y'GSS׾ܣN~[g ;I嵾?ov!B!͐aߝu7LaR.j/85f(m/8b_MUq^K ETY9_;?]u6,cDր5⾝=^Ǒ5j@?=w}ʷa2e2淮| R9GdoKs#!B!J+em?oъ,l.@#xUF\[94m%ÌΙ9(0TtgV/iò pσw P)TGVuXA 䏕eN =gy}:Sl{pمq u£y/'.$B!u BjEYrnmc5<^`'ZBMHֹ*cǎ}rM6ra A'I>})!s=Yi{n- vVK1(|jJ5AWnf {Fs6P ƚ6?;Ǽ=8fLQP;D2ԥarN791СeB!Q㥌AUΝ;ε`cMl>I\_BXxơךFt2o-]V{F$ggȷo:\97r{F3Wz[O[=P,u8:ӄn2=ػŠvޖpcY.\$s B!utUW@LP)t;(V)b3BX>#nxZ:?nP  $%%e_LdP!l(~^T0(?fڟ 53efcƗM( :hpA϶ hӝ=}lx/AE_+T ]3ޖ.cؿM3 V)UcQzX G!BHQ㥌}BvܙOd(#]d$p#st3A0 }2Zv?F=baC,tClmE6\o:[@r|bc:J(U=Nl5<4@ n'_智vB!r'&5nz%P;}*[@Lffu"4s[Uc@"iӦ?Q$6 2Pl[]x)[b =PJ-;`aD63+v k:_. 2I]|/in1ś_g/vcA&Kr*09?"G "B!TJTʸ$hxeXT &1t l}帒(tSqt7CpGOEW;Zݯ脊E"I :| "j%nV (²b6zw?Muus@!B%DH [I!)vu"4sw6Q\@.23@$9Nߛw󄂱_)+j!x O?Uv;IobfDl-&&?F'Oqg"15WL =A{` "'ǁg.3B!D *e\64 'B!r1R muvg @Oڦ4ϐP!qbJk#iG0kW4A(% TU]wBxZP043(~$"oi_ T홾]*Ycmr./B!3P9&^1kjf(=Az?uŕhX׶3B!T2q B ( 2f\@Ynti,1I)aƠ*[S3|?4af Mxԭ;t40<}LƗh B!E[̐գwOo;^|*&N~r %W;IȜGZېxn(F'k_mRSVR\:ԼlePiAT05.jH"cpgl"5)x.0ž45 v%Ś@]?txq,<(AB!R%*eP)#@+}V⹀&I"M3pRBxp7CK歬9[ֶOxKtio.S&~1@!BŌDHͫw}5~OS"s׹2r-0\y[$8 kfޥB0w8Ţn~W<}놔bRt 4Qc2W:p~*yKw3xb˟(UЩ-KJ1ֶ#/ScKk.~ڏB!jR2.9\zrh 31i`!I B!r1τ6D6flsN=b|- ,\pyZ.F6qwĕ{5yrw!_r^@oV_R a&[_ʹp jmoeBȇ8jtgΏ51 ecwm3<5&ɭKwMPx1|d}5vQcHGEǁB!R}TʠR%ǹB[7008/vP-rcÒrHsB  U -vCl O™1PB8wwOY P=Xwa>}<6 B!E I-hkw63zsϧLxϿ4v 2jޢݢ&ΚEvo(3(ݩdKp ׃Py;e۷է"!Vkw#lV LIu/@WYޣGܖ13 w0.&{ſp }{h\@DK_CXV:c cӱ2C!BHuQ)J<@ -^?w P7gkO@W/P/ۮ6?؃jOAy2xBcc_16aH˃h9p\i^<).`1`azGE'B!rRkXMVnnH2LWǢMLR ɗyqD ޕ E.Θw/?]%%kӮ^^g QI.[``a4B<=(ƺan*Xc&K&ǻӴ;9]k\TK.wbz_vpMny+uPbB:;uhP&GHm$@nu(=>B!2HR-A|> fvm󟢡P ׶iPFJ2A&^jطKMP㤶:&=xEap_A Ĭ^-}-佂CxHe "͍ [ȱ E">B!RԼK|zY-a{bK!'dt[3#SNGQ$;rș1uZQ%? ?:LU qkV~7hj)|ىOh߫?-5_ޝFu]q&PFjJH?hj+4R)T 4B)j0NXJP4+@Vcc8lba`Q/euLK0g`aSQZ2?Y| Ed'Kx:mW*c֬YMEEC%m5[[َ\5(خʈhC*~&G! g_2jV7~_wNn~icy*N.*p> 7]L)߇6߬WSg;ˣ:\Ga>䨌Bv gr ѹmd0v~uIpBwQ9 {Y~(ŝXA#?32Β9{:HXٖ13UY֡0ǝ?2wP't鞴]PU $ߑW)^2ATu?&iI. $H+ܩ)|Sn0ړb*2nWP>b\؎vI(#?xK㦸KPsN4xAnt>Ÿ+l;di2۠ۑD))5a@$dP7MܽH~",CU!9 aRᯒn ^#ZCsW{grߓ3F1Ls=O_"Έ=vr|ًGVfkNjW]oTfgJ)8 3lܑ \RDRGP wD da r¤i;6nR& {He.2'6z'2ĽeeNq'TT׮35s;Z5߻: !V+KFu t {GFAF:A@? 4d"sC ÒF$kMdGW ?jYr.Ҭhޤ˖72IÂؤ7w4c2%ڐ/omhwo 3o LS|XNآʒK-UOTW,1Kħʴ*,1E}7brEYlՓ V%.[oPdM;{!m-7͒av߷1p$IQZ|qٔ; t[0AH+)=,9fVkUb|uڲߜ  dfԝ`(/}3.BfZw"NߺWi2w5T?E J^kYQ䩋"$"lO]ZC K=Re_Gԙgf Hu@pUmn,%kʢKpM%9W]~8XJxr~,,_kM"Cm]Guګ$E3_tww?Iq[Ej^؛r֚kvQn嬖h+$"іYJ \즭ʹZi#^=P10{ɞ9 [:HY?H'3JqHx\yٜ"='L'U:R3;WeYFn8i͋=i^̧?tYΡ6Ot7 p Z+q!o 2I0b&-8,#fez]4N=6^ vS(v3ӷY 8>}NһYm̨ބߒ\B8nz0tTR4>h7d-+2먋_BԖ@\Ґ=Eg7IGĦa @ o(^/MP_.W1򒭭rl&d_OUMR!5 fP p{D]} rMv=gcwr(~Y͠ BA$l6۶Z6 >1~}dibUKl9dJ*F>r0''َ dkMTA]Q51;>`c!n F=^DP۳kr&߉)'{"BP(n(A 6QDgA(>k@1&DaE [4l5<܁++J+V[DAllBM2=L5 @ZˈP@ @(P;2@ @dD(+3B;_"+3@2 @ Έ@hl6Hl6\v$iwncFD^l5^):^9Rg#~Â=#"FD"D#"XðlnjZ.v DDWf*q"FD""@SD#"m#dD@ h@'#"@+"hOvũ( ?"mL&&.#vV!K@jIi$4SLr@ r9_`D gFD"@rag?~u+@(rml6v{@eD@ Ȝ@ȟp@"@Z&]x<TF7/0#"@:h ]ȳTp:]ʂP #"@"i1"I Ȝ@Јe1"H 9`D(4 D#"@EdN j -bD(@ s -1SUUmcD(GUUq8:FDBDfͱ><RX,7~B@"@錈FD2'2 ^\էZ {^QOh-#"@:'Q[u'qH s D#"FD D4"@" D s In;Vm2 8|jźv n]-NP܄7=88 p!Ct4NI@W)c@ĥ</=~?#"@FC4"@"R D4"FDB D 'V0"H ^ߍNjv;,2x= @4"@"@Zz4^ ( pg(;( D?2"`D(@HKV{=/h kjuM#rH\8 QDW*pfAH۫&FD2%ЈgD*=O#"@"p`FD2&֣0"dK  'gD K`#"@"p`SFD2#溜k4FQFHx<emeDH@H7W6V1l12.#"| i#"@"@4"@F4"@"@Z*GjwWT8؉˻uH 8ad2usks. haE۝sț$Ff {wXq!}3igBif]Bl(X-bc @@L"!?ῆ=xJ&pD@ ԊF(#""``iDDYMD4"@Y'ЈU*!Ј D9" ӈqDx@@#g}y5[v@UmOo14"@%}KUrqg9 G#I@uix_6 #"&BhD9FK#| |f\g+w/3wV+-zW޵;?^eSG3ZFhD4"@@#ħ"iD#"P8GDFO#Dk"n4"@@#<G#Dl`0Hs:>͝|^O zv'PU'c͞@Ј%jL#C#D4"@|;Q" 8M0pq +zZNL # &vĊbnDB1!ϓ&o" @ ekfQOwC^j%pMS /Z v;4ӳ^<+@J6s-ЈFhD7@4"@^ @ p`#"NF8JȟFhDiDFȟFhDiDFȟF 8E@ "@sU4m7.PF8M{~'Z4"@|YYPF8_}LhD5@m 8'D# D%"@7G@"rdU 8mB. "SK'qs"DCpR7D( (M<$$?ɇ9`#Y1?i==_5 @|Jd2$\Pϧu(FRG"NN DI,K3V03F)g p%޿yV2 q"@\͝@iHG`{tJc&0wo^[\ $@" UX^U6@ @DH7 +@B @$D@[&e& D<DL@aH1LHb dC DVH7 K)~c y uR2@(׳id~x<h+?g)cq_Φ)6g ś5~?@Vcy__ 8Ri@2'e P) Dky*b,H)W4lwܚ_sxxĪ^۪"*RD 5R?k"eR DVRH` P) D|o @) g ػ{0 }>l"`.,]6nULiac"DH*raw@ f 4F="+@ a $ R@ f  eP9V\+ eP+ KYot]@"tn@ g gx?0cP=KǏHc:lՓ2([RX Je @ Ry3{0 % (j@N/gD9׫~z^,'i!eD9@5 0JݻT?WoIA4Th-B4H 5XPXR9DDJYR& Rmi^B4dC$tiDI= ti:s0Z!~4Q9:xfё윋 >gޓ\t"@~lْ*\n] ?k׮M BZcǒtj7Ԣ0VY'maP" JʁLtDa^>L^lCD2QePRD(X! a^I6D vPZH%IG!nέ3jڕi^z{{CҥKy[lYn`ѢE!chh 䡯/*l4͹8+JWrqk4!chZfO XdIoy׈ 5ƾ8\|zjH-xZma9۾}{طo_ѐ|6lL22nݚ {#[ر#dݻ7D(Xƅq:%?Of:igҩ֡[E\eQePND(ZܻJ:N9p$a^HozmaP. Ɂ\6olu:5fDnCDQePJD(^ed{:bO.jmӾ"mSn=2syF\_eRePFDh={xfJ&޳yIW6my-(\i54U;/7(UT!=ԓVZ/oS!c?Oi]Q޴sp 9l===zq#/`ōZPe?صզ0D""!. !'qs]uW/[pUBRJKB+b m?tJ)CiC\_>}$NAZjT*>r9x S8..hOӏӛa1ʙ.{Hw)DtgqtP\Hd#GXUrqLD ˜ W:?{ҕ?^"1e@"N 8@"g`yn6݅ AwogǕi5&f 꿹_D==we;;Fqvjњﭦp.2eã?3-4B !Ћ(]E X JSY"H(j 0 !I6[fٙ%첹O|2ϟ/| @Ց ғJfIWJ?jH>sб3fN%w=A. jB6ZB/oP/QbG9N^_q0 {PJQĆ(%Tծ; %t>* #7BԧѠGW#/ԇJDĬ=>" h5zY#Ux0%NQMN0g׌i9)6›re?A8;V& birduixY!_a|Y^d|T𼂸y݂9@9_Z~:# # `MAO(2C`H\>rЗ"3mb&J5jGի[ӛ/gmWEV"4/蹲Ưô}70W{aI48»fH_OnNC@ɫsaB g^-&ΑTwDy!n2䃟 57a܁kfQb<[ G){S<ڎtOJh`ΊnzG4/@+9f!5;p++eIًh#uqna>5~oGsuǯYX ⯋i>9juDDNe?A=07%nDKzq)NZgZd%WTKٺj]*Y.8GuN\BJNnYt N=xmzC@| +G6Ψ[TFp/2e8wXw3 peTȇXy'wu?^HQPC?]-R21!OJߑ'U\=MQ.n[1{R"s; !to9h1xuM` .`6[F*3MyXi͕o$ Agą &]b3<60{F1ZEP"s7 "+Thy}y۟RgV:C@<ɼouPm9gV!̬6> `h.vCe"qrii߄J~@M,h[<%0%ݕ57miZkI)>z,-'DGn!?(OC%"uWYrV&Vf"!.E ?"23(# ,|1xpf4hԈ' ZClĿvzN$Utx<ͮCBC۳L8swD@=sg3%)uV.;_92pzR!nazvpF,C&fݏT,31TDLIH42bmݻGGc:+~]LN)`|1)Rzœ쟨T V^Cn%%%stnADNw{N`Nn Fn12P7kH)}U9sALYY?ms)yn'ME)!av[*uH\XORCJȜ32&D#hn(mR~MGJiguo׶>-LҾ>:eemz2:F|1|b<\|]"6\H/wdT-HS @.9NTSSRDѴ~e6GEK\+|B] Jn)U#i£bĊS܄QEQ/'KW0P]9jslj5ą½[3Rj[oCP! #eg(|hx(O\B1!+=$Put;#MX+gf[|gY@l4MlQ>idGs'.3 7a!e)Ո Os4n7(Fp;ų͐Z:~"CP! #ȓH)@ \Xc-*QRU ^u1 w|#(7c+JW_hYkn|Oʹ\4>(TYS_<`<3(GL<~C-|SSGFq|3DcXH)7(q h,fHbD =%PV\dD1ܸ#hyb\ņQk܅Q+6PsX_@By:YXPmg?ӟ4SV+)Ey^C\tĎ +z : ;(qI;f 9̉>?.;OE&juLzJ\+ņ_t3_џ^|?Dc8ooJl3-Sl2+.%{1&8@Ĝ_̘0clA) |6l21B;ņzz㻠n(TB5V#T#U =')AW >{{H_t>Y#x vlx0>IL1PE E_P@Ŋ/[lqK {p.-C"JPmeZxxT^^(F&&G}|T}cMѽ~{~I:j CkRRJκ&  Rfg2t-3[*(FdN^bC*C}bDţ eKZ#24>QX3@^^d]W,ٙX^]Ovx`l{™|T.A؈W3Dₔ)ٟ hРjTMTL}-u3#c :bI|d?Ӱ{=ejP!aOli&׍OPmtL=|MeZhfHsi+eg TtL4}۸獌?xb{BB՗In\HruVʸpouM&  &L^&]4焔$4 GE8KX!k1zԻDk()S\QrRh(Q7a*5l AHNL\2װQ(F|3~.B(WGּԩZ#[4∍pq3qti+bt@U4neߴ5?`%ΰc)8jѬޔ.ҕ5Ϗ[P]?Klz</c#'K/Sf-cFpFf-j:,gc9}g@U=3et6j6P79y_OgbN˭ň3;2tדRڎ/9ʧ ~k s"wMof*o7Obe !9!~PK%n(i™Yb[Ol){,M<>Ky<@Mk놅pĆ4D1:` $){UU=_orMUaBҼ(Έ:YP}~:vG1U0o<| xh)|< nL/߲c=Cmr%P)4;|cIZҫ'_ևuໝܵɽ:ZS#p(<Qi?'RCHp'gG~ۼA9s5qwcnP"_A~m5̝%)rIB" ?i~ h%f1d5fg;Gôy#W^*hHݝel]m𷇇tO B1c3 $WLJo YG3.;EZsؼO]TpZç鍦yPmڒt Bn/">~ubsm&Hc6\433kVΪMxƬW}廂_`zf%k;}(@U=W/9c ;^yT\ )=tnivp"D " N v@`=D9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A];o}8`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`NDػ(~l%e-0lRXHKbA?jnvܼnm]aڬF?V ĶIfP2+]`慛h^Ёw%ܳ{<<=o`#D6,7\dUT=lk-{(@w?銢><#+txlR=fxX~y~i֚މ 5:վ7C|Fzq^Ur}HBPnQ䱖YbVm\Vs2}HGcoN*HB,R15蟈]C8" 3(>zزXFD"G-o:C]`T$MG2$ f, Ҽec%%G hwDDӡI՟Q},J!r?,ЇKhyq.oB|u [qJnϒJ|eЌ҂ʪ%uF>!}H )tsQHpϻ]@Z-~k'3:6*1u4ׇp=- EVH/TO>>@Zn+*j!2:TC K" H ,u*7CH Rջ6Gρ$U7 D@&2ܻ:GeXBp{uu%6WC#?PBښj+ewP=$>{"6KIYSٰ O4^f).)7lzu#c"i?Fkij:,kmO MO $u>TH9*kNޮcŵ"w..r!)@ ޝGQ{?;B FeY4}U DA̅#sUtPEЁ 8 }K$T krxwQ./3b&fhEpe}YH7?v_R5ԌDߏ;M]8}m~Cs;{8-M"k|cy斵wִʢ:0&iR,\?:RiW-G}U=d;ZDEt6'ᇺ~-ELF݈++Cy% z1v-u.}笁NoP2g Djq!Z/nݬ"ʹT:=R`XZ@OLn|;]Iz92Є4)/79veyDЌ\lۚ1L^h|mxޣWun\1-c9Ud) .zˣY֡y5q#]ރznų9yqi `.-ԓsR.zeNJ@phHY^t#签Ē'999g G]4nPl={Xg-Z%|ٰd՝/_K{Pvvכr43kT, #OՄF{l¬?lm߁#GIZ|;b[Tǡ9t3KCvMb)W!4Jk>Ni2N>Yz!';+FAR^hrmJH?նc92[=vUMR蜧1Uϯ 4K8r߬e);W->n5/d;`ïm:Y1tlnT7׳i⟺~歱w].ƥCmb(B3`3d+fjhmvzjN`)\)ԢϺfpਦnq)-[TU\wD:eG/e\яe֋NKyĀ6M?p" ڎKP5/8*B)Kt}iR݆+f )@"&?rϤZ!KHbcIJ ]~XPEY":i3+yzMƮP=hLJ)%ӌ6OIݚΈ./+=05)˜N|Xs?켁u}Oӟ6~_{)jt|HsN,m3SWRIKOݸp;OZ 7S??, 8CAJRsf#=*|;L1-*JA ?eRYt{- ^ȀfϿ=EԸEx&g +)!ݦ}R#SĎgZ7]u}OӟLbJK~ r7.Y^pLpǸ>դߗuP%mwz֨^*Vm m9cׄ h4KQV9tܣEx%+VBIZ0㹻{0EĎ]Y O7e*j;bXS6n N>EaNh䤡uL+iܳSV8X4Nop-se4/iNw`K|piR@YG@8H۩ߡ}MExO{`êSNtАVVR'&;wHޚ)<0iAVdPgwJCi7բ!K!JHKeҥIxm}I͖{Cx`t]4 =G~a'"! !{wF.)(RLw=4x¼-w-|uH˻x|Ϧ埽5WI[h7NivoCݞFU[ط{C?Ά&qCMU< >>^mƶ%a顱j\Y ROCv=S(G CTTck+tj~lBHEz(Q/f\Tf?sq lMTũ>M#E=wgkd/761|$.|]*Δ2+fpYFƝFu#>K%0IWji7b1Ck~`ًY]}Ʋ[_/ٷ/Z) /chJRqPez='.?TQ=ʔ$|iבK]VaJi,S*EvjXd7KqMžkR6/Yvҝ/T/Ui)3RO5bn4{z:D[N~TTA.rio)u,>_&&ٯn#yqo5oiYZ17ྀTZNNVf > "F/"R%j?,4Տe#"ȧf;Kw] l#$~BFr\pY+ 3ɑw" ւ 3 Ӄ,i{q0Ջ.Н9$a-?r\җʱOM+3)/%SF(-rVz/SD8p|}5rG̠(og8,][w>l@bTNU>g6mHuwDde;5R.,>h7e/e=[@^])fm![LwlU+UFܹԛzuӴ܃_0wu_vb[C:ԭQuޱC|h|hoC9z=.%k7͞3o\yB55(I\KEPR*.ZށEOyȟUoLssn1t֖tU%[tYN)6@I0"t~;R&t1mA R\K5fMөg?f.ou{r s$#yj+pvs^ռa;J:O$k̇k[1J<Ԋ'3iϖ8Y&+z{y% z1gQۑ~w}=Aw?mZ% ^6#ԟR7ŦN\ncWnG=|X[%t]Fy~tbj^~sdUBRV݇ODv'W9ek{&R4*'s5Ϯ^ 6!͕<)a%nѤ~%\KM?+)q{qz~0-6mݾX`ՖvM[~ݝz\Cywlݸa֤).8oncR֡?oZn݆)'/۵L@A@# P(rDgd[+`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`NDv@`=9A`ND9A`ND9A`ND9A`NDPIENDB`bayestestR/man/figures/unnamed-chunk-16-1.png0000644000176200001440000005754715174322463020474 0ustar liggesusersPNG  IHDR `gePLTE۶ې۶ȎȎ۶f۶۶ȫێ۶fnȫېffېfnې:nȎnȎMfn:fېfnfnnfM:۶ff!nM:f:nnf:nMfffnnnnnf:MnffnnMMnfffMnnc:fff:MM:f:ffnMMMM:f:MMnf:MMMf:ff::f:::f:::::333::f::f:::f: ]IDATxA 0 h\fww 6G@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@I@_vP"H[ AD !BPFHfOrNpyP 5 lP 5 lP 5 lP 5 lP 5 lP 5 lP 5 lPgrC_3}y*{&cj6 2);7o󈘭6'66 {٭eU(qJBT&F*݄l}jhB (!M$nb:?fWJ*M`wvW\3x9 O3  vGtG6-%FR;v&Y v˧l+IgWÛG45Zu#vnUTDMNltk40`Mޙlp-vH'矾\Nr}20L^ɢb1wgb=&l2׭tvKlI +찺xbdW6 CW?$28hkKuu"Omg2`ݍ^Zn)c4qjz&Gҭd3QvѺ/*>י\̺l4&Drdq!;M_8J)c65®̌7;wRIEa@:y "(( C)EE,֊?6aȟ_[1&ݛo?[ͻzqpRe 욭ճ˕zjhxv`v]oU7Vo?~`袪w 6#Lp&@`@& 2 lI`L6d   6l$@`@& 2 lI`L6d   6l$@`@& 2 lI`L6d   6l$@`@& 2 lI`L6d   6l$@`@& 2 lڠ6[5؀h6d普l@`66w?+l@`ڈ lFl@`@ l<_;6؀>6tk l 0~9 5 lٰ 4W"n;l@`@7͗^Z/@``6dLUs$lP@8 b06` 'va([aM E/;@9#6P6 ;P `) l׺L ; g  v@ ( DIv/ lPu^6at6 @5 l $b} I`@ {}- #@/PAlл@M$= @5 l6 %OzI`ОփdFt's' Ѵ=L$hN6d6lȘM03} lH'a Rc6L#@`@M:7 a6m64 a  k6h}@`j I`6Z&  g6lH0 b& Knj*z/@`@Y6Qf6͘ lhE6DĵolN`@;&lO`Њl  > $`=x`lx 6HW2 a6m )6`lx)lD`Y#  Fa @`L@ G l>صaSTbEaH)wb@`# + @b#/W4%@`-I`+w K0G` J6plf> a6  9! L@M9 k @ N@`/G`#"`64#%MClX3 lq6p). lq6q+lq6r- $)P  @$A T%@`0(K`N@` q6:O0 5 lrϿ6lI`[ 2 9 6b†6id(P  @ &`@`#`O`#` G`}#@`@WFzH'">6lF2`6lsF~ l#@`> 8^N6pJ l#A`  LL`Ar!6l`6l)6rQ>6s8N)'vl$!A߂zj@` F l&0D`& @W"_nX'@`@R"i6lhI[6d9.` M6+ `.  I`f#=64 l,$ I`@K` 7> nAE`  l!~ @& l$I`& @U0J`@sl$@`pѱU64 lgrE` M66Lpt 6XCl#6lha  l I`%+0A`& sv6 mǬ ~: il ~> e, 6\< 6ln20FO`& ̋ @`@ E8DM`& L c׎u0NDtjD'نRsnM  & | r  & t̊$6w  & /6 1 l~x`6lI`!(76lI`@`@P6$@`1A&6$@`)A*6$@`!1j@_*3f7/@=;5U,/qG5-Mַh*=<a(Taf_;|eȎ8's(Yz7KQQ` sVfNB2ן?Be0:ֱuenePC !lRM ;qg&+ҵl^I֕t}̹?\|>hg˜c lFaC~xSql liGk<-c 12")9Oʲl† M2kדGطSG>h#6[?w\閾D:;:Vo+۬ݿ2PK- ikSZr-} 9?88܏i'vgeZ<ߡ6@7(-4Ww/'^ +2}V9N_l2ߗb2k|/7S/kPؖ^=G؈4g{6\~t˹\B&AXݾNF*|5\җT,th(gdA9g(,ÿ~5k 䞜^X}d@ܝ5L|6@ڋ*P+U7̱cGr~sgC[l.L&}YSC_ ho$ j4 }@Vm7^lCbpس?mUoLluegnyo"י|;`r0sf'c"ؓo=Mwf.&ܓӲ-4U;}>8n:Jʼn@Tior/fL];/9ƩR/7.'okXSh6}ا6* XU{ʴ?l]>7sH=XɘH",nI3I7sr| ]lEu?Թ\Df6>k[ZQ}[~+.L&}ƯpJcyPUddnK  @,ǒTX^Kڒ(lUY$?̌mUry"R-IRL1=ʢ&M6kVTc`I1&(C@r͎U2}W*`/N͜؝8>{r/$^PC`3 ̚[.GXx:I-Ӟ6 vRf9qa@i9{v 5Ynם)l`˜CtJ`=U6*Kɉ8}2W>sZX2VeIN\xS{23~2w_<YvL_=?Ks?UzXw֋͘8e\xDZ aC'5 IrdgʢIkuU`ˁwKS`&ji/43~J _Qf8wIa㪲w* ^ .Vnp/MRJCyRʪ?ì +ذ,'g:ˬu7o֏ۛ lB3 *Kr2B)%'q>~`]5;V#{>%<|9qGZkr_7J_i`E6C# A3 3CLl 2m& h#se!z'#lZu ̲(X' Z/83Hl6"0F% #`@slq916/ٷcH( wjpL4L3H1AZD#7>܄آB%]BA/H @[1O~*SiOŻzLD5 @ 2 l6|߮$rZ{균~gV` uD5! 0#vF"@6@g(ݏY#lȐze lN@6@V6Č5 ЕѨ_76@BFԵ}P}ȧkld(x$ 36`#i9ZR`,Dd~xٲہTЯ᪩coexV 0S`ߞ^\Ǔ96dwt&O.ṉ96Qb?9v=4䁽g*8󖂉5eҐ8 --jC85F^Z{55$HAÍWS;x糞×ϟ8,G)Q:cTR.GaCRR5lrYr 쭾 ldjr6-Y2 0 ǡMó?RNCLn ܍Ŵ(!h씒v)Fؐkm\y݌6>, UWkuh.EquL4UGKPim?8R lKd9S lGՔң(L`]B`u]jj(L`]#(v v6TOԲ4;w  w:Jj9Q@|{:[͏Om ݮP`^OT > ZtnH%|287}/3S8fJo-/P8kf[虞ޔ5}_㯞 u7@-" p.+g`o|~wǨmaX|s CO*aR]j kU+f9› ߿}S2UsHky}׉'R,Ϸ x \!=z%9[G%`C>}p@qY])c*"/SFYjXru'2鈀@ 6667E}%(G9}%]]"r?w?`h q"lm*#` eJ3+LJ>*"P/'ۘ3Jm TD#`P q @&`!pud*.Kg*}5LPTDJuAYRJ60A(Z!a%5S}ST:pͺ݋\g$K6](M { uaaQ[ UZJG썵(-WJ+( *@|PF$+3k٬gf>pہs?CyǕD[eW4d)h8t `ʜa]Sr6@m'`C{Ruq09i]=S@(n;P.yjg,iƚVt_Miͮײ=wH5kֲETyߒygoNE@ڮr{-y3@~M.3+ HǸxrC?em:P+,'LU@ƚtSXH9###{yxE/l$l r.7gm΢mIE3\eX$`Pu/K@9'rS]d\w$%9]GXSq, sNN9Fdϩ&`Td.""uaޟ! ؽͦm`wIڦknd의_t$}drL_)-q`R"!Y*w̯M5 XM"TNh/`oߒd_h2dԿ끲,nOݳOi>}VQeY:вi^bkG$f['?=ofΉzK2g3t T%դ""l"-$sǓofIXH;gщzr`Wƞw $2X#h#`7{!CBnJb/"@|Eʜ5]f.Lٷ&z^(g|x;c&{1d v -"'ɇd9pwmy咟Wu 6 6FذA⭿ԓ3I^<3/L>%\H{9T9$-$ @o+gXo @el;~VU퇨?XSo7DÜMG9&v;/!`:r#M`+6Fu =MaX|YoF m%OL$ ~OXSOq99@ғS]"{_{/$aC+"㣵tC=dQG*-7}>:Qϼ]6]fJr҂7&jIvvW:@R& ;g3s&={t.`_9;f'x$@$J/M'!N $Og+I.6vAV;QOkYc=D:bzIqCVH>=I*ג7M.3+ HN:PYܞ*g55"sd׾+'~Hvwb\}_ܜӻ&]4mʹԮߜUe8% rEG| `@9'[xƚnK_9gE!Yt[6nz/ YeI}@lXGS6 `tjWgb}߻2H3DEsK>\Kr .ʲAƚl{DVG:8,ɝ=!}h*`wyTV?ΟKLez}6lk!&&&/tEnIU v I!C]+l~ذq(g=6%řRQ6  HNgI'R6`#l"w]-i!+y2pS6dVI l`=v59>'V{t\]|Վ5Z%EN쁡vl5:+_CSRj[ Сb颩NdJТԡGtp)n8(thEG VڔK4͵MbMr׻4oUcu+ݼ dL3@q^Ig=$#Yg\ f`~'ā,{2:,t%[xptbp3@q^vL'8|fyϽu`[h_mFUh%+:x;\rY;w.|bsk\= g#"ÊHK)c̳#6};6i`WK) {Z_4"ک27j6l}`U#FOT)l& ])VD2R R,gGz<ܑ~T칫Gz3T]înݼ @,zdXT=8a|]oc`t2r|^Cu}5=t> w>,%No ^`|l_b[ ;Nl؈ꚿn5 ٯ@Y"8Vr6 أTC;_98$i&TV`׎ʂ-o:_zPxppص; 2oo7sxsLБ$}s~=IZp.CI#~0d˞h[g`f2p0}V7z2J)~=H,5ђ2ots]MIY@I"Yɤ%lA`H恛$t5k6 fYM# `W. `J6 lVd+ l@`Qn4kPW׬u][(@)ly9G6 ع8w̔ԖPb{WQe Ja !q0WbЅ"BJ)VN;dfRIu-'wBDu-חщC6|jv 0 %]x̂u2?p16 ( lG7' W*LN`qJ)S{ x X`(EgC3ٿT C0aCW5`FOaux?]A+l dJk du5d @` k )#= a4-. @`CF6@:K @`p\_+l {Fᤑ }i'Y r0 [>&#aJ)ssdQw 6Ђ^ sIsL`<60Z2LِQ#'? =d8@7jd3i_Cf>Sw~{Os'no<!1 6p^\#60u}78[@ZSGZǺk46rX5Sb7"d%2jl CbטA`p6ΈM_lZ|k 55@6ҷOoD@`!$&玞9 `~0: (%Ba6D[6t)3G<Ѕ͐ #-)ljv?oA׌p͔ Sζkl1c];#b e/6n<"  H3<% 7* l |+q Wj_YJ$aѾEl -}zd ? Efp?XM` A`H~4'@`ʀ| 6ehO`9#A`6=6;' %{N`(^lY6lؗH6>LxY6ЖDKaH`&/"c vcG`&.)m 69 XI$~3%҂P!67M#6$Ll୾.#‚xY )6gJ_4 #:'dN5l/װڭI D@" rK5M3)EH$IO@NNl$IK+^l1ՁwA. dP؄6p՚ۓ ƨj^A`ܡYWB[{D@9 lۜ=&:uf  6lmV)[ )l agJaՙ66=ꁕ } 6kV)l jvA`þR7i׾!Quf36׷(Vw&5'ak8DN`}}nx񣀭k`,, +@Mk3 `@`Ű `58fXxB+ 2F,eg1F |^_-lhJ`6,2֨[^M lŬR]U zذYٻ6vhE" |f"'(2Q.҅5 lCP,k^<- [ 8oװ& ; {]Npl.6# sV؜'z]ͥN } |\=reE0DT#aC_' >K_C S6@i Q6@i l8i$ 'E偕6@]zLE lZ6[XP Xذ>6{^ C6pA[^ ;2;}Mr3-l8w4y]ۀ†WEkW {R0׼_/7 } [sz?6la9QȌSLPvl a<(SFyE3`؀Q|M`bC66 Yld5;F} {6&l{xٛzF;t6uT&!N ؖz[ؐRPؙlE\̸QzĖgp_=ؐPPؙdkGYY ^<揪6d4u";q ( ) }~挃 5 li$vlHjk'/ }Cj:f"Rv$<NL# l3ą>cL$l^LR%׉m*)E`zy[aSJ6 lXXwN;]=6Iuk'tptRuP)pÜaT'aa#HH_m3Ȕ aeCic{Ý#f6,mĻ~bϸǔR \lnX=s9_boC& 9U6@v6@_Æ+  1lYאE`,β⚡%7 kAjV5ؒs!"0q5 OI.:;;A`:zwN 3l(hYĻO09 liÛةYW}mI`QnX9&cLJ~%bg *z ?lVoUw{ pj\ÌxJ|& lePF`(l"dC97POkΓ3ile|X°њ& /һ?^ /")l\aq <6Bx]ׯ*amؐ] ksPQ' /5,]s' lxYX} ?Cap…5߯^Ćw X[i]q0 P¢xBXZa4lkDIDK' Al$lt||YQݧ 1 VR#`PjQ_Jqæ lmP+\ZlӾFl6v 59 8Hx o< B9i"6G 0 o A-1Vn%`p:Zs(10RK7`!1pQy>6\0} s+8"@Nޅ 8&xG+1z FLÕ>ђR;l` ݴg`R~]1)WN.tTGவȯ՚idɑ՚_s9VidlWWi26FD@oy3lx^qoG7aOlg3V\OBzG "1;jH`[DzߓlM]'#`C2ɧ#`@բQF/ 2`)o.OV#`=|k`E  Jq$!`35{f?Q V"hG/Zs[DW7)eޱE%#r6#Zsf!e~^8Ҍ7XhKaKE A !P(lzXH <["=(u/"вZҮkɚ_gIgtgy|r7<ϩ죯}/cڙ~>_?~x]_U س7o_>1[Fr~o/1Nv\HXJN;ojl]Zl];#A a]gJ.?G&`iiv~1'V̵?+\5LC`:ޒ_\F2Ulq-A}D/+"0aʯmIf0-O}}B:,Y#V&`C-v{Q=Lъ̕H>~oGdgPSKAv)$ 󌾍h[M 7@A-1l#'+&57ZG|s7i~~ }w)JK= _>| inr Pdr|`/`)`]8}q.L&Ǘ 2&S`i`/t7_C~8xMY>(b1@EjD2>e 2=0_&pkO#H^|4ub;4(k#WR|fqh}1bn8/lK=90fѥnq`XS"_Y}/rnq`cH4_ pc(:IgE cnvQ߿/5Ne# ыhjn/KoT"i5P p}|{9TQ~w\JvL "MVO6vYjϗT4U흊I߈{~nP LR/ ,xJ@uNZi5aS tM%TJ:)]NBrϧQ9;yepq hԤ:U3GS1!]tޛmnEq뚎GmDjJ *mec/l_ Wsvj(k1%"w9RQ.@ݭ٦UK)?/(m*;Ț"< qoEuW] kk>bGDO?{7mfQ*GgE]jF47#({fm󟒮́Oc`X"/29La$/F@.#]ٷ>?؍⨙*LJm%gν\_}v9Mqn]TvK< `fRlbU뉥?$@ejþ.ݛGÝ` !=PnXAܗRg2oCwZN< `*CW+ߒw{uJ'[}JQӋwJEvbvxCjq&ڶRysrͅ{}!\$DE|RAA)(ōt!*C7VD+* )(7jk:L9txr84d|VCg~ g:+إda(U?QYVl gSLrbξyL9^pسvݗ:͒mV_+lLYm.P0}U|{'&c;kd5KG?.}>A}z.+oڗDg 2Y -hJv׫%jgDҥ٤`6Kg5r]͋iWz7ˬ?0LwfFˤ R7ήV_^9 0 v7p a~\"yc[zzYKG˿R_V[^9#0`?B1|b`ᬡf_f{X1KY}$+H< M vy>&X^-1f =?{J]`%PSl\*]}&hE]=|IS+h:.(h 5S_jL;1ѻ?ްl gߝS-R ϼqk m&b %:'W^:ľ]و"~nqL }7'~D­N H֭~q]E7~ 6`K6;."rCu f.8~}Si>M jwD hmްdȿwD1~xޛ\-COz#ԧYl ::9}E'VߋXِM;UIvcݭKo/t}+tfE*l҅*<y 쬨^߯,T=YL3/ƈgＱ-շcڛFr85 ǥgw iwV7h`LɃ??q=KtصүRcM,$o=űqC37ѯf 69ܳ1'>?8މvr幃Gs#WHZ"ylr G~δ;&?_.q\WIENDB`bayestestR/man/figures/unnamed-chunk-8-1.png0000644000176200001440000023674215174322463020411 0ustar liggesusersPNG  IHDR `oԒ=IDATx à7h@7n "q@ ' "q@ ' "q@ ' "ϮTq4!jq*Ѡ!~!4  AR[SCsƅ.d"Q(Wzq 9^Nϻ"'(8@ D N Pp\G9;-_+?~&kHdjRږ/xĶ`7RMͯgq̠Z iSJsr ģft83?z.n[؋k=a[ｏH_vF_?4z+tꇻSN=݈9p9:[K?<{xbߍWVv̟G/_4z Vw8bsɭwm`5os?/Mqߟ?EaC$R RES^Ì' Ȑ3pӓ'k,cQqA^N)P^][>$kQ`N`rJaNP^ ^dgDߦ]COYN,hֆc+;_7d|)׈nۯKZ/Sl,H_)^87)Z "Amؾx7/6$[jAI?q90`9F Y{O\Su&%!w ̐{q<;i288.MKxIH!9 gD[LLOD{@A9`"Oʹ"|*Wo`7J4?8fkd:Orzx"/5Z1vLF§yp/ΥkNOi/n#3)}sTF gBb_$.p`D Lray?- APZ~=`<e[?v^2-5 q.(q2:g'/|Ά#*ThLVEvy5ku fYӧݹwpmK>aCWs3D֊>C$X{HjO#iʈXfl4bٳO1ǵ#)2/ȄMԤcCL>3MɩF3⏎Gğ ry-LWWu5a5[v ~:S]  Tp >A$RFRg:,#Ӷ_ifNпk뚪PPYaIV'?A|ʖ&0PNjl"`ǥj4K+p$զyv`϶uKgX+Pj2Vã$; Z| 44Di7(^HzX`eHv5z4^Db|#_1 )BkjQn,?G+:jPΦyC_+&;^X},oW KD4RvMa+?ɗV j=ZݖhH5{Aœ =Fսz).H蛧g7Mu\mqb?A9{C{ zP;5x[ٶ %Ӑۜv)5cr3KK5gN+c^JoZ&0e@DfN? wԉo^aގ5EPj 9KEU2L؎{ -=+D<)Y{ն5e_G*SK߽BOcX!rܒjlw%OM BݿPSu؍aIT@bsLV0eB舺V? D2_KF:Iqg0M|b*/+*$ K*q]ZЁ3­AaYY/SW͓BԲG_Q~h2L@aJ(9'&s–??V0rh Q|cuMڙPB[;Ƴ"G'52D@Ro A(UFTIQEF\l²n -M⷟M[-,:8okP"ʴ4&j<ͽ#íLV>ҢWZPK)v%0 Dtڎ8T5_ BO=/4|(UX^x~!!2ezoY[&0(!Ԣ'L eϝ6bW4}$7m6t31Z&ĚHL/ZQa 5xvh#?>QSo?XD95Ym3YhyIHXz({oYrɜQձPjƌCrFtYdw7S]\@o *w":P U/nsSJY*3W4>([ 8bXƭn]'>('ESDEvDV Ƴ|wj{ *DXŐx y& 6M?5RYIK6L]/"33Qᬬ8qiԌOLԄ4FϜ"]\[ʨ{xFJ։}0rϗm4]Ɉ&*us&DӛɼG(R)&6eL螋D aZ'pG$BHHt&ϓ3Ú4eJaeFZ;սK׌Lt։giOHRIF+tbV! iH&=ˎ _cǵ6!ъ=G"H$vm9,,)QG^A&u *gu&}FD(&vv*ԤcGԕw^9z%/lQÚʈh#?~^T tP낤VNRR$jcVEB:[iWs;呂YWw} &*y(BĦ a}xR=W*UvDH~Td.z2+&^{ʄdHjQ}x%'ݧIoMW!ry_ISjrD]M=Ӑѐͮ\=c5yO,75%1\+uƮ>S~tz{X;non9׫ #:4iF66`I'l?9>W2MJH_V^mK-6ʑ'JRd }P1%;G aW m>0'37ֽ)ˈ{ç.\\U!7ij-e$C[ vJbwd0B(0v8d|)3#Og!TbQݹs:յ/MiYDMڥڊq7QJcH`%e3dNwDqhD)@KnVX:T5D,N{U2sy_XOdy APb1p`].\FJ@^^~h7v$PLwE<846cKDӤVsrbK-,(TkVPEJa2Fs ("ztmmD X+-zBH!(gb[Yi_ 4:lt- ͬo{Y}avloɼ`O+78R)TbdƔ/( zy=:}W5obt&-VN4v$RpҨyTt`sT\&|cIIJA<=`ß<@%5=}GN_/;N\|&Esˉ8h{i"W *D؋;Pػ%7k Ӳ_Y$QCuoŧD4gdv l()S#v)vt&\BR1%*|z*ԚQSC sP1t2@pv`o08fX#*TjdCTVs"v-ֈq}kjT?3U"a^Pj:H'%$àUvOۏ݊OJXe?%i&9}jE}ňwV^T v*gErb O*rD gJ&V{fIH 1j;_maշ"|̾粙7Ri}>Uw`Ǖ[L GݔD ޱIw`"DEФ )U`sTZ&|('*Ԩ^|t%Bxm5{ M.W-ЯFH4OQ{/ ;9 "#2sn$^q<2bתIccTbR8X;TػMimɚȈ XұWsV<&LiVRzU҃ u*OE)ԩ]+JTDE֤6_$Z 쉱}ayvc-j:`h }xC?6k'12?נJC%1"ik6Qa^fD4 D+wh&%>wǹl hDd5 w*O _n| >=IaDĘƒ:Έd-|WؾKp}5_WB #_­/X)'eb*ztmmv!OR*yD4RɈ6qҋARwdTK7E)Hyk߯vk?;ʲ`sT9Z&(5`4FTiM%DZZ[Ra*~GisBSx=i +D.Mt_!x-չ"0Řݸ׳(D)h^=,Y&j7IEɻy&xU:8"ړ4< ,W3Ŋ O^b ڈTiy"pu>)}fHePʸ ΈވYeqKuyQ >֑0qBl߼v;6qyIbM:ξ{cIw==zk;0eN!bHw}PR4j盅6\0ExɓY㑻cL Io?q6"L?[u2oԯSʋBw|o[2a/єR|jR O^a:t0"PZ2~(eJӵ[{AM>9ʳ(!*jDP资,a>yAQRj<AqgqKɇ֔L4y@9˺G,|⭇^fs3^߿tp7cSJ?KZPZ~lsŻ1_f)9o^?8{gCjj6nAw]ʧ+:ܓ8 2r*h-i0N=RxW>]LZѩ;N|s[ӥnzU2P Ijcfg?RLdkP;W{M9 /|>(-|p@i3p͙M(yYhܥmV֪jmMM ZbQj-{ 5~OwHͽǴlN ;W )jɼy SJJaa "EwO[GJ:Xi*yEBخ~n\RZ RZ|X~(-C|p)yA8^B d!+U&&O{+WE>y3_KO\19KM7x7~͓BHDӐ.2 jtv%Zj] ڲfcDxjH2"TAL[~d\b2nKƲ]!kƂ!uʅ.߼.gՠ.seJaPu?~Vq5MeUۍ_}&"|N9f@u )I=_?%Ը?+y0D$j7lU~n5M(嬛Z~2bTg "a zV7 [rjlWRV7Zwd'*%3qT*]?\3~ XNޥ; xMLψ:bb&v-ܳnɟ~Z)_j~y.BubA%ӹ⣧3RyQ/:R9Je>8ʨ.m\:wҨtҵ_),xfU' w.9j@Ϯ^=ŏ`S>[Ex5g:יuK?6jPߞݼ=}8cѪnĦ+7B÷9G ߫{/.>7mwU^YJw?m~b]2v.}@2x5H D"q8@@ N ' D"SICϮ` H~Q(|/- E%[[p}˫ +B;^o908mG2d" )c6]E;:r2EO~3wo~wo2F D@I;;d hܼ_ylF/\e҉Qa;_f$隹5"фE>|C:\X$ڏVTVW<{E"7vp3͘ش3*oX\ek&.{6Ei&=ZVڎ 5ǵ?!oM0>.Y[}(m"1s6oԚd3j"T'uNbFSgkLMꈭqQ2v)l-ET[&>ty 0,EB&N1 /:D͠;d0z"u"uP(zj(5Xy|2O-R=ѲGzv7#QUd mEߪHӊ"""""""""""6P6\c<}v}R%%nJFQv e!Itib=*7E!'"NҋX9 N3pLuw`N"cb@Pgnڿ=%üsD@ kE 67oZ&"!R}]qmljGy\pP e3wX $y32%E]u-Dw> W&aejW}}춿2Lo ,@ܨQpgϞ(𧻓ceeŋzô3*h7sgTV]sETŊiio)a}.[Gˋk|,#Τ[jQ>IuC6Mcj#FcqݵAo##^9Y6Xy6\%ڛ^3y:M :[)yka솒9S^|Fk[._6nf͎Eci;;TcnØQ4U>t-TMΉKz>Ʋ9D:ApYG8@;x}Y8@q) lzo6(2d~u }_RC%aΝxD$0~.(>d*8Ѣg?ƅ$նp_> *}(lV$GCq;fnr7Lt!IuH! Um\@0 p0 !Ϩ8"ZIT6T!/jx9$HF`7śR+.s ,ݺI~Kq"@*9k(&8( ų HJADDDDDDDDDD-f(N='On}8@r?"_\#,d [M<}rDDCp!Z; )\K',CҢL>n|7ڦ!3 5s1b̮xRKэq9 IVRD`!8XF'xH×$Ad:3 i䟔pG:HP$Gp]X'߲014f-IWH'PWA( YHG4߬Ux7Rr,D(K2iNtD}rQ/U q.0^$C.%bW^mfh݂+уvC "Huѓo]q19j"Їm"$aGD 6+ܴ?!RAН3ԋڗjЇ|IB[,[`iGDDDDDDDDDDDl3NvE>fY>T_K}+{ nLC՟7͊~h>z(sr Dt\pǃ ;KmP 뛾6h!=+(,%ӟZJYi ЯkѧA2F #P (~}>akhTE?A8H.V$k";sMdſT/lDN+7p}ٝ?ykGq1kJ bn\u{Wm4у쫯FboW[CǺ73|‘Ϛ^yg=>}sϼV${E$_BF*]-3wւ_^sc q2ڇL($N@LQ(hB?v[;:T 11A C1V(r#) 0cԉ nБڣoWi-n$kjV.5փB]߲ݦ;;~Q|y }'{6] 5E?xD P+'և. #H/ud+/Ԯ&Z~4T6 9=/ ݎvXUL*#!~ (I"P=xalሑ?G^y;tQ7)2[c&o2b> &5l5c K5Aj[|gBD iY!{,(l9 S6H9fs]HRDޙ|»ni(dH!0b4Tu{} (3yqX bl_!2p>eTocIf)fY'ĢC,6II_oݶ>ϾsWM%ko-|G_|_|y'w7}nT˿t+Zw|ksӎמi'r{~":֖JSq+E79%HPփ߰Hz *\(lfȏu_6nxlW`mBPd˰d6idWyG¦R CQ/7=%43UɏtLBDDDDDDDDDDC9{շ\x5p匜0X0ƷLEiDq 5ՙ9|?5󵨣AQh xg+ OUڣVKNdy C:̨.bz`˅$T"7)XPd)^B6rl d"Tˎ0< Pq|n- |f}!U8l"Iܧ-h19q-hq:8yp0&a? T66Ehѱ-PǴhD9=:oE:Sઔ=Ԋ|Uh(` AZϩ~dDR̜/)Z|ޏ\:M ?VG a qbg#aX NmTL"{9,}2RY.d!AQ'q mk,)"A6 v ҪpDo~.݉`П: 8%Lap:fzP)";k$U}%HX9.p03QIlF'+tU10WAY9ݜ2ѝ.B Ƨ= K@B cHw#IҹᴴIa*TF}\AhPnʅ+ #c+W5@|d=э5Z;vD-hzX5'BBۻ&VC\Qu5ն+l,D'oS _Zd@ kV;mT5T7V5T56kO٦ϦxA"TV<DDDDDDDDDDDb7N~dĸŇl<8hp(tpb~|7iG )' UgD Y+-USу!'zݨ6AϵFc 6-*@7 ~pwĠu>䜖X@"":4sxꩧ@1D?B;%A"\m0ț.j$ )>dH2\ s?+-\W"7GFri B/6A6rm #T! p786AJ[۰M9. @ӹܣR)r1+xK>aM9.]g7gUSyD~UmTu)3^V3N,1OV% $C_ ל2+X[V(zhc3Ft>26ote\.3<"Q2^(V׉" 8VeŘx wbXQc6J-LH,نa | g'SԿ@CJ1rFZE cz9d"e@SdR DRL/gJ"P)ΓL"X)d"D80lllWf/ADPzY\Zȟ Rīoq~4"ה@}CJ9Ϩ1%Z*NAM R5בg~Ǚyqx>Ĕ@{e`o~~>\ϳOK+oL l"Dlooj"D 'F uR H @>YXXЈA @￮Y\\ @"@F@#SG $ e҈عc ߁% A84\]\DDN isJxYbe$'O2 @|)@l`@`P<@IR@4Mo H B#L@8J#@ $'`uݾ*m&D z~V{4"QD@ڌ ӈD`75g$"D4"xFI D87&_ ?@xk"ò,ߕq 2@y P+@K ӈD@VMT+@@ N4M(4"&FEA-Ľ8Z!9% DfK;70ൢ sD4"@pVQ]"@}@@('"9󫳮kW;㳳,KCv@ 45@O#"ܞOgezl F&(N ^(bH%hDH"@'"@ #(N Dr"$'l 4"@}?:45뺾;۶5L$0.@ P@DN xwahC#0 <7A@ ';( P*Q*CL ] 0`0` sﵰ~ N `D'. D@(@86'Ј""`@?0Z_y `D `轿'hDN   DuQm~&ye._d D4"@8('""FDpp W D4"@8@8C=iA Pk}M)@X" @ @au]0"D*oY ;wAqx`-Ħ`lěxO`$h Sh\ŝ07xs}?^  D D""FDp9""FDpp#"@8 @A7#mV `uH4A `D'Ј"DLH]C"Uo2f cAN N @:tp?FDdp%#"@,gB DJ|{yzT@,HaϷW[G'gLJ{;iU}>w 2%244-("P1MLu1JK6h$b1F2 PLĨeQ,I MW5. AI;svV8g]N |}Wϻ]댋.⃐=7VΈPJ Wuwɔ9OޞK# ϝ.l{|k7XuiU~c1ɏOc[|Kg l_rk7رcR%K`Dh"m®o`틶IRy|OԙO\Dt{s>d_{叼(s[K,_ط䄑7_sVM̞#׌J]I* ׭[%F@ i꟝\$C/Sc2'͗$ olK_kecIǾrØePfm Dhҟ/ԇT uALH>ļz6 Nt'"m@ B RFQpt2|@E6<\Is6'Uz7f~p-^L,&z6%ɮ{ć7#"v&ͼnHSv(*?y)qp+t窕sq4,>vc yqg~{A5D8luEQRѣ3qpI=;4[F጖[|ڞfč3/PNm D8tMo(+92{DQ~sƺ8vxMdhyrl>#!{.|DDRwW]!d@&i}}}P__zJEEW{գ yHe{9!p4۲e9%,X@ iv%Ѥ.%+II$CK!'Mgwѭa^LjpL^wDvJ9ҝof\8|;c&? jC"DMe(Mhܦڽo&]ġjXxu<}*z ӽ?EۙI 7 e=, omܰ)E?R#4Gr.:Etxÿsy.Euu} 4"C Ҋ{REEkmOO> ;vh"Y?:(ʾw_Y<Ee=5 `ߌHkV~A3Qֽ8E iOCg7׈O('#Jh D؟3F N fxbe. ʁg|ğ'EQ+}x߸~em@ $]MH$[6_W y\8ߺez?5"+4k{fԇT ? i.0 #vQLϹvǾ5,6qƊld~/gh䑩S&72URVùW_9}{ NY+w5 o|aw{$5sا܊'_[b+"`D8j DZ[CKbqq6|wY滍i뷮[-Ui쑴;mҝN)U93=flif_y+v riHz~?z`MG'㬺5{fpҤCB֖mPtQATtpv :'9~?]DuQxp96𸏿6'ۿF!!_d G? %"-#>U- }CGw';32yQ[GgwBgG[~ݭb '\-ώM/WϮbV.Ý|>Kjf`d9n3W@njPThg~шgG3 DRN Є,"!˭&JhyneمbF&~"ܰsD0 *܍"TD@MKDs"DD 5 L`@`8@}NDd"2=DĪΡ< ."{-Dq"D|1jTQO1lN]v.2C,7`i7{HJ+;AH B*'p=-nL3xl 5R߱R<L"Ne @6UE3}#l", o-lLJN 5@r" DȰ@`D܏$'`a>_Fİ@j꺾nL& $' moNeK` x<  "" D0" DHI"(`k D;&(JK, i=E4X9^w9" Dp" D~~ DC=8"lk0LA @'"@-?Z@rZkD{8ُuN0sܴq(!S :"UFz@桨E"',h A.nAt a0ۮosq8otrpՕ0gV8踌@ qtKȾVl>:O rV8 ɽwڀ{x@bD:XhQMųƴ>RhþSQj踁H,K M۶';ohʂҊ@;&.fl*_}{6YD Gw7yWu1?4:L B+n{ _8?N-z] E+4!Ro9˶[h!#"b5.*IsWnۿoGg57)rꝍ>}&F"+\ε  I[<3>料 QH$ FDSxRdИIsWnpR$I͓߼5# =:|>HQQQ:Xh{'EvZӓ"Qѝ U_oo_~p}IFD DZ>)3"'{o65} Ͼ諸e:f rEwرfgH UT [Ts`CϏS4~=[ '@ڏĉWċkBdd9"s+.r& 爎ocl m\h^f3nEnIrYƭߘL?VSg\2sܝ_kRh$jط۝ƈЎ%Rҥȼ_Q8.$ܑwX+?{^맧jQ@Țs6~kzVpKmk^Mg˶>5ɩ@u@r˪xם ]7s.d䰁Mv!KLG%i <:,4"pj@|-dӑw!=yGfZϤ ]rM.ٻ)8i׵h057sC[nIBrL0CA ¢K]ѡC!{.CE:*uzw{qVQt7$зJOdB]ȭ#c.ͷNbђ{p!TeÛw!6b^2eJII:qӣv?{w ~ϽiKc1^ݹ}㧊`ԷaH_j#?6fDJIhOM kɓTd3mRVl166FD'gbVrV 產}ly3q"ϊhʎ^צȳk:sÖoHr!GNu#>{_ۢ(!???XS"hnn@Dע 7gڴv(`ͥ}oɉi%+Jz:Z|8%7Dg#"#"5Ж 'FP0{]=mׁȧ/--Y|Iѱm]_:`ֲKw4~hz]3{6,>o'Mc`"_^_4}ێRytUr[ѦtBv{@$q٪u{/rMLw9JL+1'Lhf54;,gS@ DJA-~xr9q MsmC'axgf<6d{wդ_.!FD"cgsq\~;g$ծ겞=u)Ohݵ`o Y|036ʼn4̝u\nxdݸf͆mux.(=q)s-̛7/dDZTv=yHҾc~@ّ}ȯ_ݞ=9aƤ!=*t<3ǯiD^f-08UPWW@-W?sƼ=Kz>[O|VKgߕ툃֧'ґ״eάwm-FDU"］@.R]8aE8Vo,8~ϠK(Ie_ٴbŶlpFVF^Lm^dC& =4ծ'Y(++Buuu$On?ٵcw6 Jz]wuYհwFAr}j_ֽ:y;wY8Uзo(J#M*Nܞ\:uJE1+]RVsMCEy] L"I$9x`ӴvђmMQq-]SQTaw&$NmhMHeUeMuX gDA}zDqlF^RұcE@$]}E#v8ZvWE^ұOEq/|٩sTFDE͍זF^n1G:vqcsѾ77EAikzg6I]ڷߧKCȟkk~wx? bՖ(H0ЖDa_]D^vGxk5fM31 >EARyW(c?~t{1 p{>8R݆?9SED2ۗLy)QDɕ#GDeӞ6{Oc.%eqSY-,>8H:܃sծoq~a7r;7HI镣y3RH:ǟ V^<:'2 VDD٧r#?ۥ$$8}$N 9Isg}wGy(Q~aﭜꬥoں!:T]t9𮚮eq۴f$+[;}ȁ@),t1|m@"?r: (@$kӌfu'N@c'e\:wWeןXӆd+ֹi[;[vШ-o;818 "Iu[qL;_@%H~{It)zʬ 5pD޷?.v}y%Hꁙ蒫Z 0"R.vŀLt!%+V-Tn^GwnۑJSKK˕EVX'a8M.J];~ޯVo8@$ruS}P6ΫIQ) D"{٤kDDaχO=dGgFHK Q>bg"M7ym@i^V!TF޷pբuHڷ7f/Y=( 8H&,fGTe"9Ɖ7n܄Gg]t/~}sO)E\Ӗ-D3mID$-,=L}kC2Q<"2P$vo޸qW!8^ ! T5iwֽ-2FDʢe)Yn"`D"wZu9$ 5nr &3eL);EjNjPm6[@%pDr@8:9pws}ͮ# Vpι.?&աC深u(FD= Dl\Oo ~ýz~Dž7W!Ze;}BPr w|8>Ʃ^ezMoYl 8FÅxW .̈{pkH?:D4;~ẻ`DN@y3o}YG~fXِY .ؘ舼e矦Œ5UUUQF@9i3"}Xwž~~jB@YK(l3n/kqTrLo_w/4ߟxSI/>vڒfD:U=ڵk?6>Ȳ<,w}4N|sӦ.kӆ\YK^}ټGƫIGzM= /ݒh7o=/ 83o;p8,/X Qzu4W ֐]utϮ\́ݓȜ~_oD׭ 5>=Qrͯ<ԫy9{#=8Iiհ>;ie{MGy_m(#iZaEoDQro}qRoܣ_d$+o\t,;+:8h]J%4JA%s)+_"tEe1GqIXQj饟5ݒw =4hӧ>SCWt{Njcpyt "4Jⲻ&;?aɔ&/'_5v<Ҟ#}=@ill|8F(WwUݒ(osuç>W?[ܙEۀzJw$IEػ꽏ߞQA1oRQ3SKKK4=%ӱ{.zyKٽNey{JMKTLM;0b0 ^|??CB`ۗ>k`%^slՄ~_{/ tNZԸw6r6{ntMO޳e]?',)Cڕp`϶sᤴ38Ld ?_75asu^B!eӜgG-ն ?3JSJZΧla!ә1c/p(ޯ o?4OPM6k6եZvңGuMDZlQQQSR%Y T"6t*]r}EeC.rF F1dfL@%txb K܍1M+J ;?,]=Z|4R&)x.΋7}=3a꿟Y=Ȥ1sƿh*Cʐ-2۫7~1`AY)ڥuˏ\΃7uxl]uc2-]XL)uz~YKWϕR,JTw 2tU{w-mؔC9kogml AQemoMQU#7_-PI{ڐcej):e>;=k[v{ﾣKˈJαҷ9I@ ITj2M0Jܲ kuCCJI.e :Aރ;sOsk_W[91n1GhWҏ?ѱG9{~)}K׵Ie m7bst>c>ӥV j;~[3@EQ^[*a.b+frt~oI|XP.?,̩SY.QR#JQ /ӫ-_D#zrG_Ͼ7;x)GA3awaCg" Ttsm[Ït G4*6W McT5/J0C|lFҗfvRJ_:-_e7'DpO>~ܺHK J!Gl;`e&n=lJ)x5C );J|㷿KY -Y2&fm{,-W7l޺C]չQUܻvy˸UF6)QmڶLg].i,EgwçV}-C e&M6K B@1:sPQإi;pʻ[w褩}2qgg:k??5:,.+yLK썛7 ٛ4kbo@D>)lRdfæL&Ea_sԔ\*EmL^ETc>9)*y#:7l}]tp(/]Ӑ©ʵkW6~A,p3dYWim\27U.]}}{nnjѤ^hJGIgZkB QFuC|ܶ9vʥ>}{ܳC5z?wWƭ?{t([n{K>iiiW8k.%HgJ7r>ezmtѥm5b 9 {m]-\%)Dô6ǍLK|3ȩ*L3(Ϯ7l?'\Uk=\$Zt.sv)1V✇>c92XI!T@Ո淜};Lc?lգKFӆ1c[c¹scJDr\9Zʆr62mɴ! Ê+'lIeT/^>yd_:~᳍{La< #_ipvk 8 rBʀoICye9DFF @`H8Yj~)5K`/-zUJ|SLSa(cx,-m}CCzp}wJI.m_lve ҥtxp-1V3$on!P>":}Ͳ ZƎj %J5vJ̣+II*U⣳Nei>FjU ) j#/,"6KڣfvCxy{ Fh%CcI)LI>Ie^2jadSxI/Fpe(k||unD79haLAl#XIYXbu[됲hޣ[Nؽ7S ?HPJ_)>-9T-W7uZrԎeHՉm;d r m剏~R #^f7*)3KU[\)DIC )%*JJ|޸]*[7tKa<7eXyeR k 2L8=%E!%fIiQvMPA7uiTy1+x`VBL~SrVt,aje/+1..GN5K{B{鐗6<՜ j}u )U$voY?donx9o՜_"cD(Fx]+Y,;墲b~%/0!㸱y?Oc_My/{Ӟ=@@R!̣^x}o>>2B@qE#'OgLNյI.?},ɥr]%"T!3ys=g/}Ǐg}^p'lﻰ?\r!񥩖Ro ٳ,Yco3ݿ|Ho,ޑtҭr'-xmhtǡ|6/DS%^o>2HI.mv7>Ybml}pƤC6$\*_a^8ܜߕ1+M&eWR-V`cT DDNx[x lDTX8I4, "!m&jϋg<7}R` -N4VDδvs^L .+l6_Ht: /%Rw[ h$)mxC뙡7wG=}vcL-_]nUT94;J6^ɜuul4 =L~73i.YJ%*po,iG䝬"hd,*a+쮶6t5ڿP_ٻ[0÷s+ͨu "¢M,+bxcp2F#2d "2w r?PaHN # 0qR$j1;_ WڛcA0"@ D@#@r"`D" D(vHQR0P^ 9D@@rЈ@ 9ffH B=ChZcA@ 9 9_9xHE @@ 9D2+{k݃S@$ޞg; +[Ǘw/Ȉ;{u]q Hs\\cyLKB܆y:&$ʓP4612Fc & 7pYgcz===>/k6)Qͱ7.{+}•ߪ 4@?+;wj+=wKˣYVVVpwY&cQտv߹y%>{f-TPZ8KJKK[G~~Ax4[fح}H(K;]:h~#@"!5 n컆\qQzC҂͙4G㿽x͎w4GFDlZ _w>XsO_pJJJ&MjM2%###ɯU8+bv]zv!ic8D8)! |(YYYȑ#"2"@iHmo5y3iZk3kQ"HD j+::RS()EbJSђ9:hA*C9GH{Jr5$\sw-r{wϋwoIخF\vS l. Ff$C#cjхqzh0 6RTTrܘ:H-C l~ryqq1c65'm1Ic־[({λ3ׅ]@o1"GwNL:Xaz vࡾY "tZv_`Ռj'˲ߛBN=CFDhx]g&L־T^ pbU~hy(!" V 8(X\\tpPJ\ Y.]ZNj 歋• Rrz}p3  } 5i9ߖI4n;]nQw=;qn/1hAyeӦ-OJ&yep40xԋBVzՄq 0"@" CV{kR'_}dȪ8oʋFZǣ O%IVvt/.™gzCTJdŁ@.~;Yf7x^ u-kU{qZ>cѢE3|'[*  7F"!եwI?&$޻go$[Qsϫ5$\suSҟ.^?TEf˒m{7mvehD@$ukEټc '.vRoSH$QPP'[԰ݣelۣۦI^^xuդqsdFDH"|sω!/?et8n{K=uᰨmOuЈPHH^&pPn-1+[^3VdTӇFN߾I#H][7Ëޝ GQu]~t E}m!YW=2b3N_t<B"TY}woOqQ*;sqwXמo 1z)6yQBNZ5n_Hƿ;D4"TgL8ql^Du[wm;k0sFm;m-Z3#"Y @0"@5"=}Ʃ7 (Rʢ ѶyՎLaDv!y"Y!Wn)dǎmr̚5+y" #;^wa8rS&P=ͱyFDB- Dv|#,hq:_4 {ndFp"UKqЂSE[ZX׊N("*(V+!,$ zQtB7ӝg~U))0{S Cmw |%"Tj {9ȫ~p頋~MZ.&. XP^Ѷm*!=T]+gvhԶM(P.ի7}T9P1.{lDߡ\\փ @jPH_1j8(Ѡ-W+icDQFm:tzQ3XVv-d<5M|zǯկe@$~y[D;f-ּ5+/_ᓼw6= G?tgVZe'&2`ӖFhp&o_P$o;Co;K vՊ,܊pz]W' lw,8h+X{_h9~5_ȏdwurSE6j41$7-Y9YzZ _~j_\Ņ!AyR//G"$Cݺf:|ZQد(oqH)o^ݨxl&Dxq(ָi'fءuZ(VqnaH-a͎_)WHX"P%VXP )n&= %7#jn%Ѽ78GF#P]%Qe̎Bxq:7M+HЦezT2{ $!EkrulV2hp8։B vY"P@YuKO)Zƛk,x+gO8m;J&wq @9ˋʘ:uЈT p~Z(أ9C*m!vǡX[N@$j>HrܼdD=^2򩿼iY>{֢W7l8=_%"M8❋&]0;gPFgQd,qڭc_ɏá W=y9{K>z-#_F:ITFiT\aC7 նI pP.h(ٻOCνѷ~[Gٔ D5z 3vѣGT Pj}3p8O(^:ܚ5giԸU7l1WCDÁ#KIZn-K.,BDΟ8[eDdHv_&o[AH?{cFT@d=`}#Nm%Hd)7/eu'F@$fg4e9sLk|YND ҼvTZ.7džI ʖ*\vÉ~3)3_~e7(ʪߤyS:w+٪F'BTf rd2[}OT+fKG@J4")D8yӓ;=>o|f8U%"!=Tx=3g>k>-CJQTQpe:M(ǽY@ۖ>1wLQ~aUKLӸ%׏'בWğ=:{z]/QPPPSF~~~T PQͺ7o(޻q}gȤ۾"W/BgN8%D%REhQuDV 2TGPmU0թ0PD0*€@ѢD,ţ˥rxဈ1! $CqF }O3|:!e7ieq"J6juA>C{؉6q}4̈%W^7u} Bһy(D'xsz\pRVqYh앟=oV|4X-}6Yci ԉT;Y3_Jd_鯭ɟ4weu-;]?W-է֋#uTҙ ԑ@&mDx9. (ys^z|P%.\;Kvvjv:!mk.|<Ѣ'n>A_Z8뮋DJyJ!pdffvYf -?{}P%jMP#v2B^_W4H@bP):K6O;>mJyuwA8TIQFQ8ɳ/a(T>V H@$$ɰGqƉp@2ӴGı>@"5!qɎ8xG*EktL8HFl~kMY8+WmMVmZ |.r:~lFKmW7mtkh} Bђ~VW+6hԴy˶v3d^;r׷~>{'<#V~VX "ZP*Q z+u^D ZvՔe^턌(TImY2ٻc֦(6 )q(%t)"8TKwAWqqT  H bX%XcɍCbjI90FfҐZ?a*{ov'=wb?qlo}+Ͼjϡd?zF_[7M6\?^JKD Hbb΃O,H , GP]rPVEEqx VDX+\Rm6)IpRޯIfҙNw?3E^i{r>]Ya׎ `4"g xX ? 6~zx(ǕͣSwo]*q.Kʖ;-׬qE_w1@K9ZvG,O!2sKnR%νQSh7Άs32sևqWeD=a@qX̙~ZK!eZ/kА1y;R{jRĨ՟s޿`XJJ )gId:N%엵 KrF l]5J EDDh;2/nt37|>gMjACu.ϙ)|xU>4Eq`.zs=VrrzG^oleqW#?VGok=.-݇~2mңӖ>yC^rfڕ;0dήX4Ð2h))d@L=~ZNÝ0sNM>|Үc crN5QA\նK5_ݩO-ԥ؉c{M鈥rտ}>vC+‚2ֿ}iȊNf)(G:ͯ݃x'~Gw`F׬dSr2ew}>2XO^z=kO n(Ye8*brKs;[T73j}zb p2Ta ÊV0,]f#˞ 3ljM()du*'0Z6)B:Nz*'}U,}JIIl >G@8H@@0̨1-^وQ|aʏf׼9Z<'&TI*7}" й+^myL[CeOF䔂'~bsf̝1({fp~!e*aWׄK&Bj 7~C|Żrj*' Qa=,)9/=آ0me9gӡ/kC/bqT k|>eOܩ3ڡ$~䗔]}!sZS~׍їνq҃E}c\: -Bh7k ۶$K2HVݵmeߵ;W4w* 7qIzMj.;eЮ3SUCLYr&%)^Mp?5 Iss*kY+4c -(mvi Q_lufiI![DT-CdhRF*!(灈m# }c ʄu )ѰG72HޤYx} jz^ߪC߲i)^Fˣ@ q@C#beHYGY>7s Dʈw^S#2!gBB 2[@$Ӱ/y8UvN?'!GԪ]s(#ohӦPЈ(`FxeRmbLp8dqYT-èU;/聃yRfrWOzZ٩4"P1:[!Ǿ |@$|Wr\Jvcx({oѯ!BDDLG᥸o.((R$()q8B_E}hŴˣyZ.LE (Qv|vwqee%"?}AS+e"iL6iI[:D]s̗~B?f@ce/+=e@`Hu5ԍkQEp&^]&^6smZ-^fWPRrȢG~j•5.YpM9|pug.*"bLEfnӪ!:5 lIkeX*hsCJL/zw ?XՓ״ phD@6J<̔3&$$⡂Zv*%:Y{M0oy}q *rF@ED R7hz>]31gGnmHIe/<%1{1/}oc_"8_FdUTYӾ>rV3cmQܾ_TsZakx(~݀-44mm۶.N" NEڧ!Y_X+qaԸ9hI?d󤫭PQr-| QFEF@bHXY-qό~h;7unA N8c:$A&j9Atlu%dnqL_枟>l0a [gNB8?o1XP!LBˌAmE!H˸ x0ZD-ft *Ja@EFsַ04 <{pO^3pOҳ6ktʔ ΰTOâߔasLCs!uwػ O V[`9KB;97(~y=綯 $tK o!%"*4o7k1C΅D 9ڶ%O _## UIF,%oF |xRVj} "@_Vm^&QTt1aۘ.qL{PYVgH i jqqv>5$1X9RI,mɪV5p"(eQL1_fq+)\3K%̳gm(,mصcK2ĸ¨_aфu4= 9}gC +ʦHr 9 ;Hv&EB981IQI9V&SbEHKجEg\_`}~?=~VkG6bhuuu!V^^DYnܭI̹̒uoK=ɜCkd,@+ c!atOQ$Dَ֛g9ԞBA;no饈#3m^U힪l(Z0^7\{X*SYsQvHAjRŲ-ۻtꠍ=@bL E+F/!*]&'NWOOXkYɾxԔVodn=sAIE@yD(Z0j7zClP ØdS7$PƢ ՝E+M _|F:Ģ}W\yNb4 0jQ/Tɬ-UY (Cݫ6q߷I&5-8I87l8fY)t`@RM@ܽxpxI 267Ng1W:ߋUs-+"VR4"NhhD"K:N JjnHǂ 9FHN x%" D D4"@relg'G8>=;㣵<}y+҈7V%kmbk}xq}|1`D" 9FHU<{E-Œ~FH+>: vx @ P8OD@|@ Fħ"ƺipFN 9c"8PҘ@ >  ]WsܙFpU4/aps@ F ('"@ > O#Ddo@ Fħ"@ ODwvँ(s%7/@H=  h х]B0dރ@|@ ߶|}`iD4Ms/ӈ4"@ >'N dXmή.#"|XVgD# DЈ@VL4"@ #G#DR҈@& 8@VPHC Fr"iD :N z"Lڶ .@6J F" Du9x<g<,@Z@,&UUN8G@"hD 8N F" @'@# DЈ@p;ƅ( 0|.1!$(DA)-؀D$jѩ$ɥ`L;ɷ{'"N @նGiЈ@h4w{~DP۝D4"N @TnkMЈ@fyu;FF DЈ@8'@#"hD @' DЈ@8'@#"hD @ @?pa[N޺M F"DӇ iЈ@4@= @4"H @kn5@#"TrumhD ?҈@ш@3hD @4""I#M 2E&`NXTᓝ7 8[EQ{cQ0;c[- @,M? w,>`~ UЋF#/TF PiD@ @|k7W7+@ iD@ ]  DO#hs8kFhD` kdTnوpAȜiD@ @|F"ئ@4"  >DO#ӈ@4"  >DGw3y.ӈ@&/ӷnogjdg_dӈ@4"'Vsw J[wղO 8%@Jш@|4"$#HFL"d iD>ٹw  8Kpfn]P1 L?݂40]u.@rӈ@4"D' DmDd"D%g d"Frp]Sr҈@swm]҈@4"' D@#@p>UJg#=.g.F)zM D@#@pЈ@4"' D@#@p{#""^e@4"' D@#@pZu]0+3~iNNnS"  D@#@p4'͍*hDA @k8(Gly#4"aވD@Ј0@"ш0@ш@9_@%0/)")k "jʵ "$"p8m),,0* <I'=ܽ^<<P4"9*"P4"=j%7=Лw# @ ҉^?ּqD=ɝZ6mޞJ_0>>^Hht",^!u$=c(aN\.|ܽ|=qRH>#>V<{y: O#@E(O_yĥ_M/ڋd3KX5&Sdn5H fnuv5H>/ڲ)T3OzY9"=57VjTc?SCdk@oνDqGF$&m#$ADQF$eA"l*eBAE"f҉"B񮈊 QQ[X >'w{|M-C=tMHsy)B꒚ !@#p;EPWS|UX2N߫*d$.n*y1|waqUNQbh{.x$;M2:o4Cʊ!T񮦏N{ ѤXTQ^q J&#ģCL;Υ(E?bVl˧빧vCD*'Ĕ6<s++YVyN%藺i1)6qܟG!@#%D`NmCv-vPX_XA#0FQnwEZ !DSH?Ѩo# !01(-m5Hxt[Bb\MdwK 2{wGvO'G^oD)[wqLqu7ޝ^FD&@W>G)}[b/[7;m~~؍]/3o._{G~Չ[ʵ+(/-dhD9E)iNcoɱN`cx^ F`8wTL#9w6Rtiy384"D*XQJOM1t|Zb"Օ-ii%1j&2"8܌@ RU2ilu"A#@r^WDi4iz^ @8 $M$,d~o8w"ص(K;6֛E bw3YF kʃE{& T_Ra.龷ړ0&ZF 4"Y.*=lmxW&ji>dɞ%M@iDVxlUNpާ0d׃+=XY|l],FZj&U״f@$(X1dwM麞0]\ɝ!Wo]{nMQ#4"&/<{D"2ނ-]?dww '7_ޒ"Vė ,zlS*BȤ~vWWDP:)~r["}$o(/6d^>?9/ SdR!MeZlX?KQuI0 ?ז.E AAkO#*\D'E("zq| #ɍ?ǥ[O_SKmr!R[sJ7J=}]O@`b'056:>37vtt>~fըIʿJ\Hc߉.?zRgv d@$ z?Qk;ož߮|xQrnZDDꝉ f@/@yUlMMU+L賈\ @6D@ Ds31.DQ $& 6 lDe  X(D(U(˜ܐ is/g3DDDQ@P-$'L$'L$'L$'L$'egjL `=x/wy=0%@Ĕ@F d#`b {MHA Bsw8WnkgDR@"^.f"@~D"@4" ?S" 2P@gJ@ TA& UЈDLDr:Sr'O& ^Gٸm)P@_gՙrˋM@GiD"|k8^t)@*^@& ئa !" 4P2@" @ACK̀iB1u(D.{}z; @d"@"@4"@"@5\%J TF&G TI&D P8mpJ@@&' D~ЈDJfm [ar2 y^)t$@&  Dd"@pZ^XL#(wfȇP_ @@&' Dd"@p@Lvd"@7iD@ WD D DB)Ȋȳ'@& 57*@^2E L "씉(E"} Ƞ $$'@& D:ύ @W D0( D0( D0( D'gL=>7 ifM}/o`PBAE  @ ;t4,7׃NePeN OPBDP^XbfxKBaBS(lDa D(U4njd2HpQ@U" Ḋ D0404 ḊJj#H ?g"D:3s_ws; ̍@wVf:&O F@ C$JvḊm{GBJ$P vrCFG(?@;@"C3@ʥ@`r GD uuSG (H '0FD "(@|H"B Ё:ʤ#Č:g/ GFJwARu?IJbG559Nf5a4)!FRGT,$5 'j w,یw&ܭ}wyY͓="}WuIJ4:؏Y5 P"*ںO>u+F`0 J!K `k_}T{C'M>i)GO3lag}wOZl4MMg YM i4o]{ $IR?~M?w:Zh W엖{Qzg8g>cˏt~ɗBÁcEַUs^ĎRZڏO:sʤ1QJ]_Τ>/8D\uC rx">hŋՏGYߵ%ߜ5.]rû:CЎK$& န6zuߓ忸dP2~E7޳|*F_7_v˺bʯ: VdU& ߿hտQQxSˏI>ؓhdod"Z4nmp5_92zUwE S|!TԷۗm.w\sؿ_#S?@wjC|RX]7Vx澿T-4ZO9gqO4shl{`^ @hP4Rc/cf<$ F8ej&7?b* T6(boW~ՅPt5ćM?ibe?: t{K2"OO5vBY1Sk k>vʱ͡,ٽn͋^iǡqcPQڱ}G)ui@~HzЏzUXs͌Lh I-J,95TdNru!uYBEl06zDkxv_fD lCa~64 =nZ{6333333333{?ǐtԯ³N̄m)%53+VSw}tttx,^8y$Td[Cm2q*|}DWqJRMP(%DC%\.BL&38cFEgg\xM6-́z >, U={BMܞ>1GږRw} R7ԯxt8T$ݯw'njSw4qCY-[ŭ]ǎmw#nɴL~I-z8wdʚʽ)Գn;sX2? vSm): iUWLne3o۞ CYӤ<7Hcؽ>ő^1pnGSzs~=HC(m]r(5OS7tVE:)DCE6]D>O??h-'_@163#PtEwo+%KmeQnPLu@ v}8E-N-mQ(ǝ}*]` - us.Qqǿ~"6$9Tp`HK64;VKAYSAQD N"( ݩqx|4nCHV{'KqrWg۟&.]!Y'D8ȇ;C&dnu~-Tq4?3cg̦wS"8j&$[LBݎ׺+mJ)@*Nx~>${ g'1Hu@z|LHv n=V}U{rֵz+ǶDHii!?Ose ͕jN%@8@® Ws 0' "s 0' "s 0' "s 0'ĮݳD%J{#^P"C jjA)*hkEAQqPAADQ':)s<'D q@ "'D q@ "XX?oА~ՈY Ra^X3&1:WIyc@^h4>_wVׄEWmk.?j|Хm*y[%]eza/tjZrm&;u2AtQ< )@i1ӗٳC>.̚Ǜ'~Z?;py䍛=>q̺bLkh¢08.難*Eݓ`\~Cr1ZJϔQ$Df:z :yd!^'מ->˸6{fU8#1!ķ-߶ڸE7:@dD[`f_u?0aI:LM%!poSM aqNݻ`oHc.@dPC+wu]DVqlS`߳g7S8 a0Y5 cBVaL#{"H_?P}71Ѱ%=_C2ZN S|* 3s ٭d3Ր-;M޼kF77@.}JbfԓAc~{3% ؏iՆ-_#,A+Jd${ts_o8p*|Oy&_'#E29s/2s}'DI@RW|y0P8ʿ-ňȊGyzд)CRBJ)Q"MD62A@0۶)vtL*Sۿ/vCٱ1MSXtH~>W'y[qĺ5‘#(+Z\*2O7E WK0!,D ߑDeRKHƴjP8B }Я${_,_} "ry~褍9!U{O{w @)|R8oQ.)\< ۴ EoӧO(QvE^u˪T˄\I_5glf[}fp6Oha =@e#;y\(ҭ0RǙ?6U~tT.-Z WҤRGVM+WfÛFIaçjۡ촽~6gVUt{VSDF@(ߦqM au^ ǔ!oQ֙7 aYtpZkhVOJ7z}KWOKQW4ڴ?RCkt۫[8U1V ==d${[U qގY=0@@4ѕ\%8l-[ \V W'h"HVp-,wӰ ( V0yEMyW4dpv79'L.gZ<Ҩy}E\\4ei8L_lߗJk'6^^;|+%W!|<1p]o 'f;De 2l+pmYڜ@m}!~FkFJE'"]-'n)P8<ؤ YĊ/dQmu=B3+%_!Dmz!,Q1KX<^AëK|V! DzcH9'Lߖ ,"3Tr֌jd`Z@@(aGWx{Z=4"ɻwRFN#_[ܧ,w[DwT<.M QF\(:>KX\rT o~FUim]b$NSDSu˻jRWnpwϻ]¦Ŵsƺ42D R6=԰\b6'l*pSC҇P)XU}l2 DעYawغ'JcnhVAujߌ\rЧ9Z6#ݸG u3{~&D!ӧN+{b|VV|Z2xZ%%DPLQʷ*GJjb2>3zV&W}whW&jF4SLO;iԪU-R! )? D!iŲ3pmg;d2MUuK 1n%5Wp9 |[X-S8-{ 2f* fƼT"HW K84[X\&Ux>V]/'{~j]J秛8w!k;p*Ҫw*38G7Y7 ;,YqL~pZ}@x߭{.,ӹ^*@X=GzR2Q:{)iMݧ3sqZaVyMG~ҙ p b4>OL_rG&,F- |۟Or&褩3W¥Zi+1OWQ Wv="ґqܝTLH~0 v5(X[j-︜1I"Xo~ LL  +4{!㈌"}NgtjIe@ ieg"u0 vpmꝽjҖHq야D zm=R^RT@uW̥؍fIWH}ʲ׊ %'%m˱m}'7 ɾ*x03-=G;Wobꊽ)ւ59<1pҢkz%yն}U6}{1ֻo%) R ste(!T5n4R``wS9(E9sG(P˻h}wڻ;Ķ}Hzߑ7xk07o9i:z'di5+$#yZHZRJAu?0goUDs69U^]u8"PtYͳrs~KIJ F.OV]S +?o\X3ģ&G(WL~81&G|">5W%-F(}pF|P!+ܔdjT7R'u/)q>{TL61Loק:%G.fQx>?!gCH)4hqҢ$9"K!0\1P_ZEqryb?:30h4B&~kP]7+|<#1>Բ#R2 #y<ڑ>S2 ob.Vu%׈srÕ.haOخ}TfS+;'&~ ̊s mk#Ɩbb 䭗5N}jSs7dgBTqjX~ڔШmYjV2^=gٚm-12YFu'};6>p};O{E$oOLش:IԱQ}=vc|ӵ̵Lu-!rҮ|fl)cX?*cUXs%gشk&'0!}ITv9KÞ 0!1%5%i͂`7+9@͵~Son?6lT̄QCu+S%`)G2M`B PUM5HQ![\R E;Q!+i P٫0\1ӹ^ШPW)-Y#jV_p!!g;24bizߤCGLL αeĒ÷ -ʑ#z.0xH9?dh3cѪl|0B$Sr;;9-;5rB&B1*k}Yew\sIBgfY-׫).vauRhש9?]&UhEb1LowԠQ!h.L69Mc36d%b, Pua@୧3j !ڹG2=4kz@a D4D4S"BkoxLo)-q>3GGqB.  [|ɻj&R$Tܐ'S<袒A WFi4Uuf,įOkl PY 8 T9TѨ#J!ͅ%,a>#Q9vȐJҙc|?tiY*&'u8b;["#3K^Ч]h޲"b$j2fAr#cwt.q$_';QcFb9$ A\]Eu9b-_3: ѯ?o5ͼc ` 5|Bx{j+[ΊCT~CiDheT@Ұ105!;w<`Ĥ^0sl3eZLj z.iL\Czg9~۱#1Tݙ!G{-eYn@Y3wTIjdzrBjĺ~'Z%ioVF;8{oUe'EHl*KYnVYnŞzt]Z>srln aUF@QY!,HֺRIHH*&S7O>IJeVUrl=.M1q*$4c;6Eh3/)Ogwo m Ҥ] Kc!R5yknj!#[ܑpK7 wv`1QJe?n~$qʆ#Nf*lQAblݺr-H;u3}o6iQF8|N-Mh1|_ x>䷊ybc>A^.dkX,g@֮,iNIo'Zca ":䚨`cgg:E ]wE W|1΄ Ϸ%orq-d `IvVJ|Ȉ۵lo6H@hNo!Z}eacyyyǏ?iEW-hUD gٓV<.ͭB1\5{LBB \)+O]D!=!>sV![2W$"XL`XC|* jhĉ3f剝mٶsOVjS7_ޯ,)*1-<^(ߖU Ls3eK؞g?Vfژ*G9,WH@x D>幄=GW%զk V*$4D2?FWWWk]W[!g ql]#eS<7؇ `zz,pIM'|)JNb&Lœ+؞{_-ɻ 恵^g;] LidlJc2x XR@DjFZ<({^n7zD̐Aۻ[ C'-TpHqAe=9&n'-CotMfJ_<=RYlJS``[,ڪO DDv?/y|~Zؿ(l$еMΚ+eVҔ7S] פ`I?g7e6CcD6XH]yjx 8]yz-.F)ۑ+|[6zv+q1ϟ>[#_g>:H]oMjSDtSj>dԂy}mm5%ŕڲ7"5om+3EOy#¤yJ|@&.'GkG"$~B䣔G"f}Hy߳Bgȩ.4` ,<};VDReKSZ⭇bc>cHےruN]Սqsz~UHZgddt<\K.:fJ$?}RC^Nn&yk]r87@#!$nu׬̖4}H *.)f9sg:.a ,O)i()w~݋*|Cut{gC\]Z}w?w?!eDWbI#)x.yGUc[fw3Z!v4xOVMs6'u/1ur(q5oW;xnN+e"JƷlU^\M}A^;#bƢIsG'`tb;x믽އNJZ!m7t+/hiYп.p'k@X^I#R{4Ycdz) GQ>eC~SM^?}mEIsҒR1Z#;;鵩sMBz n _WsjN?էrk@XcvvJ\tmKsc,MFtչo||OέrԿ,m6Ϩ漸{Kڡ>J9ܡTfvV~QvMhdžc q.;ޝ>㛇ZDomF,\vh팞?}>́jp}|㲄Muկwd{{mygg ΖVZ\EZ<<{Avȉx [;FԼ?,=5w}(D =t|\)ByLv=1fԖ]76Ot-TĔ2b)ٿrUKؿO5% N.ؘhlo8!MH@;~reSAEfܽూɷuȦ -yG]SWZ# 9C7/7~/hH4:aM?RۿU^oa8>H]͎vP~SHM_Ӽ],:jd&X@+Z$]U ^yF%l+D!1?6dý8ˇpp\}追p_@~00n81D)w޾ቑW *l]Q ׁmy!{Gv9Ef.+>}ٮ%M^Vyr_FYq׷c7"Xԫ[VSݩ͏M_vힵ(8 ,(A.~]K(⦋@wjMF5#Mk실J1^P[l3Gr#Kp Rɧ?)iWK֦wWW^ܴ]3}߾6z``$wѫ7<)6X|Ss;pxf+F~E;nQܞy֕i ^~ a~~M@؟nki}jD֒ǷdV[)iEW?}xRqj)zVjKx2i;8I8[)/OgxO!@v d@ d@ d@ dڵA#`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`N ϼU>> IENDB`bayestestR/man/figures/unnamed-chunk-7-1.png0000644000176200001440000021372615174322463020405 0ustar liggesusersPNG  IHDR `oԒIDATx à7h@7n "q@ ' "q@ ' "q@ ' "Ϯ4`>-1`L ,꤃F7ct88࢘VQ1@Y |&r^6X@Bxu D"'@ r D"'@ rXd+Cii:X[[lqnoS?<˖'~\kBfjSo3"DrU~t+9BtwO{ߏ̵c$go}ll&pb͵Zw^#4__+=n'p…-%0wf6 IRtX~@`%BAOV Bt0¨"A0*=IJd el <.X)>AnZy|a؃@ÞֳJhzMUVGg@," yĪh= l@ކOV|Ǚ}ԺwKW3 B3 Y C%rtMfGyS{5؝pfwY߾RO&LDOi,WaݍXD;j \\[nUV^~͋Wde}Zcݕ`xN5O *8\q7/&^h4ߥdgz<cZ|ݾY%D\v7jdAz4I 16hele8j YU,R:?/(a yz^jd`rz:eH$2p$"ٹ&0 3tP# AIh!7h.M:!"8Pp@֖ p^#G9ͬFMer;'mF |3Z\YyƘe[0̪r%30Od,?cݖ%Ұ ezZv?͑M떗gj ?bc|zBvĥS=ׯIeܑZ?.Ǟ,J>!TMjJkzi˚ȋӛJcx&ʧs,^׹Gwnq.[S]- 2h3X!ES*9c|&DZV2yZ]nE \i`>:?ϜK 4QcTDDc1$јhr17FM{`F{WA3F9K=,,X~ߏ/9;yvt&aZ>h1-hE 9"%"Wmdf Pˉ(4x9U֘U Oe T%Swwr֭s5Qb+偻e-Ծ ڳa3̮_ĔZ8mݔXoE+G637T/苈x}ka8 -74,N,պSik. LtA'2ɥAĪf}X fT7uZM|[^0&E0+GG5 Y&0mA+lA(}\_DV v ʣג fJsԤC;Ҙ"6L]zrnۭ8t`}3G{smH|vRgR6 :ގim** uj:qcc k1]ɁHh1kc,gO?~ceClv>^%gS+z5h楦uݝ(%&&Qo}$$DWS,g}zg`D)umW^%ṰfVʑo`/.QlߦUyaǿ^#{]˲$\{7kOFm}m̆zvxPD[9Q}.f_rT4ۍ݈ON wb/z{OJds229wgTcw:(+bJ a[f"QyVl>o7t/FZsGw=G1~s2YnBPOX{ڣ>.3%>{MU%2G8a+;Ad5Ci2x޺wġBf\ԆA ){\SrN p爄]$09c|/߰ą܊KԤ=we3CڊSiO) O-|~Y::6{hM?A{ͺX|.=:ӿ_xgaCɱlcAM3wO֟y)H#v~su--ӲuA+lA(L!1-^έ4XE^.-'oeR[PC;xicd0 2ɚJFJc&OOӡoN&5M@ә,o^wҨj\a3I*o|&('i-Թr AQkgSttFԴ[ᄮ4 ;W.g%^H>ҋ'2\o5&~Xcg'4Fi-cnJ|H/4њAKcYnƄ]9IBy>F\UOۥeBQj/@ق{A5_#͈i^WD¹#˟lmi۫zK'UCQy-3!9v_3+}| 2ׯ8f@o~G?3)+Z4K&HXNTEDZEW]Ym˟>e!&]h, ";}qtMڢ9iv1w7+B+[XPVPeAXZ-"un=LF3lDUNOeI9S}xZolM(Jo([ b/Bj^%қjhsfQU8ͩTfJ{lCƛ3_Yӎi\ơ Pǖ3N3wrDj1 %oK7f*"r\jӰ+ssA?7ZduTAx3ĉ%8ݩkץ7 ̒_4P]hUzżD _( NB,e132w™^Ndh(?+}Zۥe+BQ/@ق{Q "[04FVү{T`>n*A2YR†UH6UtLyxHUNQ;DƑ)YK_40f0*_^50Ҏ}hOw)*Z4 |Nj%+ ۨM "ԥ_s:uhҧGIhF3ᡲ8U~) <^;Н#"߂Xy̋APJ^zc'|lCE7̏h+ۧe(͉lAD :8sfl$f2?ld=>>oriLVwlTQvBy1z&{t՜# n""n&V ޘ$0唗mv "*߹/-m RxԥŤ] eP};,idwQh Zk[DrhK#4#*PX<-+ENe G6ڵY#-Wvlk;XFb˃ =iH^X 3'k"2_WVjY@'Yʅ+z"xKS$BJAؕu"OU*uCo^ g~AN5.=pآCwnY|ь[VUS0eO@NJs3bCdC$nSZKصHph7bHC޴B#_BMSy7xN*"۠kWo,Tw6yĂOt^`j_?_5)ŨʽO7=iEJrʺrA]ڴRέJۅe^|Hr*S1*9P:ʽ&l^#A*WR< PzANQmt[!owb⡒ޚ+CC4kŞصǯgMԡAm !y;$C":\#r7`UeSI&S^fBʅ l0tMbfrԹZ ԥ_K;8d9<whGM⤇=Hr(1/U# d@kU<)_JS~A(ET/ԥA} 8aw!Bʑy‚7JY,3c.]rn{QN~L{Hb|+&nGa\kYv0 aii 6 ƶd^+K;? `7pPn $ b1#&-Bz.KU[ 9k|Hqy2d7!Upj..tCQvt_/-JZÝw$D@ҨCYIEeIxT^գ\+P";n-tuA7fP?Yȭc Maץ&CI^M ]EuޢǸj%Nvɱ퇒Q@Iqr5hF +Kk!Fʻ7bWkQ燲x D IuDbsctA3zSb3 (6=Cѝ޴URu|U Ҳuq8ˊ:qNK3>:c</HL{${n$>NT66檁(V(YTV;>x*($9t [`V^ȤE{{~(+ {[6& "BCYݎ%4<RjK"wl~rӶ{FMxO`Txܾ>"( xР/ [.CorZ5n?X lK!LI~. vܫ 1Ⱦ!"3"-Nd1&1OM^+ _e&4K1cd j@d`dDR}TF !O!rmn(8u\#rh7oMYrݼ.uȬ]^|Kë'?V#"Db;Nɍoط_ Ǜ.f _}wZ+ڀ kebe'4Ș1{u$U59.qU*uWDsyٛLH-3>.%0d;Ȧj*]v0?tfd ߛw9i>|K*"RkXO%Y;@,1\9pQzwcoQaǏJ9i-O.xwM=1%G̝Qz1*\dl_2x DIg=8,WmiĄnsTK:}'ξ0Q`, -3LˇnN- i})˺_0spIW5 =HhN]d2ΟJ1rҢh=#ؤkZfay"hDM^Zӂ&oh `i9x+RRvL/-Z=)EnUX+?X ZH;e|aR@:kݬ^JL[v3-V6tgxРB Z17/oj7aɦ#f f{HJ+nmה拘~^Z ץ{kMeA+lA(u׳XăS;Su7FQu# kM<ɔˈ*wMx~bq涇;DrP~A*$0VDG˺;Q'݅4q\ZĔ,!ǹsS}iF ~Aڅ.Ȩl*"lsEQ[EijXims&v6۽{9/YDݗ?+N =\ۢxd{0&Ì[HbfTqJZf${J m~R`|+?Ws@a0]cii)@Q]>iBA2(J~jb)9+jZ(=|}\j}}v+co\+G\?whm=y{o|fyV޿?xUNv;7pXn>k 9sQ/@ DXLwZ~8WPG~h 5mǓoP?_'+c)C@ BiL~z_l+֝z5rljt:7oo?qy4"ȱU0ز0?Z\&=tw6 qOp[h00F%09@r%t Xpg~"s?oe\p4ӯLJ˫G>]&P" D'N @ 8@p" D'N @ 8@p" D'N @8d2ݤ!iC`xQ&&U%~= fA rD"gA rD"gw,DIl6sI 0` Pi4MosI 0^jZ "fA rD"gA rD"gjn( LVt: "D0TA(si 0`)c|wurh,mۧ񟋃Ņ_h]0*m a8>lc}cif=3z}yaY 8OXۈ/(TPE_@: T)@-**@x(54{A* 4Pg89@|\i wJ:lE6˦$RI>.DZ'_ݿO,xHqhxc{I>ͻ/UV"IJn:|\;'#)ᒬsߙsG6JHRb kM jFc"I=۷-`k W#Yz>5lILARHN ^iӷ5WlQ54\uXHKK5MغCҔ+f6 vud]ewvMώ4N] Vuq׷BolC"A cFBg頀:q2alȤa@q2L#LXdX"y9Gڷ^䤹ӓw9s t5}܅cѹ R}FfWU ї.ִl r^6DDDDDDDDDDDDDDDԃSu *{AR0P~|ʅ7fMUi}=l\ 3h [AS<(7WT4c#)9~lVO3۞ԥ⹅*=/6mڴC+Wzhmy`/"nxZXi{^ޤ)|H6`wv& Imm m؟}QDqSYI͈/XlkĢƎ_)#Ǒf6?Ium""r]ןJ"غ2AMDCZk+ȿ\וfwz"4Q:+GDͨ ?W,RP fj_AgOvٳ16l RXHh?xt 9/ t3<1aa^3+`І!TAʈ,N8 "!0(DD>Լk< RJ"/0',|L$=AT0fڌ4SY~G^/عm7Wl+>2hǯ6ƗНСC1GûғSzƖ"t=E41rA)Vy)U""""""""""""$ ODpv[s *t%f>0,/ Th.Yѵ)}PQxvyCWЖBM}02J|mU#1DDDDDDDDDDDDSj}s ,$mźB o634V?~ U=a#ƍ+дiL )\e ڥjޔc evxG =vy`m[3Ɵq+^=yHL a^3.``9 ѐh?V]&eeYp"5$m$"!qhM"", OM""Zp$"!q', /'EHTZ"$;_&rRP&~ kϹ@AAAID=1cnj923hhk*mؚ(ܱE Q]D=u;cd4JnT"5aOj.Ÿ)s۵a>_+B@޽0M)iDȇ,˺4"LDCH DD>.וD_h~€HTn&DjmuT_B= r "Ö-[SZZ RHq xwI 4|Pn)@m'P9<D+׮ZIJLDDDDDDDDDDDD=[ pﰡsR ]Ws0~_RrD\t@D=fF3ejH( c|x忮~ .K^ 0.qaNQӬx`#>RvxGEJd2NXmωP0JMc 1Jh^зK>#Vұ(U)SُR2B:H.=:zZ\b]4[s^ jz@ْG쏈1c1c1cL5^+y<.ϼ^R6뉌#,Dhkݛ5??sKJ3co~4="cvMxRe@`RYOH=tǕ2fm?NIUSÙֹfSD0sJ*ya0>͒J JTa:!V1 """s.R6z@T@s|!ĩ %ǜҹ~XFqؿ\T 53(Nip TXc1{:n@0"J`wfAUQ䑨:`QHFDliZ&Z*3(DbEа#K=n _}5ιzjj:O͸k'o#?{kInh<4ce+g-$dfW6'MFOX$H$F#]͓Uc}5RWnser= Od" O|pm8Ҏ7sn\?uA$붜ׅ#INqsoN&w"_8+3YѸ Ү+^ZzKM44uCmmA7ǝϛ/Np>IȆw&=ghOJy< rfb_EģbTyf8_p޽/Hgn9Ч/Z835Jr>CLV-=ֆ쎒qj6fAHEبƘQפuAMMM"DD]PCCz8p BDqUmjjuAL/éHJϑӦ\SM~yO}q4X/yywRU9-ܷ2[' )@`oԤ ՕU-{sG9l役b{̻h[xG= )2DFU"pDhHB%#ju4@m?Z"C38rL3,Ft!X-AaEpߞi!CL4ǎX:.B'$r`1cWBRaٲu>Z۴ĂW(Z.JY """""""""""6/O-PӰߛy;Tι{'h!ӏ>W࢛sl?[M{ft-w̚uǭ74EϼQ@z_tü{Sr*.=Q4c!!8FA"_ᦸ PKavpB9޹swD"C|_"MC\"+hSpr$8u}$zn O.E~tDy9X[:{z>G2A@;u^-@DDDDDDDDDDDDm`W@\\5qxoKM4~mr.~YAaW]GG=o}_$T"3/x҇oqw!:G+\-Z /;fȀ#_e A]Z\OxwyTucvcPC{Vk#pSцK݌-qkJ/D^*$ EpVP@L-M[M^4R򢰶> bas)Z)QEkb 2v! ]d="ȓBګO """""""""""AR|θ9KB?=?3ՄQ^RaeŪϙ2 ӫWhO?{AD'.ŖPcb4a )AT^|bf|)fA3|FK~cЙbi*Yf1d؉]O۸jSMcuӐ#bi7UPMD5 6>fm_"ۗX[F*"萲?)wWNMf_2kYDљ QWh8QM%ˑa?9HS"|Y3V߄h Rx(XT 8woā\ GEP4c1BFE*tmx8eW`1PAT)gOiRcT"""""""""""": "DD 61;~2)^|-oa;g-(\:`<:%" l8M⨸]g N|O Bk Nl eF!&4 X@):;Lԩӑuh' hMmP *p 4"""""""""""D4';fG0:I"C-ErD"R ,Az5dWiZQ*vA ^+\;)kn}Fa*U?NhĐ+/Uoo """"""""""":Y ":1SL;w.3~!A}" 㠪 U6߲TL2^LT@>b8qh@s [^׿"Yf/Fn BDDDDDDDDDDDMANg}+.0 ?!_?88^΁0W{W -i& C$eZ!1G ,  AS玌hAHM?yZ|S( %66|Y H VAG1)[`Q{ ɃaC cm1(2ǽkƯ(4C.x=RByQRU-RHh߷G( rXXG-KzDDDDDDDDDDDDA]z"C̓a QkP0kd):6 Y>f<]j䩦'i*,Ct̏^+RKmUuSS8kq|F Q":Qs\&L@wgXHSXp"MA+|@ᒞS\ 4m>{4pi_X |L*\*oёpqylml|m ق,ST4j(\&1p)lD|R_#(:TɌoFV?BZ \20"""""""""""" BD'ߎnƶ2IE<; έD%fg!.f$ ADfAҜ+vK:gz? V쿠8;==e!tN@[P(\hW8 """""""""""" BDԑUpI³իy qEpxAT( 1XC_Ri -8%.2 R4!(\_Gy-6KnFQu CAM ;Y%`QJXHv~eBe O5߲ݧC&|.{vJ4gKZx3%F/FYF:7PosJ/4%r0hQ[*dW=l&FUk9bQǖ4)q Cpֿ"o5TX}N$وb;PS\V/UWEcmUE-p}T^񝁲ck + 6-.p߹cz;]qf|~HS_<9D # ^TQunhMNyj BDԉg|9 ђ(@e6 ٻGqG႓=,/5Pc;QcӯCk/J /G(T nL3<|V| &%/5hA.U$èc4aD hq%wfTNu9l!" O2 ^f \ ŮCx/laC KӯGm)u\,X;(>%[KmzXȇl :$26U# DDDDDDDDDDDD)ue@"PW4}s<8$+y#ue}#yqJF7j>9Q/4Yqln+SpI$PStYfGj&RTUUo8 O: 䴙ަ]a(rB8yfyV@"='9j5H)Z]06ʲ @ @_L&eY];i 0%9 0#bvʒں $D>zB0!v  "D A 8@p "D3g L{6cA]@ "fj+\. `}l "D0,A 8@p "D3g AvdM$ D9-.P A]Zz^T}ño>O Y 8{'ѮZ(qUFo &B(H/.ɶt-$ˤ".n*%̱ }i m2)9|8s_@ Th}}Z8[tSR__)/s k_?~$n@ 0Dm.vU @~K.u4GpQ"9ܚ"uˤJ)^/(yC3@Vgp|@mXT)97I҈*r2~{r9FYMihD@u:i2|v~ ޹jh:96/Y%DS +?$@ P&O":~'hʏ7hDphMMMWVOO#DӴ}kqq1ͅpa=FTmrrg9ӻ}^4"@vߝ߸2G5ܹx?}@ P~ݱA)cOw  xˏsۗZX"DЈ8C#D>8&8"#AL 0*5FS4"@NL2*Qx@?pa39bHvB [vP\ D'PWH `x#/@"%3"! DqȖeI5SEz" D,mTI O#z2ŝRPRD@!@%"NSPR#-`Vכr{H@A@DD*'  TN@ݡq@+O J@%- +( HJ:m+a7 D0" D@p3@ 8@pu]ߋs  Dm,}OT#"p"]}߿]ץXlc8 9˲$*D2@ 8FD 8N @+@ 8FD 8@p3 DwMZ,˒ Zpwqg_f@rFH"@ q|+aHT-)PA @|+"<@A@жB(<|G♠Aф_u'ڤ7F8( \@ 8FD 8@pC@pR@hm۾}"uu] o _T8@8jm@pMӼgUU% Dȗx @ `\2"eb'7FD RN @?n("Q˲|f& D3-)P@ 2@@xj<e8& D3vKp@ LVQmӁkp)8FlD 58V9-Lz5"D @ Y*"/ڶ8#pjDrΟž "KVf@ -<W/YZhJ+bHt풄l] Mul(JʋC-yɂUЩט{}M$ &nӫ 8rUmR*hL&B1VOUP6m˟+WSSQ]]]B6hlH r]˓P/VZR<\ShA]O Y/lĤS߹=p>Ycǎ@ph 3mFJΩkzg%ԘhBf7rI_3Fd @;T(|گP!/iOSp@dlhRv #N}Fy8O}!zn]#mi<|ྵ~?K̴TRဘ߹cW!4XמּpL\>bv9?ce^z+6u iMQ 6ljjXiB~9=@{]b :7ӒB["q[on!e#±=9uOB.oyՐ^v# DZ_EW(z?*(|}b+/LcKNvg6{?+]{wn*DZY*KB^|s0u'^ZSTT-2@"!ui_9 !_ă?j1XgyhΓ_CκqڸGܟggL^@{J\PzKϺs{,NBm6ciw ^ R/=`wO%Xfj!I?=)3p"V\RիW8nzOUwlѓg~ruG >j7z}ɟNէ,UE!m0_E k`øNX̙F . %f>_Iא1 WjZ,~=?2 "` >W+V… - ڃnݺlTQQ2"PB2@'" P"enu8[v.Z퇤847 "T@R La5.9s 8t@XLt@hUc8ƭ_D;u4X@X6DL&ύ`2"EP(+3C t@"˙ !8@ D(J 8}om5_ {m>mY7ƨ_{y\x0z0dK uvvq~~`Tϯ#EDU"R5[: CJr-\9%@~"@7=> E6Fz@>֦"UikDLor hdB uzzj8 ?"U.^Ȅ@UU4`u4S]}x ȇ@Nd+|wu* /d6r~U\#ݝDFћYܶ|A&* O D '(@p D '(@p D@ )b\."@t:  @ [П$ښf_j4h@ i0h@ 7ee"@8DH P8em#0n)ŵX"!uH ɑpOvӝ69fkc> D'N VfN @,wm[G{"U뚠 $.D @ 8X 8P8"x@ae"m'+3'"pK ~@ 8@p2@p"@a>i/WZ癠UVfx[" DZ}]%hޓ@s)qL9<&@ OV D{wLAEQ/k $xX$v;*LL)x9ƿ D """`eppp2@8p77xgcD9Z>pB @w '"~;w6x]vdIRz.z^(6cIlA(--MHc65wwf>09nKҺK|#~lOJ kmZK:? h 7և/i-_Ϻ~s_~>G^_l|>Yk>ToDZ4M5Wt͕Tjɕ@\8x:Hl`4<x<^NV+1} @@4t8?/ @@4]Zn Z늧3 "oDUs*}&NA~w* q <0(X=Xdi6e4Dt |Ẏ}C"@&~k<&$(A TA՚JJ@^@ou:(P@f4T "D@^fȎ@ s D /3E 9@"/3dD `08NaP@vzsȜ "I eD IV J  x@ @g^fj xsx>zx > t{mqnznq}{pu" yr?:;XYX;y @{qL3N&ʴ,QD7eZLDæ.`s hrrrVE D"=Mz9E=pώ X{66s]{ y*eZ+3@$Х_hߎx1PU/-%u‚  4@$.ᶡ3V:WwisLmeIyOs2?-&#))s\bbbZ@og^Xc# pҭo/ڳCV^ uW\\\+341mwh4`3bV_?I@ Rw轥GMN7jƲKC" Rc7'~޷qὓ"!.V_Y1ӱ-'"4"?|Y4+{l},W$!'=>8C$%eʒSiקg\c,XCE9cWj"SȏF?Gջ>)=!=;&Hgs+GL̰O5d^8SKmY BVhM\(*1D-t!@eMHjDYH ig.:s ~7Ϸu~vhSC&;]F[6n*jh7 Iuͥ@@"#n~|L#QqGr]ҤV׮ND Hiu\"w!ڔ{,{u7cDŽd;s$nUܑٵe}U:ؚ/ܔH,>Y`^"rM[Vfb$h9#@$s/S`$JCjWf9cߍEEϾ|PfH~ݎRe<17j4r8-(DfO~h_S2@I{ rBJ!E79"s4՞֓b\~Mu7E7$RgqǻFc:᳧KwmX@9 l6ks>Rv `NLJR&D$*Vm|jgHS:w[1.us'(O~<tHZիヺ>Ò6Qҹ]v(uW:R@dNQK/ڦGimx'F}֮]LQ]]]y@$:}]lNJ민,_CCupE|T[B\УiE555|vn7$Ι4Ou'2{Vf+͊26"om7cŶ{xIE)u?kj[m[hW͈ҾpC kg~+xi,+޳Ϲ>_\%U9ҹ׍W'K{9{Ie[}`/ٔi\w9=C Fu:lʢes'#M 3EUN%tmtTsmԩS#" Ԛwqg0C:^Gf;OT}]ܒˆٰaN/2dHb9Hq!<|1 hòy?Eǒ~+O]E$YdI$YxM+;5@JmdԦ Ǻ"ϑEӵP^Q}yPD`ymTeYe c LJۯi_{_x{|M&""$b+rFm}5c?7G8uGrcg.ݚ/ ;zIP6rQZ[f>w-[+dIJ!VqvP(lSϖRoEk%Y!jxᦚ;_GQ׾ǎ{?YB3' E[&=h,"o((gY4J*9ʅ>Sm/$6YdIx /)lxɿ5ćrOޙ!n$.}PJY#.씞Fb`ϴxE=X. ^!e*Ai{k;E 6-"?=CMs$2F$}=\DDaMh/ tH䆎sH."ݫɬ>T|4J(wŗJ# Vb{e˖m-EhKP(t7\?oۦLYyw^UԥͰTD!*We Ҫ8 :w[͓FNfIEiP(3zxw{~zͺ׻h.4((LVѵU-/=xotM_< ,k *i2(iRU˛\%Ў.X$BIҩ"4Y #$>sdqF)%Z9|yiE}ħKH'ge&(^'NY@Y21ii0H"*o^k=PWi݊"iczhfQ|i~;WY^#IӅw?؃I'ãy2'v-UPc?YKw0[U^Q+DG@|Yf hi~!CX<ѱ0'<|$໋o}$9YQ#nt]=oyȔ dz [i㎰$^}{”T Yؕ$y{4 jI~#I oͺ"W-VJIHhSkW/5| 7VXx]t)FM]դ?p0([?qs4zǩW@ WF y<I yv5DDܽ[>!#J1T$ٚn l2ZIt0jI#I VVY?ExhƟ&pgYa۾:e˖Mnܹs8|ɭJ@2#!!A1&bӷ~-bP P=@ b8+.ߎ5xf/ӿWףשJ\ɭ(."ڪ3j\!:>5KZW?/1Y#1nD#?ku^QPHH8haV-dU]6%V}z_#)ұ" K\5_}I$uH4jhp55Άkªe^q 'z̻;ƍ=<;}ҴC@۽Wv$|K+}ˆ$ɓyZwZH5UC5Cu|;v5a3$ي(f_Тܰ$$ϧ2ĀH[QVa([QVJ1@Qd$[|+ی2oeI݀O_Za^5i'ǩ՘@$Ir؝ KZn76vOI[| >د,[I2^coQyһe8uʞ}-Hft}q!BnHMp:vJH@DJ>uލqFd˷sAWO{y%ņJ??{y}'UVd|=>8y_$gH[sgUCk$y2zf8s;dÆ ;]5!XĤb=t/>xIר o~nW r"+I'Ԯ)I'esդlFx~Zs]<lV p>/"INYΤuQ$`[nUc;K'#ÔJ ")ekNzXIr?ƪoOj=Nad:F5|e[PXxsc=IZꮐd>x]I2g vcƌu]w #1w33ޓ\5͛/Qɾ3HX⪞ȁ("tz%Clyr6Y)*0 2#e3^UPeupy$ue?.رcST~~nI{k 6!==*$)Q}+tv0:yL?lʱz8)Z;o%/[W|yc8~eϘ~L4Sfg_.89fsi?x 0ȫCg1m VmxN r Vj`Ң$ʴ@-Zs{!3I4| ޼YlPj6hg *+9qc?ԨP^݄q1Aeqk|Gv/Y/jp֨n7!>1ĴyF"e?ٴjϦ4 \}pV5 ErJo2#W濴je *T#YLJRth\=xe+z^? [:wp8T*'{R&,zq2x:+79i|Nċ5[t6% 8=1rܔY-]:';;{^TZZZ\mT{-נeA.fB6 .4D~=wۺ>?s 23r&M\Ek>x,k)~kq¢muȿxkѡKܿsL@剮i? %߬;5oD*037wJ}3&L?M15$JNDo3}c~MT\oLO1TU' Rwx-vӻGwoڱX;]}?> 23Co=t%b!74x@]кI|e~mkVjaåhw2 V\}S luZّC.}r tճK /Tp@$rxEV#9]&ɚĆAպǘ7/}Uй%G86q~OO[D:ժtt*X2NBtZ f)t7 "ԡXqT&FI 繀o"O^!g^h;06=dydt~toĎ-K?|w­3;ջgF{GD4ثBl~ D~X]++7+صt߮mGU*Åjl> D_7Z}.~8{",+3 $ج4̩$bxpt<LkPGR*'ѕg "ٻ_ר8o6 ,!E WVL "X K"e V$ qa0,Ѣx;4"33 ow~7O/)DOP1T*w3333䟕;SSSr8  @ 08" DW^j~#߶. E/n\@FcN r @"+D#,p Fc@ E׆-[ !DVezD "@&3@"@@ E@` Dn,,,yP*NgH$N 8`e q D'$N 8@"g|*D?|qkzvVrK![tybt|y~uRSV2[[[@Dh4TLFOt_beeY__:L i>Sǎp?#+3ٻu滐M_|I֨L"9g!MIia37M쒖rw.-:%#ʍ0ٹov-;{jm̄1]el$)Z\2gέZu<11%T"&]G8sOo'Nҵy"%X5oJܝmZt0~NFP;-bB o-l}k|Y$!Zv4'cڵߓ,٘[TZ"+++Z%)))p>.@$Tc_`þܯ~nPEʏrqthޡ2/Ԟ@JA_}^ mH[(wӇSv=޺e8_^f D.:M:xG3g"'-{فlmv* Ԣ@JᵽFLfgA8S).N3.[>hBb߄"*Kٱ[֥ܲhy4T#Zrxwuk۾y KbÅWz$gCZrrrJ]NE9l]8iɓ] \|Hɡ++U_>R iqmd䍹'*hYS_Qمow.A; @6 #6f5}O?y[ rWv"O'N4{ԼP3'HMNNI]uw!7rٶQLFLo%yby~y)_ޣNYkS*uY*:?Pc9~d¸7W&( !D^fd^8~א:4X41Wz"At#Q]DW4&CP B^]@hI藴90  >'7#"\lsWtܼe#{7.K#tӨ"Ie: G RWIG߿,R/3i[%@c井{wdlݼZ,uhyӶahcccQ@ D;2e uC`\ i@d8ұo"?{UORͨg%B!ȡr>oW4/`q3"W"43}`"'ΌZ_^, DJw}/s9*J'^ۗ~൉٨JˮOh~4l|q%Ξ>y6Zܲ$̏2@/Sۊ>) ^ ttSM Z*ɺ_Mۿ-*[9Tn?wuS4xAUk4jUk[kihEFD Dg!"iaݳ6q*[iis`.E:UsKg7K?S:`H$5%phul?/a*ݚ{d.3{rA>"@>,..^KU`9 D;Sf+FSj6н2@${N~xʦ$01 ٍɩri,~J.\. `DU*g`$ͽf76(j$IjFqA0@ D N X(8@"W//>v5GDzI '!;jCL0@!y@Y/l#"#L dUާz0wR+++"@Y@QD;Sf+-ݽKＢ"*Ej袡Z).ZzX( jja+KQiwN*‰rܝ|p#*NJb(֣A`k+ r`%I2-e-$dwٷvoOh*FDj&|Wy)g3XMc,P"@U4@DmϯܽqǎlkvSg;nK￉4@ dVx}OTZF#~e$]^v{tӫW|ꛩ*~{a {l^e缭[kFSNAMdf^T #!:$ t)hp 1:3t`e , }s% ~>q<} IuY¿ Cjue_L\= 2ou#ixU~7l]{pPІ]MW={GgE4~_*,Ivp{z0*U^s75ט6}֜gdǻ6o=*Iln?.D4]M}G!㋦}lźםByE{w_;v[fjH]OaD4}V4$;oZum3[$D ֮]Za* PD>tF?Ol5f/N°{9@."fB9+V.&D~r 3RUfьO|rn]}}i ChQ 0"?uJ ]lE">>( w#mZd0yD oBs3׵m_1 =KCNXy Ѭo\~zS!Z7' oEeֶ?yO ǝyE_` { s?_2BZ~f߷w _~lUpLBԅ?40)2pXwwtu际P͜m-;+/>_LӱQꛖ@22d@$iwFL:c˩n>}fϓ]sp5\fϯ^jY͞X\Rqq 8>|ȡ{CeJĽȯ8'0==BBx7D 36[7OR`b|Z@dH 'ӛ[Rώx? A/d@$R(d+/Scpp J{%@ 1{r(BTȡR4ht@7U X3T*9[\ cT*"@U*B$Ez4bCIWU.'0=+‡uN $2{Wػ{8+lkhhɵ!햶"\zq# li4 tp'^葁8CS k^Ǚ Oܫɉ[RX(@7"ד۞=y@Jjtҗ hk./.~ Q D s_L</wtܺyط$v$z= 5ñכIۉsCdH\.WbW6 ^^xAC"sR~`iTTt G?i4! Ggg^9,iyY]kmwOVdǟEV[YdTBc.YFiZhRRf5ii r5n*)EHeYsޖw 7sgϜt^P3ID[W=\1z3nyGU&M߸}])(@m{>{G}1,kSnXݻ-DDھݙ+3$}ȴ5KiJS~*%#]ox {!lJ;<[WKGEKmPIt)mٸ ؽ /vprO~VU.֥K숞42R)(@$*3]ҶϹR,cKq]uC}pY{]7UW%@9"ɠiۦ\x$:Wv?*6vl.[[Ε2 D"43玩Hb;.zA{:sM/T?*{^zO0_4o-EDiڟ_s 3y;QCCøns zaD"*ώDZxE?02iʅ3FVT]U]3ymidow-2bŊݚ_XO%O?gTt?Mζm#GPHD~) liΙFSUNSGK$W=a֢K#x]Tte]蒦i;{]z]}»|3M8aI.䴉CVWW7rȌ?>2iL$Sf0ev۷vTVUK7o^PL{{{KKKo3V` DصRKƛyq/:v$^̦1DJ3ܹ---m[Э<뎞y/Z77Ϻo3 {?^H;6){Œi5ibmiMRa?o׿Ϭ۸is˖ 3,[3+~qɉO̔|ܒFdq ]ŏ52v2jj=~j?k֕dUIxE^_w56?|݂INuIӍ3:%F83(t˯rZ2 D:}봚$t #^6Sܰ; r DJ>\12Q~± ys3 J/=t`@9" m[SWF/%CN<y~ڶN̼rDP;y!٘miehĉIv@$ګ*sI'r\dpedc窧VwFﵮ|j]1r/(3{Iw~_K]rq`@Y"}O9\V~ǶG/l=gqևD~igM#4cƌ/w;^HNwICs`ٖ4/UmiD ӧV__ݻKayP &ԁQ9ڪ4$ ]!"h "r"(h%iB xIt# z/x9?Eoyx/x?UUz Iݱ$"-~sLýwXX-WrDdnT[mKGwXKc r:yK[/_Ο՞>rp_? we5?||Tw4^? D )cR/'֓Lkk>.=zL@6\[ V-r;V"IN4lY "VuicifXXI ,w?=_H%GD"(fƚP3 _Ip1em~-4ZMHL3M51>Z6Mmc6[*._{3 FD/u6'*KJ+ԾbI3/[fcz3ceAâs9|:d(fۗ]o555!3"g|"Q[o(hD=k +v`TM0.s"v; ĒZ~󶌬=9vo^bbaގEٛ+[z(9CO~/i egnI35)SÃϕ$Z~D]ZVU0/) emqsM##z'<;xg7N\_ 6qﵫ:rTfVQJJ M+ $HM ^Y :^U23h:dQ9E 77='E 価?\<9cBo>r-roӐa>MD!#i߸V;3kpHρO>m;2ҩUQ-** BH;wm Q555TVV/D-CF<|F!;5sBiߡ@N"mGےЫzB|㐑tm Vfr)I;t!#**ZťJ+1SH4x@2ҳN!{I/_+#"9eeqӴ{ߙeޣIȈKGr*zD^H|ؚtX~4T]ȥ@$PY^H:.~vwgCw,POzeO4 @"޹ o]pWhj07Ґ6oFyȱ@$T-\1(dڶ-t[KwN6im%4ffKvDب/2vˁpmQ%KF>gTаOccc @$#oظy~8sk ( (3yⷶ|M/M~c^8~mtb`^n2(.yEu_AAђ M~xVN Ep4OSßd߯}z^{{'cbLx=M(Tzb׋N$0 ZT,]}@uuu%cbpR B.9w|$Lj@:|˛o4DEBV)D/fVkv'#"iDb+_L:y"g[" ]?~,"RYs?2m\,2`䣚O#"yaӽݧG4bjwg$'w\H054UdZMTUԗZP-OٕjusIM{[D4hkk`LGGG "LT @!m ,j:w߮7lھ3WkqϞb=aeZFʯՒòX MOԮR0["1bbYme+=r;޽(Xgou ~BFAxҵ&m,+@>)//Y`&T  94mN|~Ɋ_:[,r磛ެd23+xqjeuT~)zbCeF% Bn4u[ޣ5&3%Ik8k~((l[}|泼]܊\?:rP\x- TdQZf=z.^;Ůz/^ȢV]^^Z?Y]YEC?|dM ?GQTКȢ_hȎeL< 9g_8TyEwPhDY? H@(k|||055i1"$@ UT@ DnFFF EFDax۱Vylv_^.VhQO _ mɦ>;>=kr?USHTX1"2[vPڏotaZb{ UQQ>l6 %_7ݎ6AtrNKƢ{=~ <~=THҿwv}6u6"ہ-Oi8X B%ߏz^ͤdXk:Tsl]VDLX)6[콣SI%P ٭Guə]3;$c#]݈|L o%zrx&t% Vn8m U{64';o$'*1]1לnwlsX*wm4h"_F;?X%V/V '` ɟJD35uJKKl J5E/:DD+z|rȾ 77vWbY 8ν!]6Dkv&UPXA "A%,vv" |VqP m@Z44mm{]:&p -y LsΝO8mzճ P(nmrl.h_Lή9k7OئHz75+&Բd`ARپ7I1,wfh,{_"H%Ǔ&)N+o3_ל$Kd/]R33zB'Iѯt% >}^q,9{&mjf&Պ_~-+$yO 4<:K*::,q˥J$I^߱lԔC$EK5?5'IҽiO1DvVX^(d~j|RD .ޛxߣnS+${wYqwy>b麮͑-*1.Y|qq,H,VtLBi^bxK,``[9- e΁y_\4/\PgY0yTOl2HįRL9ьŘe/bIЊMohhH577_^8<O8%.@3sj.cZt  V=Jzdj= "S$)+Ir !L8r$I6JYUGO/YIf/t:дfqΎC1zAA^{% ߯)~j8W]^WSg"dj3*x>MdZU~a϶8[o_1Al.hs٬aS^;{u`%6 uF.Si6|F8][7nNYI&wvu޸$ltQ@`f=~<p9h 5{ @Mc$0 pux$# R1&i2={$*gǏ>ٳevu 1޹׷T͛7?50r9y$H$1AdRR&@ x<5(JJ&1ADb' R11T *)[I2Qerqdu͂$#ф.Ν[fP[tILKŝowu݊9Ym/ܾmovQh:m_(R@pqh!BBڭ-}F'A!x' 7Ȟ߃grwH'yV7NN㣃:iu\~^YU|f{{kfCk.<3on~xP- %@ @nnf@"FDOUz4 "@ڋFQB ͧPDE9 rl6FF#@ `<GeY)"DrcDF @ GFDH @ SFDK"2" @ 5#"@R' xn3 ,N#"@ Z0"Dv @`0G^/`DH!@ P#FD;0Bap6hHh `nu]ʂ "Y*Y{!L""D3"DgDο&e"OLlDgDwa*h "8:3`Dh!@ 茈ƖeyqL4?yFD" @ @ @p7 Έ @ @ @?۶}U'R2"\N 0MkUJI4`D xXFDp ~V/O ߪ;w0ax* Bv灼FOrеP,$xO"ޠ"ly1yA @ I @<@ @FD@Rr" DbD#(@ iv"u'FD"hDϜ'1"|3ж`w{ `ZtFD  L P>#"@p@f D0"i Dш@N Dr1" Dnc0@iv{l"ddDRSm6rfB#yT0pc `Q8ba*DH) mR5s6n%v |8\R؄˜3YpN\ʂFD D2';#"=@" DЈ@""eD @fyջ՟ s[ן? qFD ?4"9@"]y #"i\gN} rD/#"@FD`"hD sv`" D2'dN @0}#2Kȃ41 c@2-L-p' M̕bd= v$I[4M00Hq, AUUEt*t<p(TuDTUU$,ˌ5 jp 8Ӷm m# AMęiju]] mیL$E 9FDݡJQ#Vj%&m&/@LFEd`"+8w])s}kr^ME;VI rթn}W`Vx@# D`D''@# D`D''@# D^σ^ކ "@O7Fw|O6#"P@h;'@> DЈ@pW,.$9XYK0nDc= ̈L#@ @? DA# D#"0@@4"0@h7|YK\q Dʓ>hD~(5DȈw( a_xq 8 8xѥWo*:;:U-:4%ihyxϐ ?"ddD v+5"( "Dʏf B @4" @ @rFD@ @4" % H 95hD 3@"cDPFrm] gW] D ^fw=@F"DUw8hvIq"dG3 V@qw@ @䌈@iD@ @䌈@iD@ @4" @ @rFD@ tr4 B# D޿o}~cq0ޤ]A F`H A6.V 4i3 d{NFoD @!>I  ?Dpq49o(0T@/GDYDHC3  ?DF" DHňDO#`@9g|,Vш@C  Ws֦ #" 8ō3@`m0[ӝdPk] e D(D#@M@rj;P@r4"T#"DPPF""@rǗS{1"s6CQF 0AL@L((mT{ DZt}{ @9pppDpyn[ U.P ip qA @ @ @4"FpЈN N < ; qqK<#`x ͆UX_!X Aʠ8].;{:}0}"'F D@#@"@vm? Q2VE jNDFЈ9hD@TGk]W{ymMujF*cGCg_o N7JP*58<269|p/S|>[[Z]_ߺ&8ZHfs~a;R(B.ܞFCdzӇb N-w_Kl\W'&+EIVV4l*(*= H ʎV JR5ex PAԠ7Ԟ;A$ic&v|bs7w43w~[g _{_9zIRDD86{w|+'yg'9=|Q:1ɯ=s_Tė#>:Ǿg"r<_kL|:rNiDu` 2=:V}ѡK ;?Ń {љX|cƽ?˓5y@GЈp=+GSfDs+GC-7'ξKU׏` }oFgrD -)"mSDgMY:-=1Buո{zRDğ҈ߝK@Јp}@9ʫ9"{S\VZMKKz̷aiDX.J?fDDض (m6PNohDhcs9""m ޴/]:kСC\ԁ`H?\E1OZhCJ%"І b7rJ U՘mP2S Uz+J'9֧N>=66 K) ?ոVJtZ`m e^ fH1SuR,([zԬr灹m`S&JRDVX9ZRh XыO'hDXJolC*]*`W؈b 5h6@yzІfD4 <"Y@$"Q)H\{ڢ7/+\7M}PQm MOOi=^՜ЈaXKiDzn "D|4@<D ?O#@ӈ 4"D ?O#@ӈ 4"Dz}{@F DxuܽO#"$N'lO#@X盝קܞш^V@]EDZUH pAsG@ iD@~"F`y@~"F?v5(3H*J͡ g 9L YhD6C1@Nb}//o"F `c"4"yL @mkDNc :D 5wD2@v"F 8N hD"=@Ј'oDd"aDD"F 8PkϗqViD&jmn{a(@Pv D@p`N z{~x4)@tL @/ 36"ٱDD"F 8N hD"pG"@{4"w( QxZh)x[/g-4Pq1Ety}3 C I#P@ȖF3@ sDݬvϗ}&FD& ǗS9uJF' PhS7:-pϩhDZ\@Fd6& 6QY%M HI DL@ ħiD"@|D4" >@w3^iV=X%P@xs*hDn@ tF@ ħ2_suK9a:K5"4`U" D4" >@w34";Vm* 8FZm BA(NupqDDpqPAĥc3C#Ix-MI6ߏ@4" ?D"hD"@EЈ%}Q2J(@э'ޓXn@84D"ʥ !r-:gڵ}%U.0U$iDvv S&%dN FȒ@( sD DP.<!P%dN  2' 9Q"@"F@{Σv={0JH@$m]I,OO֫(LtULYYY$ĀtuS]UUHd|P)z,ޗ+qW,cd`}}=z,L`&ixڬyd>Α ȀM H]G2чBm\.oD.VPZŔ>@+"a A1eooh2tOK݃n0e۵ D5H")pKr!0JȜ@@&dN  -Fov_0  .FMb0 hY\(&5Z:614Z6KS'5|y &G2 `d2 *^ pN'L(3d"@9 D:kG\$d"gD^ssM| lsJdA&D4?89 Lw&@1^_oDFpA 0D@d"@ Wm"9'"9͈@|Lħ"+,D gȂM2ș@ ;2ȍ@ S2ȇ@(j=ܟNTd"PTwJyx%JH& D@pd"@;ۃ\O H&@1[frAE 82N LLD)+;pq4i$&ͤ: 0 K 0`h*4дUsɹ|% @"P8zR@td"P8D"059"ϠL$q`zE`m? ,"@7vFuK`Pf!pE@ @23s[ GE@ ,Vdv TYK?N,P0" r:HkJR"DQD@ 8AR"DQ(EL @,J@i@)`ή=< F)@"@UG'ȖRR D@)@"PkP@"#?]Y~#@є"䨞Y]IF$X`D@9`"q DaU. rjtZVVk hmhQj@h ? '"vy5`)Xr"?"kE@(|`B VdD)@ra`1$L,@2"@ M7z <ۧ= 0M,@1 @ 3"DZ͵O,RUbZF[Rg͗+,H@p qr D b"DE%XEz D@"%U ^z qz@p_K]D;nͯ;<"@^?o{)b}+F"$1G_DڮFTbΛ~InDNHoܦ'hDbn|s&PF#b" ,]@mD,D%CF" 8@M8'"!I G@R@ ̊joHN vq,&0"0__p\">QP!璉Z.s\! ׉" 0|6k -4ZW`e+[h11ZƸ6 v(@RCvf'SM͛s@ w}Ij3)HD$ȫP_;fsuvb>&S<6APfLDS@$ 1]}R>N';$m_'SLv:@8>AV@$1]~^FsvW ijHup~J%P@ds|1yCW_raxpB[73+{NV2$&9U@dK;1Jug/'_']VBۋZ 'Srv"@ٜ?dnB*8?g0jJLA*1*pjVѦE*E((\(L8H8|߷ˌctgМw.ǟsj"&5(tϿ8"b[ǎx#;w=S"~yj$mʹ272hn t΍:_>طK{g_GiSÕ:Np\DhXVIWq`&EDۖ)G {m消H3=s=mw7ZⲈ& 6qG޻BTع=4;8pqi MKLe> j>ܥ()vXAdvK)rO)2J=EU|Zn}d{O|LJw6hAdz7mbYǦʕmM'ܓ&*l<%N.ՕGf|Q3utΗvං-@Wrdl17-dGSG )l%z$ __%bŇe%aLj~n|*e )mםS !nu((93l6wUzr֕OFXނ/#іmW+/\X>6YVtj5/%7`se"6T2D"`s 䴶F٢/@ڪx*wө(_~ eHe3ow=G/>}OE8^C}}Ov%('iul]~}c<_KZlCԟϺ:b83ݯ_܎t{l !y{*nI5?mEl b㯉+K7܋!d{~g͏aG 'bw_N5ۈ@ėػנ(;b&1ist\mҦ/4&LLt""#^5K:Ee85jba ",9eŘ#g9oI^}̮g|{zF# 3ysD)#Z,Y9&fDd%޲)""MA! dEޜ^O.1?HIemqNeg&FmI6N@]6{kCR&?.:\\yEN֊O)t9E]%cKK:&>&ܰ ,17*}=A;a뛶Xgvf޼݈(grE ]' Uf6{Nʻ9Qq,gڀSg^I1 8gz,dՉs"w=rlNi0TlD85&.G@\de},SB/\'W&t?ȊsF]8.!eh "lϊSv {4# "/n/zLc-`3`}# G b-%6S]M^X?zehse2wR 6̝;2ȝ~n,@K-o4; "+LLքSR5ξgfrB$3DUϛ"C5jHoB$ ^~ږ`ѐ;'pp+%+'n":cM% V/H_7DwbvMl@uw8$͝Cna.a>GX6E'%DxhK wsڍ9!i[M}e㜑 =v@U\랾y J,-;i' OcUSPZQvfo{MLZ=i( hI@krW4ӯ^}t(kLy 2߿5"{_xPwe oJ 7U]%sL<]ܗw==fTXZpP|Ob-uR5ə;-;b&+@q]i_IU3,Z92se9bzپ)4L?' ຎ9eW\_RA_g n%j}KJgodN@k?&71^." otmb71xajtθ(.KlaS@DVne0GML}N@O7O ۩"Kz̃}T;6%/~T!`kޫo=țM |_AV3+yȢlVMr.n^@DV]/\3r JDpL5jsOFfJbWh%aDjZgrw%+i}{u7# ߀,ϛU4dCz'-^RX>hcw0iu\'O)(WZ_?pPv ׭zpXH4S^MK;hA~[QU{wphQIOAzBxWN4in+^|.2r=wz+䉓$UU\|^juL6"cp_}:'F 룷P),ITW-X0RYRkMkBv ]ڂ>fkJ~Pϸ{1acFK['Gy*kN ;^ {~CUn_2HMҙ+ UaNMO'sO^qJi?*>'uѡJȽzEڽygE}%vϫG0"ZJߜmDl}'.QTJJ?ψ&t7%!St#=lFCΜ9uHs'*g'} 3?v=27cfٸ4K6"ZBVdp-E3yK+r(1 "O-O>ݦUN*Zt3QSح!&2jkRkcl?^T;^I2<߸ȮfpoOCH/=/50b@Ys?8fBڴY~K:[g6rth{dkNOK8zddfo]Xe6=D%cFh\$ 8"@# 8"@# k6@L!1u3x%ZFN-"9s "p@8A N'D "pfWLmVu; ")n[Ϧ" ݿKq8(!& [.8 rQ)8Ihr!"(*hA ~ w>ZK4In4e9'hq'hLmnPXu Qgqu燡O=_}#*=}qPG3,"`_嫧aE:vzȿj*tm5Nm`o‰0Aؖ9{g>7[8۱ҹL*HN]ґuE DeaT<2N }|UWx<:Q7X{+/̉Xc^c8@KxP#/"hP MqLtCm,7]6Fs.(wND&wҞ(-}`O^y|w΁;z7zWjEywLo9òаʿ]~ވ<w=~#**Bd1î2j"Њ%f;E{]\K6i5w(jD|yTݥ-I 3]몍^NneZΓ2=Ik2-ZTϿ#jLS"yIT*OW>SK7e?8(]3tF-yd$d+c.{J4a аyflOBV׎oQ_QȬ[.rEͱOȄ_?xmBgRA k7!+C +qd쬨j"j Drsʫonkye°QsА?`3qU|Ph̒i7!𓳻DaڝrlSc-* -!E1;@%I۵mZ Ү]Ű۟[#i@a :/@ɢ(얔mݖ&Ho+kaٔ r=/Emy‰'=Ҟ=KK{>Q݊Szό j""M(JB7T&4&Pw^5V#j_zͷSzBs/.R!+9UQlC}UIJߛ=Pâ:MWثqEQʬ|fB#ޟWkƻԤ#:Da8j""Mu:QȪԓ3v}W??$#ٱzqJu:>m;֯>E""9H}KG!zѣw[m{gW$QQ-^7!7_@^"uE??s*d[=+^򯆏] ܽcT$[>C%I 93QmuQm/,)O&6{ܕ};D }'-y:%{8afՊ/5nF$5Zjh"9GNГrCczf؇vKG!+*3"Iaꎔ:o'\rͪfL|鱻ݻcjTIQ<$qR+rim^K֬[je]Z~Ȭ}eQhLsh!m D2+>D폻≙أ ԉRUL]xV&YsF.Bn0kzlܫ_\$J:hcL~|X/ºI: uwհҽZ~h}[ŲviGw*B!'1IV9˚8oc%޶;OTTw olk&DQS_Prً ٱ R]ze.hu"-|gKN2Ïg/<+ΞᔩX2Nٱn'S&MƊ;LZjθeG "yN "yN "yN "yN "yN kd[+`ND9A`ND9A`ND9A`ND9A`ND9A`N +djX7GIENDB`bayestestR/man/figures/unnamed-chunk-12-1.png0000644000176200001440000016067615174322463020466 0ustar liggesusersPNG  IHDR `oԒIDATxڭJCaaV1lZl`{&‚VX2WԠے g`x x"I"I3$ 8@ "3$ 8@ "3T{j6j浛a/NG;I1NU^] !#Nίl?N8=>~'6Zϟ(H|=6fK!O(,y<8;֤ldÖvI9QeJϜ0AN AI"?rCȏi;[ }_8^}o$ 5+vWWUe|& l Vzr?'-./+NuώԺCK  ?X)7D|rI֩!#3=w9ۺ|К7Ӝ iD{S ?j|G$"XEZkB&?=c|8Os GRĩy>v_+|l-=/{7.%xD!8R߱|ܰ}e쌽q{Xؿ'6ZJBPW@8.W;͂e)$ce>SItP& p?I]vA): H JRC^2TL5#L)LS5ǔhEQ32Rxw{{rณ3wc~@ R~o"E=ϼ)nK澳BQԣL^Dkw&W^-3P y[BQҡ-QUU* %T2W~uMq(J6ڰ3wb7(w1ߏi%3oXfK܆9#ҡ$5'sq;mZxRM_.:aȬr1P"]L+Pމ)Vs6dM+ EQgb DڛN%z%ׯ;BII v[c˧Q/mɯjضFF^)ǏV__* ^\:s 'Ov+d8E5աMQMMMJL&>MM R^r␡]|I}re?:P(-t:6USۦs92eJVVZ+~~|y_ġ$J970:&]SBCsl>$QʚD*Sܸ' >ZDϘsuHEBI6l6H٣{(ԩSȑ#𡊩4+9(lU}snxk^q޾ɭiK. %cJ}}} q2cƌ[ihh D*K'7 'LMx7W_5*?wKm7$BQkߍ"P"?]1fD~ݹ1MwOonoRu(:"P"~O%CIweؐ;OIf-F%@ʜ@Bl{'BQ/dNI} H;;?n1P1{MA N R.:4鏾6->g=ugn o_[#'(-n5!ޯ.D6!D=`T_Lk8LMDu^wԜvߝw"l6 7[GrI t_qnc/:rT/Tc_zY`}afl;FO:{4"P"]ݶ2"L6VT>:Jt,h=L: "t%}nD 2Vػw 7 .h. G#`=$l_Db^z-#&nl@ Eܺ")t D  eN(@}D P\xșL PYlԱpB PSԼ@83MSD@ n@q#@ 3a)@ $ L a@V]׽v@52<۷@YWzh/1|d%w0$t0#q0 $#n0#d"k0&,!h DrPXV D@#1.D'_02\!MZ35\!Kp@L  g"8Ǚi VD(F>ٹCㆡ  u!CZ  S)*D\(803F&D&;+8F 3cu2<ݭyk G~ Pv" A}f @@v' lAL  5a8R DD@q{$1"y"‚< @δwgdYζm sD  &HeVbD3̸di x"-@    OP@@((N P@  D@q P@@c8@q#p'عcۆ g@`ͮ6G XsaH(;L ?ۇ@ a@Z飲m[/ܘD@Zr?<8S7\ ]D%@r % 028D@]@p ~L|" DL~HI @H "@@bP@H!M --] o8>}10z N f"<q :#c.h">:pv& D 7#=@I"bqJ l"@ 6 Ea CZ"p-DVF]hiT*\BY3*P!<@f%#R{Z)4tK !zx]e[ "C"L,xD`TM<&hfhx@  -Q8pO @pDI @p M;Mp@r8^ 4DZ % / ?+ $duwx<.| 첏- #!@ @A w1[(2)wvG^D6@Pk Tȳ@ @( @ ς@J@ X%*qf{bPJ @ j8"D 3]=m@%g R@j@ @ȁp Dٲ [v"D|2p2@p-8*@r)1MS@Ȟ@ @ikr`w\ٻw l5K=mT@QF),9,?d& %@ T@q@@ @; DZ+"D P9'@`*}[)@  WX%@ T  "N3+G3ȮmB4v/,n8= asDH @rqDF -HN 騵@X9I"!-|*UcRu?q@;q (t%wbI, c0`\"2D?wD/V @ @ =w0 C8_~G+{ "2PS'(N P@8Xl"5"AL P@C1/@*@q@qH$yum Jm(!'(N xKy3@,`vi@??O  H"(N XTN @8@q 2D@6@`M(΂7\l9%ۊ݂3@e(WGv`a9=' @+N S@K*q@eY+7Y|DtA xl@K4]*8S{("@@~pppN N X 'tc""  ""1F@""Ы;{wh0`@@ 5Rq&e0(P6R?{oCݹP@P$'HN %P@Ж$'HN P@P$'axۙ9@ k1" D@%C @Ih|>N[;E ")D$'< " D@@ @m"~" 9@rHf?hkYmh@Zۙ)@ @ Q N -u]s<6?vH)^~ "/{wS1FatԱ5Ẕ]@E]I(9gf.D2Du@"" ~`P1@8@8d1J N N A:#* D D DLm>nX :%@y6u- @ 1P@8i K0z/O~@ @rٗ9g @e "dp!N"D@"c 8\"neY D I4frvDdU"OAU4L-'}UA0Z/-"AĬAAvwp{~3 @ ^EeAn<,0?k\@ k2 @ m)xlx08zO_eL8^]04Mq2H1+w~y5O7KFlP_FK/5 o)@{[e}pzUƥP a!q2`Eq1eE`6MWaa e5MRlbaYϩ0'w$?ϛ}?"iN{Sl}/ M(q0: 3&V %КD%^_n,BS._&v؅6yy,p.g@&iEʞϔB3{5VR~WV@UQh>UEU!.(DZp۴etd  bdt6.Yfعsg_Hz=kZ)TYPXZ)} B ‡ CXj}m@z5(<^8hJ[o3 ÆIS* zZ{DW]:%wkivA%ccVT#QZ6ub=zW^ 9}gXЈ6)!ؖK٬\q'O@ݨۧ M q{+Y#q:tvxDhQRvd)**dZ6^.O QYY@Z6^T^^XR"<Z6W]|4pF#uI5heh"$T̸{|p&%9UZ׏M B\rĉSB\KhS'߭?',Yh"mHE\٫NXNI1}B͛iT0w']{:%%9^JrײW]ODO3nC-BB͉C6|XJ]~_N bro\׈}ᑻ' ޱsϾڱKU\C_uǣY8yZv  @1 Y]3zE%SNTFQH]6pO6m-''gM"4:ym [WN(볷ys&OJ4e^~L?Kjov D("D"ofD!˲J9@ =9Z)DUU_D mGeze i8%{wl0 a$0u&H*@QRd W}~@ 3[@u;]-D$'sl"$'sr"PeYn}"<ϗ¶mh"Pqa59?W}A7/@r @C"` @ @r0j @ 93 9n@ PX5@ N7 Q…@ʈ鄀HB:HP/.3JMRyFs@lu4'B"MDL8 G<ޥ|L<h"""`_ C ''k=@8@8, @h@&''S=8@c8Ӳ,۶D ɺ_DF p"D DL<LT3Opoh""`_pЏ@ @ @LD D D@K;Љ@ @_жa "fKf٢Kt {o  +)*9w%C"%Sl>xo?{b#D̬=szA*7" .s([uݘfF`10R̙f]+1 eT 8W7q(s-aήKszI/$G[oΗoZik<5|rQ4iYvTtGh# "@l"IJtI#;0-{kI@D^&F9~ hoȂ,ͼlF&}\* 9wvơ(3n՟Z3-\E'NO555ƍg͚!8qnl]UzE3WGyezQi+\{L2xb8UVV>ޗ$%1 \r 7.cK*ZQOyb&So_lQ R!7ҳW|*rjOqR>6l$u [ߛ,s=r<x+룤$@R"mreik+g%sʒʟU;༗'f.DK/Hh>q2.ǛA`d D۲lp D^Эm݋gL?c..pkCR'OLи8X(*\# 0ᆣDc~`A&0yGT0JDyW>!< C-=玚OnKo?< OoeNW-[WnEm~3"I3'f7# %SJ޻Y3\Ʉ(,g:z͝;w̘1yp*UUUK +@ ,g@<n+#=e~QZػV8A&ERg$X NR 2H2"\9W>˻ "t\nL& 1$I} ({g?v^.~B_:y#LPp$""$/f꜂PDG[)=ߞo-/.o]?UB-/w'Px3=>1uXûTCKkxrnf- |CG: BC\x:R+蕝 8=wS̨z2!ZtMAExE ^EA z z\js9 ,ԅjͩS9M ^/wܝi7-jU0D_Y(IpDɶ,?ջ8kw7Վ|mLn{ﾳ+Hcu I ozsWSMITܱ "e YA 1XcyۚZ^pݬI Vy^Dطwp͓&Q*z{OQJͺJAܞG)7jkmd9O Ftʜֵ}u>j[^ٜ6ziTAK˟iUe3Lb$`ִX" EEԍEeʊ" #hʅȂƲomfmh:n3sѱ[n]}s_8HPHSc$I{kCX/)5I'o7NWLߞnd՟Mo#NGjZ "$k Dq+;jx?~KU-">ݚ "$k, Dt/]qhY[Tvx~ܶ8,T<Ԓ"u$k;dʏ}mڸaݓ،܁g>CzbkO썦W@墔8ko؃;I*zy ș=آSoy믯 Y,~WKk%g>q /5ץ)2.@E [f lIlD=R.43`1* <@566/2o޼~ Ϧ<3;cjiXinnʣZy4vJՀ%iе8DV7伺WZn`t@jfP$Ce4:%z6'1uL :tEo`KKaEC]\TSX#GBlRlPQm?6\yvq#'z{M`l\16ym!qC@$mY֒FslUY1Df"^{6<$t@q+X+]xqt@$9-DZfΪ:YDk/?m5i萙H$}=IDo<0@di Qy¨'.앋t]ۖ_T@"91ZMckjh^@Wg dg 7?~s}*b#/wXs{sN{g}ee 6JKcݩO\;)+R!GBlX)IRW T.9sV8l6*+f&Ef̘` v)Ҩ:yy~p 1'ݻK`OI|{vUJv(޵'CƐlkyo"֧(lx^L +Im_r{'±ӁHtA{T gxTwO/ l΋'O!k{6Tl`3"ӝ-5Ű`g.jxڑaҊ0/Nu=Ӽ"@/sݽKay4LEKnKTbD aK RSA BDDTXXqzqj B M#y'JJχp/?˃2)}YHbQZh?r#k#Wh9[4q$$;ώeTEXlN$O"vtƒ6D41@R"tiCSK4+$~wAVusβ , P.wLFhaf'1s̬"B5=Y%Yj!b r۲(+wLzs<<}76[ogҥʖC(HadžM1Rn\ү_ExSUV(ʁH:fd:_xnYG܊_X 2G  c 7~p:?w/^-箧Br|8>~ 9c܍W\衸~?\5w$&w$P dߏi[wNq} ;[.u?;Bd?3ct͞=RP[[{BC(C@ DB%nyw6|s}O}eKk ۋs1ī\C$3}BU(@{PnCRHl:%;jAIW:d귞hEJ̙3CJIe!YO~I蹤_ʹ-ZoRb Ds8I DҒ=+ջm7&=؆ 3>: [fzvZW?s _9qIر$?sG^pHrA]aQ[$GDҒ {KI3.w?xk+/Yz 64V=lc&Tw~@1^D$I.p8 @$n}G߹Μ~1:'M>cN~Vŗ_yokl+> wo~{ςVo^tȃYg{'?2_`WiGo<$J2,\)]3g y"@9YlSyZZZ"JIz+$_6IY-)M"@khhy.\LS7I ?^IоK:ₛҜa$O1hAkǏ;܆g~vc.#cV?pф$l/ILqsx%6wikgk|cu_ÛHqA(s.P ?ْ$~񊙶%sNNC$sw:6~$I7W#%@(s"|&IR"ġidG|7bjvڨ$tKMkb 9s朑_P a$Ilzs3y됚o^-mK9&Hfn(GMb `DrkMH~%O\Q_:ksRa e0IT\PL\7?nKfgA /n!vJ??hK ]u_rG> +B bs.tɎ?g2N=uB6tm|q@ySl׺WI!Sje:yHU^7ʖ%"qsdFɆ>U1LWmj=; m1tI >T .-SҰ[d"H9E+i_ݱjSawtVA" 8 C\D7 DqH@88H@`@3DA)iĀpKhw&? D' > D@hzI2@p+vkF*FOtl) @h1@לZP/f98P>Yo-/`\`B-T:̤H "H @pv)"DCP.$3@i D'= "$yt:sA@RndY_1 "L<9j5@ J4‚֧o?y K(^<~ʽW&GBHD7{vGO_rw@J__?ZtS/jȾmo<(:($ahZӘ4NfXX*YV4JըWYc#yhǠ"<fppM}2>H_+"T)-ؾw;6 ֤:io[f;O*FDDD&Ts]3s̠B"ְCxo~œ'1"""7̢$?{Wo?!2P0is3 D?aΓPfS^w HOCp󺂯c sÈDlٰvOC~S~޳./~562"Ξѕ筛=7 KrN3@ȧ3D*f~@Zzщ/d <ׄN_+ʏ`)j @"""_ L;)/ڿzvgEIqo7*?<*"#9Ϸ]d ,s^ˆDɜ1vm8d-C]ck*/OLlD߈Jὁ3`Yn&Ù+ܱg5 HSGKf D D|#O((-۴u] dPd^o])ۿ2cdCQAR\AOD\E9sLl 7 DBpDnGulٰ6iU@@';΂vmfm#!ih\* w,߿}EJn.?ƅC[.;i{$u'p@lVVEICPAr"ҨBg0"""b n"%ۖLcv!6=\Zt7]C5Qp!ROλ纷b,i]joVW{L?a09#FhY֭[[y#"""6"h b\>oGw;=obgp]<1NJ,aK͜0"""b "??$jֆe9Nu\;olv#fj2Ndtsxg \>1)gilyb@\~5XEZ<|r纷pp. /!A !,1z\`^!ci!<*+!C뢹&Yŭ#- b:7SDՓ«o+]GuflipDFk.QxS;i2~?+h  &ln6—ph"n+NITl R]S Mw8,w aP0$Fd\}z0f8[dKVEtF#jZZ Z(V3S)v7g_EjmlyfRގcj޿ݛ<ؓR:prp_J'cÛXٽ)7=\}3R+mmm`Evnb )O8q?;?qq4w**^O3EOVtݶᦧW\ G<:R^FGe ! ƻO[nzH*W?/ٻ{(8.ENҡ:*iph76Ɔ%n!]\Cwp_NQGE׻{|A};?/߂s@--~NFے_WiS2:?޿VvdWKַ,$C(n}%΍Z 2fi_Tq]be8hq͖ {c)n]|~e+eb۔ n7$աy++}l8p8nX,&A r=C2Mji-MҒѮ9[:}JD$i8p'ERWkjnhΐ߆ٔjOa(Bxr*nބ[k* [D:'L }1ثfll16!{i)N![_QK^zlwo=q߿o TRr>.J!)'pA.aJ)I)E.ܸt JƮB) ~۾شx>7$ZfԴT^:1IvUSrYٌqA\6^ ]т}G7K""-4\ɟz1n~vO)Y?)kCs0hx`p_e&m?}jM6K[*^~5"ښ8\Q𷪪uZQ5GD vְ[V7v ud5}Bo_ [&.v9% 5B>7";e[ֽoNVeeetQ[[I4 Уd *. ~wQDanL6[I0baEFmD36ZmJ I "* a407ь&C貓>ow.`{eʡ]ji]ϾkNۦ:Rot@DP(: .Cݡڥܭ'7OfNg_P_%)*q l5)r.` @w. Pp "$I(@2F8t \C>,6Z@ "͇W퐃WjX1V n(v ? =&T~! W-I!WQ8S`+H7(rD NAMН\D NAʡ]ji]ϾkNۦ:Ro \DP(:\ ʡ]z2.~|Toth|E̎ZB( q@&+""""?3ZF'JA4???$IDr6?~O,.;s' x% l߽>j~T>rzW.>O%@M3_P i}{7uұRh]{3 S 'q M$YXYYI݅V]qmnkA vʊڃ^,B(.0D(B"u("&bTWn=x!Hf)npnm;=k;^o?rI" [r1G,ob b "I D%28ں$_x6>eú{k1Si~F̬C$ID"v6unc ӌ9{^ce S%+w)"03Id ,=\ by=~h S&+"R* D`f"$@XC&XyH:k#2Nϭ}hJI0XH$%a! }wBklll#}@M E%au;~b.Rۮ50G5^lP47Q,HcaBmM0e'ah.'D^gE. |i0 E;Ve¼dn& E e1ʪ)fq,H"I}C} g yB(P"p.,Hvu˓0.:r0/CG0q*-e?.ƍ a mg¸XqˆbW^^WC/wxPxBi|G 0x?.S,OBQ̬lyg$7+oozvo!D<7;ZeqtLs"nAĠRJwQYQf)iuQE ĄG1-V9B.rZTPTF1Ml wٯxy6"|fP4J$-lB,ab~ӖW=ž#fsG~kD SRKokھ C~A$?e|kj$]Yuoc۶x]:;vokx}צtuYC* "<p>D$ R2ֽ:\TIUMmi`,R Dy@YHR (OP>촓*AccK3d2pZ) %ˬXY$+2uI̿i\we?9Wgw|^|jÔ<T "aQ'nͣ"|jOwTy葦|K9m63'.lW\_&ţo/UK6)]YjݼBOJn͢_vӊ*%F֖{Zeq 0$I Dھ^6, $#/`k-[OY^tMǼ""` "I2d4#;vLJczDq+dXHlݫ6a95EP?t0Q;(CA'RA\ (El&9‰1C8LVI{ra$KK+Y-k^sob#R~giLŧa}8_;7[yGD߮b$k]c3Y&D~p69OSP~);ux-&R;vHTlom@5 "ɞg['1q>3T 66([_cB67>T;t`-0TDHXVvc"gOw2&ٓYPH]pVwusK`"`2hfbצ P`nꄦIYL?7e2٤9NhC,j,Z4E0m"{2k?>/<'t[a#?ydMg!iy@$qwo<爤8x)|q>tK~=녰Cvwtpy;\-}3(?ֹcw%w hjj %ZZZ"]s$I@SxУKk <ж/~iGeKϧ<$E D*ں͛#HT% D:W쑃zKN아=ܑF)f̼_?=sƴ)M}#s{=Z7x̖C@r&M %#XHLE DM﫤בEd>"@3@D$UE #N"k^}(@$i42>1 #FP_~Ǫ\xԞwK @w|(@e @ _]c @:ض` P| T@$o>OnO<ؾ kj?طqCO~ֹ㯺qX-*+BPhk}n5pPIayg>IP%]1N$ˬc_4w)=ͯuFR@C$IR D.˃jCI^-&"` "I+PȄ)}r_=>>rܤn~O1=wLrQSq^=;neR.kWLmx sG環GvOl(DR "IT]K/fsa$7`]7t.xc?g$ԜrsͤH [z"8i!c޳4%1yÀkN$ D@D$U]@eB9l_ P7Vn5PTXS 3>tS&A犅އd^zå32'^? PN:ĢE+#-U:CQr9#Ϩ=lHvU"T+W\b˖-*r lCQ =T;``l(v8|"!Ʉ]:::BOŎvf3d %24' -;"BQQ},DHvȰ!Pz =ߜTs~$w‰'TYfQ3 +[=ˡ? ;%qmo:6 ;NH455---xWs$IP.PS/wR.Kf]G[C7x[Wr'1tI,UG7$af>j[삭Lڒ gꌤD!$z%rIڴdcSo\o~x͹C=uEHZ$IS5M~O={1M 5SoM_-I0$IUc"} =x?"b ٻ*紤)+:abMvC-wdؔNŒ8;P‹^q1 \3gX! :/ j vbtFс/^hss>|/\c"IJ: R?=sZށ[go@hM RВs?fMO%8Itmxa[;Sý'شɆ{7ei]o\T[5}ƃ^5We$IR_H$وT ]wq=?j?(T(Ï6x`Kc{`Z`j DbپFӧNvB DʫTQ/} oiii:Nwww)9)]RNˆ4 ۷6NGGGh)9 eWؼщP[vp ֱB DBghǦ%-ܳvYñ@ DBvŗiꚋS!?{G_8A U,m\?iIx[ڕlyr/[o;v//MJgHqd2al6Jɾ}+ˆ IR ȏ W7j.O»^/R D@D$@<F|wmm} pa0T(EO<3'ZTS@ExOe20N6PZ*$IJ= \1P D&2e Y 6Ñnܵ_hzs(P(!_z_~Gvonxc 1IE՜,_v53|IY b }ϪHDiv DJ[& d%B$Ic vËZ '7,tk{o oR!⩃w|&#{U{^Ĺ_$"o@ cfܰl wmXr 5/*K˜8D|dCȵ;Ď;űm}]wue*7|Y{'bxЫ_YxA$vt&%74t:dL6hzhAUg>P(U>oLHMGbT^֯I-=gŶ0# uOͭ'Pg8K^l%/"N; @\WgˆCu?>/;T&OT.Y_e20N6PjZ*$I4Q {0?.dzUFaQ∣?f&dkd$"$E&'H 9Aj-,EjaaA]bbv@e3wW{4LWxYT[ @,yta/02@"DX: B @@]Τa|@x ;Uv~9[œ_7M$́tC"^Өc}qw~x1M7wKfY6_d2]X,@`#E_]^v^:Һ [K m7JA@s_}ztmW9D@w "p"]!p MF, 2h@@ D=Hq "pd\DMFt}V@T {vضa  18su9` l % 4^Y@ Ē(D WZ3MSn\"džx@ @ г^ @Mp8@ P@ @Ks,N2T#U Dc]ξ "8ye J @".Dاr@Fmgvku 04T@T @h^X"P@ @ D D6 PeA![j2FN5Wls`q 958(L =mvm Lum|SD(C @U"V@ri4M}.s3Mp@"@rqP@ 9)@T"HN `] P32" Dx<Pc" DeY(&" DlIs@z1 C].GތQHN @r D4 EaE F &cy*SxK.= JB !p|9Sw" D<*A@r"E" 9@rRu/+8p' 7"/}߿ @  qLD!-5Mr:m(l"~"@y\ ;@r6@P@ 9PKPLGj$'HN Tp H$'Jr  @%4M+˲D mVax_ (K G [:+19`l" "n=" DػC(W (M;ԑ6̤) ".D a1`9w*= +O+''z @cpN7h''t=@8͚@ `]2wO WZ`'u""@( NPu޾? "D/-Qzq6"W@8^""@KMhhH N $*D DJ4lVXgÙ 97,"@3n9VM PL&Q2"Q!ؾ@ 1{"dL`iCDl1"0+e3o"D0 #(K|r 9@r KrpC @(\ Dν6qN[,( A.Rq*8ePF(*8"8 t2:EY# E 3I6P$ТRD~I$"9pi}ҁ?nZ`V D2Q=g՗BHzV=u^mO7ީЎګ@tHF/XzƫӱܻGF~>O=n }ữku] &` EjLHjtl7fiYipӲjLnE"j3k n2Ya\݄#|_<3=o Gҫ>=|GJ^1@e$I$o`d3=\>*I_vkGD'IB.eqɻ&dUC$I$F<w߼R~T/O䊳&eywndUa96PZ՛ ¾$xΒ =?_x Rnki+\aYC@"dpR:; 1ů,&U{p7n+Wi]I^ D*BC]0eE!W5w'W%a_'^8dK. CI$ 'TlwrIqt1 Ib;wu0T63 R˚xþcS^wŚ1@z{c XA=sG CVnki+8'd/7m޽}r'M\OW7rC9W`F<JiHBbp1aZ7CXvٲ.Y7fԨں#^첯56SҐ:n۝"<\ZZZ 'vww0w$c֦abό_'}xMwtidk>vϝQ׬ls?q!lڵ7I.2ui%u[WLCӾ9\&!O0@SSS8wyaȓH$Inp8A?, صc{g vlۑ\=llt֒N}f R *>٣ z:lB.>gp3^v̤4_<0TdyӐ+olm W޴1Ο[t܄i藕op8"5IUKq_uaI^txPt3ӐKƜjW|^MMMC|$I('Ttӎ Íwoa?oli:V!*ݻ߲$w{7 *ۺ~c1 ;FHEB.rܧ=/:rɸPe[zF1 QnicȋtE'I$!"lNU'44lTB]_{޲-2v_?! ww~ݰ+<#vƛ^C[+nX#QwrMFHȶ~Ii%t,>O}^ͽ?u⽓Я;o. O.~kWK_~䤧Jd1:ALJH$IN`3 ==mqǾ{<y:qɩK|p,g +i藤yeoik}{?xQ%֑h $Id#g RQ[~x$<-Iǎ;*M¿N@$݊S&$Źoyw@I$@ ` RizܵI[N\UDyW6 TM:kvb"XH$I6"TJT_p;_wK2X;q漗|ş[ѽunKN~K^4e\fL9GzɅo;1g $Id @0a D$IlD,i@m10@*U[[}tvvCA` /pW^y֭[0@~ /vA A!R}ЈP=:C h 3W@uumۨ#8&\f~Rz4 0o"P"`#Ɓ @berf @ D]#̱ @0 E#8J ɍx_)@ Ėl ˊs}`D 6j DE)@Nfq @V\Dj# 9D Eȉ@';wl1`)2HΡ]F1gKR>s}r8@r<l NqT #@jv"80[uDK|0?$'|j$'\$'t Dke"P*` @*|$@1oz"%2@rG P@Z`].K %*PQ @rh$7_h."\~"Dw ;@r! @ 9vHN @fm#0.8ด R`F:\t Ҟg_}s 8@p `'N L"P0 o;<@$8Zp#2 \f@./@pϝi mTz/u|)@ x " D 1W@ 8d0"'\@&"?HF xG @M˲|l8h"PSO;4.D@nC 1Զ|.NUpTp ѩCt"Z@ s6QF' @L+e@RLN8syH6؝;t_}3'> D@P^? D "gY"ZAdTL @bVaJ @.뺻8^'@p DS 6 D m3M$w椁( q1F\ ^{H96e\L$n{&Nx7pjM-PxDR9* T@B"7s@D"@ገD4""@ገD4""P.}шDM?}S@kڇ˛m5q~ C#"IX Ҙ0"N ٨C4""DCl@NHB#"?!"P8"'CЈ D@FN CN^x.,P0E ~:iD1P( D@@4"@!$M#  wҧ"L@.4"@7OWQ"la4"jFk @Ј!b1jZ4"UVEQ1eYV@ m ]333333 `ă|w) EQ,-'mEVSq 98H d4 ߻8?(t`Jbu"C &7i:ǻL D#! DP@0G 2F`8Bd"@u"x+"L@"CN 2i7r pH<dH)U” p`J`80%DB3hD @\Ґ.׷+8w3)vpQ3v{yp7/W9s9\- "L@4@>u "QHC?~p`JN"2|1%D $ "G"0@HHC38DzOt)8@!@D@iP'@Rb )  D' )6j9WP6S"pH ަa( ð;RP1@)؃m ` - /' U*"YI!b{G2$ _2%M 3SeY UU@]/c z, \ pMR$84`M& ' E&I"DDICN!4ICzL&D`@ $O "ZE!28D ]@7D!1D@  @28BO}͟OkA|[fD&" p2EH d@T@@Bn/nFQlPЩ,jb86; 3333333rD A2'BӅ .D@t!(EI OR"@t!JY vP@ȁ("D   eJ D,8+@;((EGi 8[,"EW  )FP HH@gys_ DB"q,DEqۣ^>Pu @ D5Xw WЋ F" E?;ruf3PeŸ*i\/ok953333333H "!;E'~A!n!H@@$#9{CA$#%8<݃S0Owqu?޵׮([6&n4Aj0tf@8A"#I 1HLD? C hс΁]kG6vU7w}<^ܿwŋC 6m/T{x2#I$IHn[sə(MTQ|O:z-$I$It@䶯(U}ؑ?'_xƾ2>a `"@D$I$(@"ؘ u3/cͦwm{f}2 C3o}iW00d "I$Id8;>7NLG3Nq[=?7)T_xwn NXH2$I$I2HxKyQՌ6?*Fg&sw7f$I$I$WHw[\M5WͬU. ]~X`7S.[[`w"л܋L^ef_pja1Gߚ V$Ns}\KxGsN;8*IWv;C3S`0Iގ^(|aG|b汩PRM!/WNjgGe00mn(3A h"I86BiGOiDOm޴9;' DQy|z{/w $RIJ(#1oeSS!/L[#?uǥL˽;Dggg{ig}v($ܣG/$W39{]%I$I${e˖-~3IއE!/[7@-3+Ð9{-['-Z}bŊxyLv!/Da$Q'cq(k"I000 LUFTɄ?"P D ]UY8˅e?zRh,Ne@$ R5ա/#&4!*gn-Cir&Yg4556uPdܹ09s"|+4}b߮5W7B^tGNN!ywuYzu(lٲK"֭J bVZ,_<` "I~aQȋ՝+|*}hA(s"ItLe]ol͆l}8&7Mˌ $BI*W{Bi^ 1cScq(o">yzM==R(%dz훲!/u' org Q9NDaPO٘ %s0(xP Db+00&>#7#]pJXʝHB]rżC0hΛ%>[;q!ZnOH9\}R& !~iVh[4K}oh1qm]|TT'Ɓ'inn͚5H}}}(m…ZZZ@i&Mj-2cƌx$/P*Nxo"S@$qݷ/8fBEUuƵ+_Kٵs)@$GyKZ[_˿_oM @ D7f~B ?n:wuC݂AQ0 K%:.5wSAp{E&R5&˶ÒnCz_s]|p9#Q̯.ţJvlcOpSJL*[XF[ ==oZV̮$#Rzh\@3K':T)*k? 1_fg Yv9~O58F+g5ҫZ[1&3~M8F>Uga5z014퓢B})@ UN&OJQTǞ VJߦ{=6O qÞ`p3x]dہȚ@O {|短YY~}د"G֞S4WLD[L.)HշSkT?yz' >.@ƞ;f=:5)թg?(RlQ'V}ћ<@2F@xKJoh^O؍0D՗#{Uo.89goZW)*z!""$-z%"*֥ۍEEI"ˈ(k ALT6wi˳]l8r~n9YRƛc cO۾61gՁN!Ptt =fMvz^鋌fԬzϼ̾Sgbѱ*skDHK6g!,=p_/NVI˒3OGQKo]c–kK[ ^hw7+n!*j?|V0M(c' T h[}Y\.6i =]1YM^nr,OL]d83Pƾ„A%/i EGtߦB~pOS(e=Y#iٍ&RwmDZzTVJԻD!K>xB`DN0RWZbTQK(M˴%U[roS䔑нs'^vJ1 tnBT=í;yxUs:Y$(@ 00ྍ0 ^UdEFg>.0uuPGw$,XBӝsNu ]tyL'_<<r~s~W 'R3󖎚s饦jru{vU7aqq!69!% @}SI'ڇ.WcVN#,Z׻sE-q.w\Q,D1 Ay,&Lw)Mp[9{ap1ɔI7nߣ̙_nf1vir]ăؗ-O`RCX\x}/]4I?~[ K"9=r1s7nMҺ$sV @Rlw툐AUDG>5M#w08"|;Ü1˧%*E'$zu{7 Uq-ϷxG)xL-6'yKNHZQpӤ ٥9N9(">&6zKӅ=݆ v9!%h&,2y5A$I{'Iv nU_xow=&"o~%B?~P4a~S\182JwY9YL뜝e2v2D3xKN:"-/X:ߟɜE{j59TJF.)o =I8HIdWh[lo֕s8 egh"2WVݘPuvVr-'!ev̑zfV.deh겘5B`;JJ|G\襧'>ڒR6%ww yûpjr) 3в{ïRNkY]4aQʲ蠉5fwuyOZS t:w/G_3pm ଵS(NZ*˴iyaO (cQ z/3ev=bS}MhT>KhìCD=Wr'DGfק=R8'T]WE_V y`RO t^~$-\XN잉i™+]ץ:\RnY>sIRdR!MlŬO4BCJsBKN LP'5vW3`Ɏ/ZqDSя|?N2v3񹵜T @۔nI5L3m,R] >1 ~!9Mz'$>_ '?!%K%>O>gV} ]4A[$C˦.("9!%hh) _qǢY˿z:7r="u=v< |6dRd^0@|7h¢|:3RRRVJްQ?\yY34 KpǼy9CHZIN8 Т#h\ٕp|uucX]cLH~÷uׅڜpߡlL8ŀ*-K#+]!RXT`oA%*7ŸRIs2my|'!9!%h.̽L[~@J{I/n|Si ]򨶂cP'DVM]c=s{ [^VE3#NI:P!>'ľhaSv--?jĞ'G7]1%󀹿OJx"z 1 8KnV]g鼷$)h:S(Z=Wj6=fCLǠkh^y.ptiEAYmzLg.QޯWm Hԁuk ;Q^:pд8i@%'t R-޽y5a nX_D[jc@X}NSaA3|IYt hdj~9kU+I`uD=٘Jpd~D), 'm ~p9U=tNj;Kw:  BC D*r)-Q{7ڛ=_T|ȭR LҾ53M,:N^ (/]Wթ}yO7;wyjAp$ػW:TĀp"m\&}' *E;y͡'ӯ~1VW=e!: D*rI-wR qsjUjϮ>`;K_\춠cx$Gq#"':Ni׽l ]"=ݫN(qUhCv}BȄc1mjcEg:륞3f^S5vaS|e7 G!'\ 2?En[88«cz׾]!]`OW2ٵb9#_GYac?LM4{>"p?tv?fz1ş>~i.M+ p%hВ6=58rylt9]CC =ߺvB&})aV g}5>{c3;2GnmiCK E L:<1W_mO?6ꁙ)lZǟ<@TZCNhf ]Rxa.)w]-1]:eCR|vYGMؤSN ̘1{z 1 D/P6W&k`1wz#݃Dp*"j֠Ah | ES,,10pP,ᐆ2"$w]!ɂ 8""D"+ #:l A{|JUHerYm(پ)s|*[bA tP0/u{l~oܺyU˹7ʪz~~;CuBE;g ӯh_c ;QKfI:_({߼ͧ_t J'F^X{$|Xù˹U\vN ww <|L{xu",{3 ~x~ƚ"ﻫ=T(Xg&',}QЇVCG jm6lںy_{wЭ;Tąke"Bdn|\1 vp }D)Nf"L"fN%vPƬj"Z*>\Q63GvDTlZ~43FӇڵ*g,?sF6$@Y FցHEd*/Ċ2S@aQ!9y~N<9I>|J/}7TD@)Ɉ>E%D=x]A7$[+!gCVC $$RoݾQ8hΞWjO͜x|VM 7W^~<>ENfV];թyUjw|i2Aӹy@?f~ʂON_kX泃WJP%"=([.5..mկT5NӘ)LۖY8MN ),H<r̕tOm-vPL* T>'fv1 cI-Z,/_gnfXB&U)"Xw"WW{d]^aW_ '> /^FGBfk?wV3tJˎ_w __zZgRO\J"[TQypz6,D/ѡ^,=UkA[Dn=Q8ۑyu7=|I9r˩v7 ;^ .Z1{ ;}sN%@ "+YpFIJޱ2}ñlUEԜ_إ5QRW{ܺy=bn~y)iU}ʺS+_M?dD̝=_X2$:+tw]ԅ K W\ XE˺j!Fbz-L3}*E.nEGs5F*搈Zuׯhfi/mD h֌T{P3V0*uMioҩGsWt"ݏ1MysZk@|:63K,'>fJQ_;|lUQ ?#Dʨk: 9+!r|-CVC Ihoqt3Čz!5" (n 13W~y*wESjf~3GI~hTEiŇQIާc%Dr|ȝM;hy, L*[ \M_T*pcl2zQՊ`=f't]w2𮑫Nk.P|@D>5ñj^R(U{9fn.\' S-}Bj>_-/ldt?~TxnWݒ7#[T>d+"1oTeG^t޳sgOzkbRFmM* щ|pc9]MRząKQCvm"_YӋ;mfA~B=+b{2 'c'<(nHEةY97Է܏5SnaɈ3fw>ݢf~gUQ2뚦L]ƨ?]kիXCt_*oљ|*=֎fZw{x܌e_/~yØTC w'OV#:IYR14픧{!'fZʇ J/<2D׍6u0C+VhRhKϱ#29r˚(FuMSI휃UZtK|H+9aPEPB"N\iFjRR`&ٽX)+( cgآcQQɀ64 Ϥgn>luI TQV?'*<(˺i8!W^ڸ&V>luNk⠺NK+)! JI*wĽ-oc=uڛ5Q J.͍¥,z0q:`dPXn(E!۹Ǯh>V5M/Q IL\޴lMZ 7i`n#7D@b VnӘޏN]0}?q Լ+g޾qقY7[;xsUMifaWF=H$J`0`\qV& ͢daS/V]4FO ѲIsCcEIW?S(oTr7QxC;rϾCG?~Y&nR-Cmz`J[Qz T! >T5M ݸ2kٛh2|HI}#e]*f* g3sm=iDBh&JHCx]Z^^Su]&zq5&,[{'jJagMwχT.+R7S(oxb.[=c.M!w3|¬;RP=X-q,뚦?QEݶlM*!i|+W5YJP.,y# eI6wgx]g._H߹3 '+b:֏ޭˌ[G]ŦG_XvFulJՇ>IҴL'M=^A*^|m}[W7 QyzГR-Gw3>QOsﲯ욭urS R::r0uTCNd>&^?4;zQ1oSzG>A<6.>B"hr5oJtҹ/Є6F_\z j*Γ? k>E*d@;p3e#Nj/:Y3>:ez'$%߹E͈1 dՄ4Fu?OL&:gV{/$sdiU#0Zw4ި[ʫd{zT7}ㆦ<4,_7Vחa} &ahs. ݂]{m3SDl '{5&LuM%ߜt03*3ŤM?U58R3f|Y]̿ Us(QHVyhM^`Zk_%/mXB(3 \͖nM赥ǚJ3mZb,\@^{};8s{{9G \HA(sytt-$ZS(* 9Ghj& LrL%!{GdDHSD $LS!$i$6>Os$/жvl㖉DWZM!e М'eaupsgLH4f,shP!ηƠ΅"dM)d$~J.:LJA8ǦdOzT$NVk4A;le9ZWπp.w<]'PH]׾"rkj_&]ѐ]ǁRB׶gd{n=/=/ "ꓖd+=O@M,U8/ Άӡ.A$ʞ}G4o>w?Ţ13L|7'/>l$myt:.ŔDs}HeO=/f2ۼy7UJ<%̞kzrC"{"RyQZenEŐ7y1yҊ9G=d+Y}z^\+̋{|ʞ/L2=JfO=/VLh9e fMeJKeO=/ žx7{3=K=}ʋJ+_tm5=7K=X@1#o<3_$F;|'̋s(퍗<{N==/6?%퍶PIbd^ٳ8r¼$yq7*xH2aE[(̋$/ʊoIrH̋қ=ٳ'VrT^8󢬸D '%ҩuɞӅA6iىyp<yQVs} l5üX1{ӌ`7/tmBXpìE},xxD *M*3\aT2ԞX pmw+>q* 9߱H}Qm,zp2i 9s;T%4gW}=Ta,u{] 8iZF0Ȅwmg$x PY8mo'n1h*\Yd܅h)mbro#y5и( ?xAQ@ ("(Q*ꃷA}+EQBEs#p^ {vysE> }K3!6[3)`#2a,S-)C0f]N0qצV%CrN^kG6{pNOp8gɽ24ugߢysWFlmq^Gquߴd=VkAFa\VksuoG~&O`N0d1K~k9)ao`>pzQ#AAMD-r#w["]VD＋3HYׯ bZTz2Nν"(u lC2Ϝo"^vB2y|5bxmE {<-Nh>ր1/^PKQ[\>$$qC9o~$ܫA/Ж/ ٛ kgV0݃} _R I4.`[ V^sviNqQc: V 5}0 E.W*WA OH0j'ܟS `Grgq޺9'楬<~zU4ierS5`н?Q~ZیReJa29u ^Jᓟ3Eb:Vk%j CRۤqz 9{O=}p-i5PiI^ﲾh{}53SH4 hwm5]lLO4}M> ]q0gH A5u }`*ؐpNzkHp5rF~l`?Ku U+ۗ/`ZBviCԄԗ'mTuϔz|lK^ &GzPL$<ϑWRfoɱ=3NβH޷@X8$'eLsjZL߮QZaT\{X4`Scz i-`]I'$b%9T!D|SQfGs^u Ry8uL `!6<Bqx,_CJXi\0~{/jZtJE |0B(!iGINJ(JTh LKb™8dj>&)*yov{YpÒ{ʷַ\xr}}=L%雕]=n $سўUBoӟ8љ42/7 q8P]^eh{SF:q_t5~pb٤o[h$x<㌏Z{.tY1kLͬ >Ei{KDοC }t(hv[[һ\`l&%Lw/1Gdٌ\x iUA,-δFzԸ& l :1hS bÆ XnA~ ,i/qT)jɟ}?X%2ÚϣIN־'l<otƁݻwcºo_TH {49:)S|/pS0\e9K^.Q o/H rrki1,c-1m_!T,V1 Wfgjhhhjkkh 9lBxr.6P^?Q#** Jb dǫ=FI>.*P~ nOP-'i!J rqogр[i <111c@bƌ2e fϞ@F]\-3~۲Os 99Ò%KAG?Hmjdeew<߳i.&5Mĕ+W Faa!t ƍh /:2Mx xri#ŲUؼy8*}||sN$%%r\\\ DGGc¹s(t 2%x^(QtVmkkIG.]IΦ>@dG4) DKYEhҋN#q'M Xi>% . ""Zr%MZf 2,\N^#Hb{YZn݊:gҋ/FMM tI&.+qɞ=Zv-;www a`gg+++&:ki@8̦|jtz9f@dLG+,Xt(((qa+$$"`zYΑ#G'zH̙3qqq%|M/1 z޼ʟ2%`2:%ӨFIA󑓓RKQiQKBJUUU4hA|4ޕTrWnVTt"%ĿW6%`lܹ)]z3bף;F %u,_m5xm4 ^A{!~4^ _DD)-Ls Xjucl'vTZZ G6aZ `c= `JyLuEl !* Jq)m6$G1OwM LZ1QȼN\28{rD^`jMlKV_)`Zڳgi i.ZG= D %ZeĈ&jMR~<f.4c|ͫ3ƊMzg"[\w`E @3f.7PrDb65];W;/hs(澜8ҭ[Z\/}G"Xs`Qaaa|j%LEG\?prpSEEE:1A7zۧ FvOceuQZ+6|$z,z!2/`nqvn+OI yo@۹y5g i=QOJ<ܘ=퇪#??+i\3fxi(Lմ3?kk@;~KR/&#=}L[­A(FUī!"oNsEަwB%g?v dy"̺}qc9:}O -EAO$>-Ybt_w7 k3d=62:tXUT,⁁rpO "".zq;O@N6Tp|pI'ۢEsUVa ՙm.p {El1"΂Dн7IuK1jZ-oGf{ϽtCps'P-]➂@'ΖEOG >]vP䈣/},˖-ËBBJkO텛3&ʀVrVė%Ta]f7OP,7`/$Nlq1qӃ-Lݻsu /XJgl{SE9ѿM no@eh\ <$ډgfk%IwEJXEBɎިߧyw25F]1Ñj|ZM*$P#7A1(ye97È5iEA#Mک ',ċ{ʁm N`^QGvƞN 'hss܉87cv/_&CQ{9Yr{6(-/VU8L,ݔċ4^E=dx$ȎŞ6Ş|%/~FIxx1y9ƞZ{ mx/ZA=KؓYOřtK9cO6`Vċw%=Ha[psƋbx|Ed6bϺ]$^(^AСg'ŋ=HVس:ƞ,ŋiji!YS{/F0/3M6޶g'$^tW/:tϠ'=PX{!^/VPǞƞ"j{ַEYċN:d6#Ş/GH8AI}/'jϙĿH~=֚xС{M\){*$:ĒcS.^L9gcx35=;E VcK\/Fvċ$sg)SIENDB`bayestestR/man/figures/unnamed-chunk-14-1.png0000644000176200001440000015721215174322463020460 0ustar liggesusersPNG  IHDR `oԒQIDATxڭJCaaV1lZl`{&‚VX2WԠے g`x x"I"I3$ 8@ "3$ 8@ "3T{j6j浛a/NG;I1NU^] !#Nίl?N8=>~'6Zϟ(H|=6fK!O(,y<8;֤ldÖvI9QeJϜ0AN AI"?rCȏi;[ }_8^}o$ 5+vWWUe|& l Vzr?'-./+NuώԺCK  ?X)7D|rI֩!#3=w9ۺ|К7Ӝ iD{S ?j|G$"XEZkB&?=c|8Os GRĩy>v_+|l-=/{7.%xD!8R߱|ܰ}e쌽q{Xؿ'6ZJBPW@8.W;͂e)$ce>SItP& p?I]vA): H JRC^2TL5#L)LS5ǔhEQ32Rxw{{rณ3wc~@ R~o"E=ϼ)nK澳BQԣL^Dkw&W^-3P y[BQҡ-QUU* %T2W~uMq(J6ڰ3wb7(w1ߏi%3oXfK܆9#ҡ$5'sq;mZxRM_.:aȬr1P"]L+Pމ)Vs6dM+ EQgb DڛN%z%ׯ;BII v[c˧Q/mɯjضFF^)ǏV__* ^\:s 'Ov+d8E5աMQMMMJL&>MM R^r␡]|I}re?:P(-t:6USۦs92eJVVZ+~~|y_ġ$J970:&]SBCsl>$QʚD*Sܸ' >ZDϘsuHEBI6l6H٣{(ԩSȑ#𡊩4+9(lU}snxk^q޾ɭiK. %cJ}}} q2cƌ[ihh D*K'7 'LMx7W_5*?wKm7$BQkߍ"P"?]1fD~ݹ1MwOonoRu(:"P"~O%CIweؐ;OIf-F%@ʜ@Bl{'BQ/dNI} H;;?n1P1{MA N R.:4鏾6->g=ugn o_[#'(-n5!ޯ.D6!D=`T_Lk8LMDu^wԜvߝw"l6 7[GrI t_qnc/:rT/Tc_zY`}afl;FO:{4"P"]ݶ2"L6VT>:Jt,h=L: "t%}nD 2Vػw 7 .h. G#`=$l_Db^z-#&nl@ Eܺ")t D  eN(@}D P\xșL PYlԱpB PSԼ@83MSD@ n@q#@ 3a)@ $ L a@V]׽v@52<۷@YWzh/1|d%w0$t0#q0 $#n0#d"k0&,!h DrPXV D@#1.D'_02\!MZ35\!Kp@L  g"8Ǚi VD(F>ٹCㆡ  u!CZ  S)*D\(803F&D&;+8F 3cu2<ݭyk G~ Pv" A}f @@v' lAL  5a8R DD@q{$1"y"‚< @δwgdYζm sD  &HeVbD3̸di x"-@    OP@@((N P@  D@q P@@c8@q#p'عcۆ g@`ͮ6G XsaH(;L ?ۇ@ a@Z飲m[/ܘD@Zr?<8S7\ ]D%@r % 028D@]@p ~L|" DL~HI @H "@@bP@H!M --] o8>}10z N f"<q :#c.h">:pv& D 7#=@I"bqJ l"@ 6 Ea CZ"p-DVF]hiT*\BY3*P!<@f%#R{Z)4tK !zx]e[ "C"L,xD`TM<&hfhx@  -Q8pO @pDI @p M;Mp@r8^ 4DZ % / ?+ $duwx<.| 첏- #!@ @A w1[(2)wvG^D6@Pk Tȳ@ @( @ ς@J@ X%*qf{bPJ @ j8"D 3]=m@%g R@j@ @ȁp Dٲ [v"D|2p2@p-8*@r)1MS@Ȟ@ @ikr`w\ٻw l5K=mT@QF),9,?d& %@ T@q@@ @; DZ+"D P9'@`*}[)@  WX%@ T  "N3+G3ȮmB4v/,n8= asDH @rqDF -HN 騵@X9I"!-|*UcRu?q@;q (t%wbI, c0`\"2D?wD/V @ @ =w0 C8_~G+{ "2PS'(N P@8Xl"5"AL P@C1/@*@q@qH$yum Jm(!'(N xKy3@,`vi@??O  H"(N XTN @8@q 2D@6@`M(΂7\l9%ۊ݂3@e(WGv`a9=' @+N S@K*q@eY+7Y|DtA xl@K4]*8S{("@@~pppN N X 'tc""  ""1F@""Ы;{wh0`@@ 5Rq&e0(P6R?{oCݹP@P$'HN %P@Ж$'HN P@P$'axۙ9@ k1" D@%C @Ih|>N[;E ")D$'< " D@@ @m"~" 9@rHf?hkYmh@Zۙ)@ @ Q N -u]s<6?vH)^~ "/{wS1FatԱ5Ẕ]@E]I(9gf.D2Du@"" ~`P1@8@8d1J N N A:#* D D DLm>nX :%@y6u- @ 1P@8i K0z/O~@ @rٗ9g @e "dp!N"D@"c 8\"neY D I4frvDdU"OAU4L-'}UA0Z/-"AĬAAvwp{~3 @ ^EeAn<,0?k\@ k2 @ m)xlx08zO_eL8^]04Mq2H1+w~y5O7KFlP_FK/5 o)@{[e}pzUƥP a!q2`Eq1eE`6MWaa e5MRlbaYϩ0'w$?ϛ}?"iN{Sl}/ M(q0: 3&V %КD%^_n,BS._&v؅6yy,p.g@&iEʞϔB3{5VR~WV@UQh>UEU!.(DZp۴etd  bdt6.Yfعsg_Hz=kZ)TYPXZ)} B ‡ CXj}m@z5(<^8hJ[o3 ÆIS* zZ{DW]:%wkivA%ccVT#QZ6ub=zW^ 9}gXЈ6)!ؖK٬\q'O@ݨۧ M q{+Y#q:tvxDhQRvd)**dZ6^.O QYY@Z6^T^^XR"<Z6W]|4pF#uI5heh"$T̸{|p&%9UZ׏M B\rĉSB\KhS'߭?',Yh"mHE\٫NXNI1}B͛iT0w']{:%%9^JrײW]ODO3nC-BB͉C6|XJ]~_N bro\׈}ᑻ' ޱsϾڱKU\C_uǣY8yZv  @1 Y]3zE%SNTFQH]6pO6m-''gM"4:ym [WN(볷ys&OJ4e^~L?Kjov D("D"ofD!˲J9@ =9Z)DUU_D mGeze i8%{wl0 a$0u&H*@QRd W}~@ 3[@u;]-D$'sl"$'sr"PeYn}"<ϗ¶mh"Pqa59?W}A7/@r @C"` @ @r0j @ 93 9n@ PX5@ N7 Q…@ʈ鄀HB:HP/.3JMRyFs@lu4'B"MDL8 G<ޥ|L<h"""`_ C ''k=@8@8, @h@&''S=8@c8Ӳ,۶D ɺ_DF p"D DL<LT3Opoh""`_pЏ@ @ @LD D D@K;Љ@ @_жa "fKf٢Kt {o  +)*9w%C"%Sl>xo?{b#D̬=szA*7" .s([uݘfF`10R̙f]+1 eT 8W7q(s-aήKszI/$G[oΗoZik<5|rQ4iYvTtGh# "@l"IJtI#;0-{kI@D^&F9~ hoȂ,ͼlF&}\* 9wvơ(3n՟Z3-\E'NO555ƍg͚!8qnl]UzE3WGyezQi+\{L2xb8UVV>ޗ$%1 \r 7.cK*ZQOyb&So_lQ R!7ҳW|*rjOqR>6l$u [ߛ,s=r<x+룤$@R"mreik+g%sʒʟU;༗'f.DK/Hh>q2.ǛA`d D۲lp D^Эm݋gL?c..pkCR'OLи8X(*\# 0ᆣDc~`A&0yGT0JDyW>!< C-=玚OnKo?< OoeNW-[WnEm~3"I3'f7# %SJ޻Y3\Ʉ(,g:z͝;w̘1yp*UUUK +@ ,g@<n+#=e~QZػV8A&ERg$X NR 2H2"\9W>˻ "t\nL& 1$I} ({g?v^.~B_:y#LPp$""$/f꜂PDG[)=ߞo-/.o]?UB-/w'Px3=>1uXûTCKkxrnf- |CG: BC\x:R+蕝 8=wS̨z2!ZtMAExE ^EA z z\js9 ,ԅjͩS9M ^/wܝi7-jU0D_Y(IpDɶ,?ջ8kw7Վ|mLn{ﾳ+Hcu I ozsWSMITܱ "e YA 1XcyۚZ^pݬI Vy^Dطwp͓&Q*z{OQJͺJAܞG)7jkmd9O Ftʜֵ}u>j[^ٜ6ziTAK˟iUe3Lb$`ִX" EEԍEeʊ" #hʅȂƲomfmh:n3sѱ[n]}s_8HPHSc$I{kCX/)5I'o7NWLߞnd՟Mo#NGjZ "$k Dq+;jx?~KU-">ݚ "$k, Dt/]qhY[Tvx~ܶ8,T<Ԓ"u$k;dʏ}mڸaݓ،܁g>CzbkO썦W@墔8ko؃;I*zy ș=آSoy믯 Y,~WKk%g>q /5ץ)2.@E [f lIlD=R.43`1* <@566/2o޼~ Ϧ<3;cjiXinnʣZy4vJՀ%iе8DV7伺WZn`t@jfP$Ce4:%z6'1uL :tEo`KKaEC]\TSX#GBlRlPQm?6\yvq#'z{M`l\16ym!qC@$mY֒FslUY1Df"^{6<$t@q+X+]xqt@$9-DZfΪ:YDk/?m5i萙H$}=IDo<0@di Qy¨'.앋t]ۖ_T@"91ZMckjh^@Wg dg 7?~s}*b#/wXs{sN{g}ee 6JKcݩO\;)+R!GBlX)IRW T.9sV8l6*+f&Ef̘` v)Ҩ:yy~p 1'ݻK`OI|{vUJv(޵'CƐlkyo"֧(lx^L +Im_r{'±ӁHtA{T gxTwO/ l΋'O!k{6Tl`3"ӝ-5Ű`g.jxڑaҊ0/Nu=Ӽ"@/sݽKay4LEKnKTbD aK RSA BDDTXXqzqj B M#y'JJχp/?˃2)}YHbQZh?r#k#Wh9[4q$$;ώeTEXlN$O"vtƒ6D41@R"tiCSK4+$~wAVusβ , P.wLFhaf'1s̬"B5=Y%Yj!b r۲(+wLzs<<}76[ogҥʖC(HadžM1Rn\ү_ExSUV(ʁH:fd:_xnYG܊_X 2G  c 7~p:?w/^-箧Br|8>~ 9c܍W\衸~?\5w$&w$P dߏi[wNq} ;[.u?;Bd?3ct͞=RP[[{BC(C@ DB%nyw6|s}O}eKk ۋs1ī\C$3}BU(@{PnCRHl:%;jAIW:d귞hEJ̙3CJIe!YO~I蹤_ʹ-ZoRb Ds8I DҒ=+ջm7&=؆ 3>: [fzvZW?s _9qIر$?sG^pHrA]aQ[$GDҒ {KI3.w?xk+/Yz 64V=lc&Tw~@1^D$I.p8 @$n}G߹Μ~1:'M>cN~Vŗ_yokl+> wo~{ςVo^tȃYg{'?2_`WiGo<$J2,\)]3g y"@9YlSyZZZ"JIz+$_6IY-)M"@khhy.\LS7I ?^IоK:ₛҜa$O1hAkǏ;܆g~vc.#cV?pф$l/ILqsx%6wikgk|cu_ÛHqA(s.P ?ْ$~񊙶%sNNC$sw:6~$I7W#%@(s"|&IR"ġidG|7bjvڨ$tKMkb 9s朑_P a$Ilzs3y됚o^-mK9&Hfn(GMb `DrkMH~%O\Q_:ksRa e0IT\PL\7?nKfgA /n!vJ??hK ]u_rG> +B bs.tɎ?g2N=uB6tm|q@ySl׺WI!Sje:yHU^7ʖ%"qsdFɆ>U1LWmj=; m1tI >T .-SҰ[d"H9E+i_ݱjSawtVA" 8 C\D7 DqH@88H@`@3DA)iĀpKhw&? D' > D@hzI2@p+vkF*FOtl) @h1@לZP/f98P>Yo-/`\`B-T:̤H "H @pv)"DCP.$3@i D'= "$yt:sA@RndY_1 "L<9j5@ J4‚֧o?y K(^<~ʽW&GBHD7{vGO_rw@J__?ZtS/jȾmo<(:($ahZӘ4NfXX*YV4JըWYc#yhǠ"<fppM}2>H_+"T)-ؾw;6 ֤:io[f;O*FDDD&Ts]3s̠B"ְCxo~œ'1"""7̢$?{Wo?!2P0is3 D?aΓPfS^w HOCp󺂯c sÈDlٰvOC~S~޳./~562"Ξѕ筛=7 KrN3@ȧ3D*f~@Zzщ/d <ׄN_+ʏ`)j @"""_ L;)/ڿzvgEIqo7*?<*"#9Ϸ]d ,s^ˆDɜ1vm8d-C]ck*/OLlD߈Jὁ3`Yn&Ù+ܱg5 HSGKf D D|#O((-۴u] dPd^o])ۿ2cdCQAR\AOD\E9sLl 7 DBpDnGulٰ6iU@@';΂vmfm#!ih\* w,߿}EJn.?ƅC[.;i{$u'p@lVVEICPAr"ҨBg0"""b n"%ۖLcv!6=\Zt7]C5Qp!ROλ纷b,i]joVW{L?a09#FhY֭[[y#"""6"h b\>oGw;=obgp]<1NJ,aK͜0"""b "??$jֆe9Nu\;olv#fj2Ndtsxg \>1)gilyb@\~5XEZ<|r纷pp. /!A !,1z\`^!ci!<*+!C뢹&Yŭ#- b:7SDՓ«o+]GuflipDFk.QxS;i2~?+h  &ln6—ph"n+NITl R]S Mw8,w aP0$Fd\}z0f8[dKVEtF#jZZ Z(V3S)v7g_EjmlyfRގcj޿ݛ<ؓR:prp_J'cÛXٽ)7=\}3R+mmm`Evnb )O8q?;?qq4w**^O3EOVtݶᦧW\ G<:R^FGe ! ƻO[nzH*W?/ٻ{(8.ENҡ:*iph76Ɔ%n!]\Cwp_NQGE׻{|A};?/߂s@--~NFے_WiS2:?޿VvdWKַ,$C(n}%΍Z 2fi_Tq]be8hq͖ {c)n]|~e+eb۔ n7$աy++}l8p8nX,&A r=C2Mji-MҒѮ9[:}JD$i8p'ERWkjnhΐ߆ٔjOa(Bxr*nބ[k* [D:'L }1ثfll16!{i)N![_QK^zlwo=q߿o TRr>.J!)'pA.aJ)I)E.ܸt JƮB) ~۾شx>7$ZfԴT^:1IvUSrYٌqA\6^ ]т}G7K""-4\ɟz1n~vO)Y?)kCs0hx`p_e&m?}jM6K[*^~5"ښ8\Q𷪪uZQ5GD vְ[V7v ud5}Bo_ [&.v9% 5B>7";e[ֽoNVeeetQ[[I4 Уd *. ~wQDanL6[I0baEFmD36ZmJ I "* a407ь&C貓>ow.`{eʡ]ji]ϾkNۦ:Rot@DP(: .Cݡڥܭ'7OfNg_P_%)*q l5)r.` @w. Pp "$I(@2F8t \C>,6Z@ "͇W퐃WjX1V n(v ? =&T~! W-I!WQ8S`+H7(rD NAMН\D NAʡ]ji]ϾkNۦ:Ro \DP(:\ ʡ]z2.~|Toth|E̎ZB( q@&+""""?3ZF'JA4???$IDr6?~O,.;s' x% l߽>j~T>rzW.>O%@M3_P i}{7uұRh]{3 S 'q M$YXYYI݅V]qmnkA vʊڃ^,B(.0D(B"u("&bTWn=x!Hf)npnm;=k;^o?rI" [r1G,ob b "I D%28ں$_x6>eú{k1Si~F̬C$ID"v6unc ӌ9{^ce S%+w)"03Id ,=\ by=~h S&+"R* D`f"$@XC&XyH:k#2Nϭ}hJI0XH$%a! }wBklll#}@M E%au;~b.Rۮ50G5^lP47Q,HcaBmM0e'ah.'D^gE. |i0 E;Ve¼dn& E e1ʪ)fq,H"I}C} g yB(P"p.,Hvu˓0.:r0/CG0q*-e?.ƍ a mg¸XqˆbW^^WC/wxPxBi|G 0x?.S,OBQ̬lyg$7+oozvo!D<7;ZeqtLs"nAĠRJwQYQf)iuQE ĄG1-V9B.rZTPTF1Ml wٯxy6"|fP4J$-lB,ab~ӖW=ž#fsG~kD SRKokھ C~A$?e|kj$]Yuoc۶x]:;vokx}צtuYC* "<p>D$ R2ֽ:\TIUMmi`,R Dy@YHR (OP>촓*AccK3d2pZ) %ˬXY$+2uI̿i\we?9Wgw|^|jÔ<T "aQ'nͣ"|jOwTy葦|K9m63'.lW\_&ţo/UK6)]YjݼBOJn͢_vӊ*%F֖{Zeq 0$I Dھ^6, $#/`k-[OY^tMǼ""` "I2d4#;vLJczDq+dXHlݫ6a95EP?t0Q;(CA'RA\ (El&9‰1C8LVI{ra$KK+Y-k^sob#R~giLŧa}8_;7[yGD߮b$k]c3Y&D~p69OSP~);ux-&R;vHTlom@5 "ɞg['1q>3T 66([_cB67>T;t`-0TDHXVvc"gOw2&ٓYPH]pVwusK`"`2hfbצ P`nꄦIYL?7e2٤9NhC,j,Z4E0m"{2k?>/<'t[a#?ydMg!iy@$qwo<爤8x)|q>tK~=녰Cvwtpy;\-}3(?ֹcw%w hjj %ZZZ"]s$I@SxУKk <ж/~iGeKϧ<$E D*ں͛#HT% D:W쑃zKN아=ܑF)f̼_?=sƴ)M}#s{=Z7x̖C@r&M %#XHLE DM﫤בEd>"@3@D$UE #N"k^}(@$i42>1 #FP_~Ǫ\xԞwK @w|(@e @ _]c @:ض` P| T@$o>OnO<ؾ kj?طqCO~ֹ㯺qX-*+BPhk}n5pPIayg>IP%]1N$ˬc_4w)=ͯuFR@C$IR D.˃jCI^-&"` "I+PȄ)}r_=>>rܤn~O1=wLrQSq^=;neR.kWLmx sG環GvOl(DR "IT]K/fsa$7`]7t.xc?g$ԜrsͤH [z"8i!c޳4%1yÀkN$ D@D$U]@eB9l_ P7Vn5PTXS 3>tS&A犅އd^zå32'^? PN:ĢE+#-U:CQr9#Ϩ=lHvU"T+W\b˖-*r lCQ =T;``l(v8|"!Ʉ]:::BOŎvf3d %24' -;"BQQ},DHvȰ!Pz =ߜTs~$w‰'TYfQ3 +[=ˡ? ;%qmo:6 ;NH455---xWs$IP.PS/wR.Kf]G[C7x[Wr'1tI,UG7$af>j[삭Lڒ gꌤD!$z%rIڴdcSo\o~x͹C=uEHZ$IS5M~O={1M 5SoM_-I0$IUc"} =x?"b ٻ*紤)+:abMvC-wdؔNŒ8;P‹^q1 \3gX! :/ j vbtFс/^hss>|/\c"IJ: R?=sZށ[go@hM RВs?fMO%8Itmxa[;Sý'شɆ{7ei]o\T[5}ƃ^5We$IR_H$وT ]wq=?j?(T(Ï6x`Kc{`Z`j DbپFӧNvB DʫTQ/} oiii:Nwww)9)]RNˆ4 ۷6NGGGh)9 eWؼщP[vp ֱB DBghǦ%-ܳvYñ@ DBvŗiꚋS!?{G_8A U,m\?iIx[ڕlyr/[o;v//MJgHqd2al6Jɾ}+ˆ IR ȏ W7j.O»^/R D@D$@<F|wmm} pa0T(EO<3'ZTS@ExOe20N6PZ*$IJ= \1P D&2e Y 6Ñnܵ_hzs(P(!_z_~Gvonxc 1IE՜,_v53|IY b }ϪHDiv DJ[& d%B$Ic vËZ '7,tk{o oR!⩃w|&#{U{^Ĺ_$"o@ cfܰl wmXr 5/*K˜8D|dCȵ;Ď;űm}]wue*7|Y{'bxЫ_YxA$vt&%74t:dL6hzhAUg>P(U>oLHMGbT^֯I-=gŶ0# uOͭ'Pg8K^l%/"N; @\WgˆCu?>/;T&OT.Y_e20N6PjZ*$I4Q {0?.dzUFaQ∣?f&dkd$"$E&'H 9Aj-,EjaaA]bbv@e3wW{4LWxYT[ @,yta/02@"DX: B @@]Τa|@x ;Uv~9[œ_7M$́tC"^Өc}qw~x1M7wKfY6_d2]X,@`#E_]^v^:Һ [K m7JA@s_}ztmW9D@w "p"]!p MF, 2h@@ D=Hq "pd\DMFt}V@T {vضa  18su9` l % 4^Y@ Ē(D WZ3MSn\"džx@ @ г^ @Mp8@ P@ @Ks,N2T#U Dc]ξ "8ye J @".Dاr@Fmgvku 04T@T @h^X"P@ @ D D6 Q\ كp .ékpR 愪Hvg~HN D9@ p&mo LuiO" /U Du $'ykL^@?_w.<S<@ P@ 9X@r"deJ" D$'HN @aVfA @zZ壱{@@wP#"d'ql j pA}@!@ 2@r"epD"pcm("#dRQ`O1<)<%%R,$ 3{@ 9@ 9 9x 9@rRu/+8W}2s@@ liOCv/MwD?@r4!@2@r"@]e0"@" De:" Ḋ`DR"i>Ve @&m>  /5^f@ P@|P@t>Wc7 ;t`;ODgFD@ P@;4(b BulfGdı$Nw0%/3- D D|C"epp @ @Hf>@ ^8x"py?6u-`'#"t''2Tq޿~ @ p'@ `>@ Ue""@2ˆ- D DC"P^fhH N /FDhF N GmcY|1 dn4D༼{n QJq]tDG"w7S.lCHƈX o"D D%^fM @ǿ Q@Pb3"@ϋa绻٬dKj3)E+䤥jlm('.R8h8:ȏ"2i*2'-vgayzߞ{$CD e BҤX,2DP:2#"4Q@A#}_=5ۼne03tfd2:R$];cm_J7c#jlxQ=]#wkФT*EGIO{EDDDDZ`XI[soN~aXN\ؿmGS-P̓HgvCI='.)=܁-Iը>8jlv͋w,Wfh#}i^+Of3on y%{wU߅ߟMHhM@ Rm)sֶڍzt*x~Nu+CtԮUsxV \;[V7b~cʗ&PJvܨi!!q?~0ݷ||lw+f6qŌ$I2` R,:{#}-Mx_\;š:ȟMHz?vq DI$و02bH?][RzMjZNQ~Govbc_iahr/i<C̹sl#Hq'd 5d$}Ʌȉo}%!67fC^fLaP#vyy+e\5; {ҷ'[lގg:PWΆnieIFܳudܢ/( I&,sd͆8LJbkohɅ̬7) TuO; cv͆!ػg_3Pk?~[f(N" {pl葙03G?6olʼٙcu[\)獟4ui ]?wVKdkCӐ\p#mq ]u4Cx~C-%sdrIN')|/ԵA[jU=gV&I$qH1ȵƐW$ oaO~ y][}x^~5W,m"` R :;c@, 3 Z1眐X{Cv?zdߏ>t˦IB^ЦlsP"W! p1+jks +oߺ\0r1o\d'QNIC^ѿ^SD^M6}"Q<1 qi1cͷe{_^tZ&"ο/7.|k6Ʌ3`۶m}}455` 2%c+ɶ '#pgO~p禬c,nlo6p7n|˗/e.=iȋmG0Gs!/IƝ?. g]ZEw!0LܪL{iK0 >/錷ɦ0dyӐݷgog_vË1̝?$ Ƨ ~}֭{.(Y)}[Zҋ?îدW6_w~̛nω4%c|<.555(pHA_1) g}}u1 "8AD$IrÞHp6lXΝ;[f0@(P` ٻc( ÷pQ܃Eނ؁҄`,(LwJ۶Q!`Dju`A|`M @(O  CD#"D@i @ ,̇@ @ D("D`g}ߟWaṫ6D q+4D#"l |A4> _f. "|@U" @/Y@ P'`>1"@B|bD@m"HLjD!"ٻc( Wx+C`8shQ c+$ !/~uiX5I>v6Ʋ,".!P"!"p?6 oz%pWP@r"|p$g ȇ$g 5x(@H@@H@*(@H@@H@(@4 0HN @LD@Keadu4M?⛉"}`"P@P$'n pMܟ/CpLD!F4@r>0(B @LD$'CR" DDԢ(H $'qX>XD}@b"@`T&v M<هkvs!DMDy>;i(|E Ԭ9<H)< w%tR'Q9 D ,@" D & LD&!DD $@" D  * D=u]>Dn̺"@ LD.%CriD.#VO _!@X]zJls!D%D &}P":P"}F}P6@@(@ D $@F  Y%@"53M}P @@(`ĦHI mi&|w&@`AD0,Al@{Y,ڱ-CLLA8E~۝yo`ۚvz|PA\ "P:£H|PT*҈D@CDu 5#"|F@ Ce@>C4""0BmNN_n{z DB4""0hY`D@ Yߜ5G'N5 "O7@N@O @|":@#@#" D uF`)$` =uk DD`6·}>Mg=?1JQQ,$MJArU[7`)M!*:ի2a`|](:u;^=$4""0<@fD@XB#A Sr}x3>wo g2j&I8"r 4#"Pħ'u@4"@" D|@u~3@:5 2CXˆ@:CЈD_!Gf?f(mm7 CЈD@F@ 4"@pP:@!ݣTa>0,@&UN݂pff.@@L TDPҨzeT D!hD"@#'Y!;n S҈D`uȓY0F@ C!hDJ`)/meiֽ9gfffffyP-DR:@\!$$ u9 D4"@pp>@!hD"ħ@#$' 8uC(Cx:W4"@nR@bxmP/GDM]C'+[/ Uӈ_ u1iD"B`CF@!K]ן@`<:i mv/}ߺ76̆ `\n wDy1j>$u!hD D@@PFxd~V! 0ʟX Xȕ؟P܎[P62EDNc`1̜\ƷCE#|!uhD" "A ҈" .F Bӈ) Dȝ:4"@CȅFLÅz'O@4"@dRFh#u҈r w@ @l!K3&hD`Hʲ\7FpU)33333xgCQ"|O}hD0u  ,iIDwbRF DH@h!DE+qC@#$ vЏ@Ɠ6"2@ 7!FЋ:dTݟm;M"4:䗎/wN]<$ЈF\; Q@ # a @Ј!ckvmq\0p UQCY4 L5io<+{wPqA Gm Q۩Ŵ:":QQ@:N@4"O :hD @ߤ!h@0@D0#2G#a"8:2!@4"A oe S"@ !S"P8@#[}z]L^ff|7Dp8}׃fQ8%Dp8pJpDDs8Ј@@.i!ߜ^6svtRN|7lv^ŭ1f˩<c1cL@CD @ gd"H B!@Dp DpJ '( )&(] W+L P+gvJ Pk`'@@ٶɛ؎@Kl0`+@l3`-)?_FZV`Re6lfZ+(/@v( - m,m܄bJ\{s]`c)0!dFoa6q_3@@Zr $  ~ߨ?H'[=d2/?bL D’<40KO@ ,i@K@Hrf {"az 43@^pM@L ha 0(@; 2%"2m7}~(0fpͮzy D0OǛ3(rQ` [^|胺Mb7"Eg |@"@JJdb d@J"@Nf  "@@ӱ9 ,E@q@N"yfs D_J"#v ; a!EM25 aaA"YY f \ p6P,llPJ,ԐKMhҘ9y?; 69 }2I3P8їw;|I3 D `, r, s*@Ȏ Fetn~# @5$УK}-VZ ApSg tɍ#F @xAd't?@$Z>94;51>X\kn^=g ~xgA ?Yzb AE5D TKBpD- 44w% +:Z j ]\̲H 4>;G[T0"#zxRu ~x7<2>iwuˣB2=s/%z^W jv>||5UaV~7qb^vVHVH$IT`LE=wtB7_8. Tol=srO}*ţ7^qMlڅ*3oypczsL)̗M{ip (D(ƎQXPͶoL?}UGPQݱKa![$"0(pl)ZܜݛZkk B(.E8J={=χv/n}X)rW!*צn|[zs#JQq> %DJS+ߘC _yrٯkiGx P,z@Y<?.Uk8ْP,Uw Dk'G!FO]5IcE<,LG/ Ѷ<7sV޻dzQ̼$vD.-!|F/IKգ͵ggvo=>v(D; ן}2 @.qr,~k7!QEa9w&G-q%@0[ SТ.ZpQD?F )i*a"2&&Ÿ=( s}{V,l p12aj[yѺ"r-5߶%JlMi*"'"{IH2ؕ}n9m+@NZ)k}7%u▶kT@@nY*(*{ #϶L/SBDŚ|Reytwfdd?HLpK&s+ʔ"pDkoQf54{z;'v(1Ϩ>hv0▂@@N_yU&!~9Z[s 0N Yp$?^_  8Iuv\(@j;ZᦍHS滓^ԏOj}@eNFޑyy…r6fc;)I9I(ӑ*YĚ3Zcރ*8?9{IvcnDj0hrѶVGh3Uj8FZmG2h bGk[r (ZD`wK2 MB,~?̳_(" dD<56ĥmٟ,U9;_^|nja%~%IDUP2_zp9y/:?7ҙg % D_ޕbYK>Y5gk /}wx8e" @E@;^ Ynf?5qW̓NDm;/ 氅oteU!%.5u_Y[NDvò(;tZ^,N\di[DNͼ" T#b^_ꈈׯnn\}y)"־Ox*r&[ƩϽ ysmo]ɨ۷VJ/{I2p#z?-FiՃO,0P vC玸|gM;TI'Twl^Q%kNݼ~W)L6/AOݴi[7z5G:x '$E ;,9f/?i宸KZ~L=Uqʍkufu9˪\1rO3ufnlK}u N3bbIIl̬MwIB͎>6v+ˍfr3Ggp vv-.”̌SN*qulrUWŐ|JG>in&5Z9Ԕ̊ {nύ]ص- ~1ZT+UH< p4}ҽ1IvG$irr$Iێ2Mmc$iǶ((kov-*+Z 3h.|FeΘx;`$)kגnoOWPAn*#)Ijz7* O%rqQPpXI}k޸Ң“kb'GP8udc#h$}0TtuE6N,6xM~8dhj$*_8^qZT{ܠO! p%#dCT%.mknђY>G\WT\I7r*,-񩮮ml-.UTRDdPqjo̒l:5uk#"FIyoqўXn# wV?Uo;N8 ohy|%.ػ7[YKW}'/U:jKӸ*( )րGXʿ/n}TgZuu[pwodt#Sӥ3~ֽ|rNPQ6U 'oC quHf] Df a#%_!5ڏlqCG x1a%xmMm<F#y6@!WF{v~;doeNǍ=2T*Mq;jzhc?vrU<'0vY~q9T%z~'$~wf# I0GLrQl#+ff?~a;:2eVV\1CMqe׾ت3Ru4W{ǧ&Yh;>oė5ֱ0\1.Fy՜sJDܟǥ;WzI|aK&eIsLL9_yZc{i2 8{KEAI!t`I/'fQ :`8mD0lYjY`܁XF %EdZTJ(;H,M=wm?>u n [Iw"J@)k$u*eZ]+ "DDDD#%T^$@}cL 3&)u"?sukXs˫(-(irT &:O K%+e?;lۣiFeH] uK ZQAXO>{'(Y0!"""J bv e~"Z`n; ȋj6!NpѠ3o@^zacB j !p}U _&!\> DDRJAӁLB-Ss+߷Yulq|+5Jc/""""""@(vjt ݱy_]--y^w2YK¥2w7/qzd,Yl\޽4qy#!۠(HL;FR(Q#D-J I, Hd VIENOhl0.m޼# j:Nf @ImWJRc;j1ܶ ~zCѺ{c>%[ZKNQ$V Ȥ̳T(j@kO,_#̈[q7bkRӎSIK 4/ t)SMN~}X%ɘ̶9xDq}gK^N-7|(?7oU,?M){r_ɶM{՞|n @xP#/gβN8= D)G D~k2Gs 0' "s 0' "s 0' "s 0' "s 0' "s 0' "s 0' "s 0' "s v 0_q0' "s 0' "s 0' "s 0' "s 0' "s 0' "s 0' "s 0' "s 0' "k Qq߻L)E,,$h2HHB*M)ZjZ4*kfX64F) Iuuq.7x,7~"N qD@Vѫŋ6Tm۱ʍBXqfVƳk[=su΢]<_ɹ͙'ǫ/RZ?KoZx㏿5BжJH젷Zuʚߗb <P&Rط4"\s[T I]$kioʪeXOS|HPFRX1av @ ǖٿr S!k!ZCz *"̼vlNjဒss&?;MB^ժת2''tǙE8֩z[nAyv)vkQ'?$yXw|z]yaXV>aM:5~nڑ&Q&_;!ׯW-N~Se8uO)rd\r$ V0>rҖx=-g(a s녅}LrVڶo4wP/%i,Hr@??:VK 4σ]_ľ;+v5z0|V/_f^R`]OۍM9u[5+֠ޒ;?zZJh( Xr>*@[ҺO9eëҶzc6ܰoJK4@-.&ح-d~[/̼/%P./%?or.<72Snd+Jt7O~<:K'sUGUrO9{sTQZ76`p{;(/-?rè 7y *7.H%/8|LT~d($)vٲ{߁C#ו=8~bF۬S@鿵{[rԉ=BeIImFW/")Tuƛ.;v_NNܨ Q&2O/wv 4"rHPICSC0JvAf.W_/l=HA^ J}脕ӟjwoPt,̔;ꛎ}g9tǵ^؀F[nQ>ꋊ([ڦZ Gc֥px$-0KU*LxTM~uņ+ɏK~_&Ú x0q`Tiu3OC@ Y4K2$ (%IS>=Tп﫹9.BW\i:O I M[Vtz?).=TMI3!%ƄJw\7S4<1\1]೓.j;zܕV'2e(_*f-* "L?y5Ek K_3RkkR%S[QIMZg3&!˦/rUJ@@zm% =_{l+QEQ*[%l:\#~w([u˃CRb+5!/%I5XCRS՘)p3?UQD4:,JRxJRzp1]^% 5oWTQ 4 (TO/nA$>u GRL?T?dDqnT7CtpF(V%ϼgjR'GDj,aR.yq疀4 DB7`#w/^|3}ZQD{ҏg+"mmLQvW zp=MO`7d s!?tJ*}|Fb;j{H&cK˘ju?)|PCA-]#h+R:|r/8t$l L9_g+BiֺNV|"=zo1sˌajE?.>1!.n-kՎ5*$mDI=q/QL2mlՃ{(^m_^0juۦOp m3yZlҷr?sj]/ XCWW?ѱKGr~Rh̨PYk?.wI=m{sEl ' `&5#mU9bUot֋3 s녅}uLkh%Hrpԋi vs}2բhD)nxͶZa,W-N~yww{Uޤ:Rpf3m'D;plEuxjno:ufws#>etbl~*ҍ\s. Osd]TbYM+K_'.<7k}kˬ~p@Et{fΌ] 4=9Vl= }Ñ~sd˜GڇhVE_\7s45cTNu+//:yX>5axCME^*]џ\;:^jwKNL pe꜉D5^W٨U羣^~o*ۧأI^ݢ۳C0fٵWFޮy`/F&{|v[֓;4zUӼCwvn箥}qz>OFB5$k}5r1STrDv@`=9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`ND9A`.*WlIENDB`bayestestR/man/describe_prior.Rd0000644000176200001440000000254314766532531016454 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, parameters = NULL, ...) } \arguments{ \item{model}{A Bayesian model.} \item{...}{Currently not used.} \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.Rd0000644000176200001440000002330315203314503017303 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} \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) } \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.} } \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. \cr\cr For \code{as.matrix()} a square matrix of (log) Bayes factors, with rows as denominators and columns as numerators. } \description{ This function computes or extracts Bayes factors from fitted models. \cr\cr The \verb{bf_*} function is an alias of the main function. \cr\cr \strong{For more info, see \href{https://easystats.github.io/bayestestR/articles/bayes_factors.html}{the Bayes factors vignette}.} } \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 \link{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 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. } \subsection{Additional methods}{ The resulting output is supported by the following methods: \itemize{ \item \code{as.matrix()}: Extract a full matrix of (log-)Bayes factors between all models (using the transitivity of Bayes factors). \item \code{update()}: subset and/or re-reference the Bayes factors to a different model. \item \code{as.numeric()}: Extract the (possibly log-)Bayes factor values. } See examples and \link{bayesfactor_methods}. } } \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{Prior and posterior considerations}{ 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. \cr\cr 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}) (Note that by default, \code{brms::brm()} uses flat priors for fixed-effects); Wide priors result in smaller marginal likelihoods, and thus models with wider priors are trivially less likely than models with narrower priors - where, at the extreme, that a model with completely flat priors is infinitely less favorable than a point null model (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 Additionally, for models using MCMC estimation 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, a warning is issued. } \section{Transitivity of Bayes factors}{ For multiple inputs (models or hypotheses), the function will return multiple Bayes factors between each model and \emph{the same} reference model (the \code{denominator} or un-restricted model). However, we can take advantage of the transitivity of Bayes factors - where if we have two Bayes factors for Model \emph{A} and model \emph{B} against the \emph{same reference model C}, we can obtain a Bayes factor for comparing model \emph{A} to model \emph{B} by dividing them: \cr\cr \deqn{BF_{AB} = \frac{BF_{AC}}{BF_{BC}} = \frac{\frac{ML_{A}}{ML_{C}}}{\frac{ML_{B}}{ML_{C}}} = \frac{ML_{A}}{ML_{B}}} \cr\cr (Where \emph{ML} is the \emph{marginal likelihood}.) \cr\cr A full matrix comparing all models can be obtained with \code{as.matrix()}. } \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). See also \code{effectsize::interpret_bf()}. } \examples{ \dontshow{if (require("lme4") && require("BayesFactor") && require("rstanarm") && require("brms")) withAutoprint(\{ # 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} } } \seealso{ \code{\link[=bayesfactor_inclusion]{bayesfactor_inclusion()}} for testing predictors across Bayesian models. Other Bayes factors: \code{\link{bayesfactor_inclusion}()}, \code{\link{bayesfactor_parameters}()}, \code{\link{bayesfactor_restricted}()} } \author{ Mattan S. Ben-Shachar } \concept{Bayes factors} bayestestR/man/dot-select_nums.Rd0000644000176200001440000000040014266336540016551 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.Rd0000644000176200001440000000251615151511631017037 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{ \dontshow{if (requireNamespace("MASS", quietly = TRUE)) withAutoprint(\{ # examplesIf} 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") } \dontshow{\}) # examplesIf} } bayestestR/man/p_direction.Rd0000644000176200001440000003233015151511631015740 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.brmsfit} \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, as_p = FALSE, remove_na = TRUE, ... ) \method{p_direction}{data.frame}( x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, rvar_col = NULL, ... ) \method{p_direction}{brmsfit}( x, effects = "fixed", component = "conditional", parameters = NULL, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, ... ) \method{p_direction}{get_predicted}( x, method = "direct", null = 0, as_p = FALSE, remove_na = TRUE, 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{as_p}{If \code{TRUE}, the p-direction (pd) values are converted to a frequentist p-value using \code{\link[=pd_to_p]{pd_to_p()}}.} \item{remove_na}{Should missing values be removed before computation? Note that \code{Inf} (infinity) are \emph{not} removed.} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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). } \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{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). } } \section{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}): \ifelse{html}{\out{p = 2 * (1 - pd)}}{\eqn{p = 2 \times (1 - p_d)}} 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. } \section{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. \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). \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). 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}). } } \section{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))} 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. 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). } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (requireNamespace("rstanarm", quietly = TRUE) && requireNamespace("emmeans", quietly = TRUE) && requireNamespace("brms", quietly = TRUE) && requireNamespace("BayesFactor", quietly = TRUE)) withAutoprint(\{ # examplesIf} 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 # ----------------------------------------------- model <- rstanarm::stan_glm(mpg ~ wt + cyl, data = mtcars, chains = 2, refresh = 0 ) p_direction(model) p_direction(model, method = "kernel") # emmeans # ----------------------------------------------- p_direction(emmeans::emtrends(model, ~1, "wt", data = mtcars)) # brms models # ----------------------------------------------- model <- brms::brm(mpg ~ wt + cyl, data = mtcars) p_direction(model) p_direction(model, method = "kernel") # BayesFactor objects # ----------------------------------------------- bf <- BayesFactor::ttestBF(x = rnorm(100, 1, 1)) p_direction(bf) p_direction(bf, method = "kernel") } \dontshow{\}) # examplesIf} \dontshow{if (requireNamespace("posterior", quietly = TRUE)) withAutoprint(\{ # examplesIf} # Using "rvar_col" x <- data.frame(mu = c(0, 0.5, 1), sigma = c(1, 0.5, 0.25)) x$my_rvar <- posterior::rvar_rng(rnorm, 3, mean = x$mu, sd = x$sigma) x p_direction(x, rvar_col = "my_rvar") \dontshow{\}) # examplesIf} } \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.Rd0000644000176200001440000000051414266336540020132 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.Rd0000644000176200001440000002677015174322463017352 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.data.frame} \alias{describe_posterior.stanreg} \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}{data.frame}( 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, rvar_col = NULL, 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 = "fixed", component = "location", parameters = NULL, BF = 1, 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{"p_significance"} (or \code{"ps"}), \code{"p_rope"}, \code{"equivalence_test"} (or \code{"equitest"}), \code{"bayesfactor"} (or \code{"bf"}) or \code{"all"} to compute all tests. For each "test", the corresponding \strong{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 vector of two values (e.g., \code{c(-0.1, 0.1)}), \code{"default"} or a list of numeric vectors of the same length as numbers of parameters. 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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{diagnostic}{Diagnostic metrics to compute. Character (vector) or list with one or more of these options: \code{"ESS"}, \code{"ESS_bulk"}, \code{"Rhat"}, \code{"MCSE"} or \code{"all"}. \code{"ESS"} returns the \strong{tail-ESS} (the minimum of the effective sample sizes for the 5\% and 95\% quantiles), which is the most relevant diagnostic for assessing the reliability of credible intervals and other tail-based quantities. \code{"ESS_bulk"} additionally returns the \strong{bulk-ESS} (the effective sample size for the bulk of the posterior, useful for assessing the reliability of central tendency estimates such as the mean or median). \code{"all"} includes both tail and bulk \code{"ESS"}, \code{"Rhat"}, and \code{"MCSE"}.} \item{priors}{Add the prior used for each parameter.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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). } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (all(insight::check_if_installed(c("logspline", "rstanarm", "emmeans", "BayesFactor"), quietly = TRUE))) withAutoprint(\{ # examplesIf} library(bayestestR) 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 # ----------------------------------------------- model <- suppressWarnings( rstanarm::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)) describe_posterior(model, rope_range = list(c(-10, 5), c(-0.2, 0.2), "default")) # emmeans estimates # ----------------------------------------------- describe_posterior(emmeans::emtrends(model, ~1, "wt")) # BayesFactor objects # ----------------------------------------------- bf <- BayesFactor::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)) } \dontshow{\}) # examplesIf} } \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.Rd0000644000176200001440000000471014776266316017203 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{officialeasystats@gmail.com} (\href{https://orcid.org/0000-0001-5375-9967}{ORCID}) Authors: \itemize{ \item Daniel Lüdecke \email{d.luedecke@uke.de} (\href{https://orcid.org/0000-0002-8895-3206}{ORCID}) \item Mattan S. Ben-Shachar \email{matanshm@post.bgu.ac.il} (\href{https://orcid.org/0000-0002-4287-4801}{ORCID}) \item Indrajeet Patil \email{patilindrajeet.science@gmail.com} (\href{https://orcid.org/0000-0003-1995-6531}{ORCID}) \item Micah K. Wilson \email{micah.k.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}) } 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.Rd0000644000176200001440000000310515151511631022106 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")) withAutoprint(\{ # 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.Rd0000644000176200001440000000300414502413050017023 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.Rd0000644000176200001440000001403115174322463015420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mediation.R \name{mediation} \alias{mediation} \alias{mediation.brmsfit} \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", ... ) } \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 95\% 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 \strong{bayestestR} package. } \examples{ \dontshow{if (require("mediation") && require("brms") && require("rstanarm")) withAutoprint(\{ # 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.Rd0000644000176200001440000000061614266336540017537 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.Rd0000644000176200001440000000644115005370052016501 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/simulate_priors.R \name{simulate_prior} \alias{simulate_prior} \alias{simulate_prior.brmsfit} \title{Returns Priors of a Model as Empirical Distributions} \usage{ simulate_prior(model, n = 1000, ...) \method{simulate_prior}{brmsfit}( model, n = 1000, effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, ... ) } \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.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{verbose}{Toggle off warnings.} } \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.Rd0000644000176200001440000001131315151511631015727 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/check_prior.R \name{check_prior} \alias{check_prior} \alias{check_prior.brmsfit} \title{Check if Prior is Informative} \usage{ check_prior(model, method = "gelman", simulate_priors = TRUE, ...) \method{check_prior}{brmsfit}( model, method = "gelman", simulate_priors = TRUE, effects = "fixed", component = "conditional", parameters = NULL, verbose = 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.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{verbose}{Toggle off warnings.} } \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")) withAutoprint(\{ # 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.Rd0000644000176200001440000001503615204535252016760 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{\linkS4class[Matrix]{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.Rd0000644000176200001440000002171515151511631017020 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} \alias{estimate_density.brmsfit} \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, rvar_col = NULL, ... ) \method{estimate_density}{brmsfit}( x, method = "kernel", precision = 2^10, extend = FALSE, extend_scale = 0.1, bw = "SJ", effects = "fixed", component = "conditional", 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{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{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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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 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}. } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("logspline") && require("KernSmooth") && require("mclust") && require("emmeans") && require("rstanarm") && require("brms")) withAutoprint(\{ # 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.Rd0000644000176200001440000002137215174322463014236 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.data.frame} \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}{data.frame}(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) \method{eti}{brmsfit}( x, ci = 0.95, effects = "fixed", component = "conditional", 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} (95\%).} \item{verbose}{Toggle off warnings.} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{\link[=eti]{eti()}}) that typically exclude 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. 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.5th 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. The \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{95\% or 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). } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("rstanarm") && require("emmeans") && require("brms") && require("BayesFactor")) withAutoprint(\{ # 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{hdi}()}, \code{\link{si}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/area_under_curve.Rd0000644000176200001440000000305114406102612016745 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.Rd0000644000176200001440000000262214322454610017334 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.Rd0000644000176200001440000002000615174322463014203 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.brmsfit} \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, rvar_col = NULL, verbose = TRUE, ...) \method{bci}{brmsfit}( x, ci = 0.95, effects = "fixed", component = "conditional", parameters = NULL, 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} (95\%).} \item{verbose}{Toggle off warnings.} \item{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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{Bias Corrected and Accelerated Interval (BCa)} of posterior distributions. } \details{ Unlike equal-tailed intervals (see \code{\link[=eti]{eti()}}) that typically exclude 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. 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.5th 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. The \href{https://easystats.github.io/bayestestR/articles/credible_interval.html}{95\% or 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). } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \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{eti}()}, \code{\link{hdi}()}, \code{\link{si}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/sensitivity_to_prior.Rd0000644000176200001440000000323615151511631017753 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 will 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")) withAutoprint(\{ # 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.Rd0000644000176200001440000001675615174322463014062 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.brmsfit} \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", BF = 1, rvar_col = NULL, verbose = TRUE, ...) \method{ci}{brmsfit}( x, ci = 0.95, method = "ETI", effects = "fixed", component = "conditional", parameters = NULL, verbose = TRUE, BF = 1, ... ) } \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{rvar_col}{A single character - the name of an \code{rvar} column in the data frame to be processed. See example in \code{\link[=p_direction]{p_direction()}}.} \item{effects}{Should variables for fixed effects (\code{"fixed"}), random effects (\code{"random"}) or both (\code{"all"}) be returned? Only applies to mixed models. May be abbreviated. For models of from packages \strong{brms} or \strong{rstanarm} there are additional options: \itemize{ \item \code{"fixed"} returns fixed effects. \item \code{"random_variance"} return random effects parameters (variance and correlation components, e.g. those parameters that start with \code{sd_} or \code{cor_}). \item \code{"grouplevel"} returns random effects group level estimates, i.e. those parameters that start with \code{r_}. \item \code{"random"} returns both \code{"random_variance"} and \code{"grouplevel"}. \item \code{"all"} returns fixed effects and random effects variances. \item \code{"full"} returns all parameters. }} \item{component}{Which type of parameters to return, such as parameters for the conditional model, the zero-inflated part of the model, the dispersion term, etc. See details in section \emph{Model Components}. May be abbreviated. Note that the \emph{conditional} component also refers to the \emph{count} or \emph{mean} component - names may differ, depending on the modeling package. There are three convenient shortcuts (not applicable to \emph{all} model classes): \itemize{ \item \code{component = "all"} returns all possible parameters. \item If \code{component = "location"}, location parameters such as \code{conditional}, \code{zero_inflated}, \code{smooth_terms}, or \code{instruments} are returned (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item For \code{component = "distributional"} (or \code{"auxiliary"}), components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. }} \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 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}. } \section{Model components}{ Possible values for the \code{component} argument depend on the model class. Following are valid options: \itemize{ \item \code{"all"}: returns all model components, applies to all models, but will only have an effect for models with more than just the conditional model component. \item \code{"conditional"}: only returns the conditional component, i.e. "fixed effects" terms from the model. Will only have an effect for models with more than just the conditional model component. \item \code{"smooth_terms"}: returns smooth terms, only applies to GAMs (or similar models that may contain smooth terms). \item \code{"zero_inflated"} (or \code{"zi"}): returns the zero-inflation component. \item \code{"location"}: returns location parameters such as \code{conditional}, \code{zero_inflated}, or \code{smooth_terms} (everything that are fixed or random effects - depending on the \code{effects} argument - but no auxiliary parameters). \item \code{"distributional"} (or \code{"auxiliary"}): components like \code{sigma}, \code{dispersion}, \code{beta} or \code{precision} (and other auxiliary parameters) are returned. } For models of class \code{brmsfit} (package \strong{brms}), even more options are possible for the \code{component} argument, which are not all documented in detail here. See also \href{https://easystats.github.io/insight/reference/find_parameters.BGGM.html}{\code{?insight::find_parameters}}. } \examples{ \dontshow{if (require("rstanarm", quietly = TRUE)) withAutoprint(\{ # 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(rstanarm::stan_glm( mpg ~ wt, data = mtcars, chains = 2, iter = 200, refresh = 0 )) ci(model, method = "ETI", ci = c(0.80, 0.89, 0.95)) ci(model, method = "HDI", ci = c(0.80, 0.89, 0.95)) \dontshow{\}) # examplesIf} \dontshow{if (require("BayesFactor", quietly = TRUE)) withAutoprint(\{ # examplesIf} bf <- BayesFactor::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)) withAutoprint(\{ # examplesIf} model <- emmeans::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{eti}()}, \code{\link{hdi}()}, \code{\link{si}()}, \code{\link{spi}()} } \concept{ci} bayestestR/man/diagnostic_draws.Rd0000644000176200001440000000225315151511631016766 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; a list of data frames or matrices representing MCMC chains (rows as samples, columns as parameters); or a 3D array (dimensions: samples, chains, parameters)} \item{...}{Currently only used for models of class \code{brmsfit}, where a \code{variable} argument can be used, which is directly passed to the \code{as.data.frame()} method (i.e., \code{as.data.frame(x, variable = variable)}).} } \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/DESCRIPTION0000644000176200001440000001111515204610032014075 0ustar liggesusersType: Package Package: bayestestR Title: Understand and Describe Bayesian Models and Posterior Distributions Version: 0.18.1 Authors@R: c(person(given = "Dominique", family = "Makowski", role = c("aut", "cre"), email = "officialeasystats@gmail.com", comment = c(ORCID = "0000-0001-5375-9967")), person(given = "Daniel", family = "Lüdecke", role = "aut", email = "d.luedecke@uke.de", comment = c(ORCID = "0000-0002-8895-3206")), person(given = "Mattan S.", family = "Ben-Shachar", role = "aut", email = "matanshm@post.bgu.ac.il", comment = c(ORCID = "0000-0002-4287-4801")), person(given = "Indrajeet", family = "Patil", role = "aut", email = "patilindrajeet.science@gmail.com", comment = c(ORCID = "0000-0003-1995-6531")), person(given = "Micah K.", family = "Wilson", role = "aut", email = "micah.k.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")), 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 (>= 1.5.0.6), datawizard (>= 1.3.1), graphics, methods, stats, utils Suggests: BayesFactor (>= 0.9.12-4.4), bayesQR, bayesplot, betareg, BH, blavaan, bridgesampling (>= 1.2-1), brms, collapse, curl, effectsize, emmeans, gamm4, ggdist, ggplot2, glmmTMB, httr2, KernSmooth, knitr, lavaan, lme4, logspline (>= 2.1.21), marginaleffects (>= 0.29.0), MASS, mclust, mediation, modelbased, ordbetareg, parameters, patchwork, performance, posterior, quadprog, RcppEigen, rmarkdown, rstan, rstanarm, see (>= 0.8.5), testthat, tinytable, tweedie, withr 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.3 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: 2026-05-24 09:47:55 UTC; DL Author: Dominique Makowski [aut, cre] (ORCID: ), Daniel Lüdecke [aut] (ORCID: ), Mattan S. Ben-Shachar [aut] (ORCID: ), Indrajeet Patil [aut] (ORCID: ), Micah K. Wilson [aut] (ORCID: ), Brenton M. Wiernik [aut] (ORCID: ), Paul-Christian Bürkner [rev], Tristan Mahr [rev] (ORCID: ), Henrik Singmann [ctb] (ORCID: ), Quentin F. Gronau [ctb] (ORCID: ), Sam Crawley [ctb] (ORCID: ) Repository: CRAN Date/Publication: 2026-05-24 14:50:02 UTC