Skip to content

Commit

Permalink
Merge branch 'main' of https://github.com/easystats/bayestestR
Browse files Browse the repository at this point in the history
  • Loading branch information
@strengejacke
strengejacke committed Oct 8, 2023
2 parents b0f6dbd + 3f7ad0c commit cd64f9a
Show file tree
Hide file tree
Showing 7 changed files with 146 additions and 86 deletions.
116 changes: 58 additions & 58 deletions R/describe_posterior.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -169,7 +169,9 @@ describe_posterior.default <- function(posterior, ...) {

# Point-estimates

if (!is.null(centrality)) {
if (is.null(centrality)) {
estimates <- data.frame(Parameter = NA)
} else {
estimates <- .prepare_output(
point_estimate(x_df, centrality = centrality, dispersion = dispersion, ...),
cleaned_parameters,
Expand All @@ -181,20 +183,20 @@ describe_posterior.default <- function(posterior, ...) {
estimates
)
}
} else {
estimates <- data.frame(Parameter = NA)
}


# Uncertainty

if (!is.null(ci)) {
if (is.null(ci)) {
uncertainty <- data.frame(Parameter = NA)
} else {
ci_method <- match.arg(tolower(ci_method), c("hdi", "spi", "quantile", "ci", "eti", "si", "bci", "bcai"))
# not sure why "si" requires the model object
if (ci_method == "si") {
uncertainty <- ci(x, BF = BF, method = ci_method, prior = bf_prior, ...)
uncertainty <- ci(x, BF = BF, method = ci_method, prior = bf_prior, verbose = verbose, ...)
} else {
uncertainty <- ci(x_df, ci = ci, method = ci_method, ...)
uncertainty <- ci(x_df, ci = ci, method = ci_method, verbose = verbose, ...)
}
uncertainty <- .prepare_output(
uncertainty,
Expand All @@ -208,14 +210,54 @@ describe_posterior.default <- function(posterior, ...) {
uncertainty
)
}
} else {
uncertainty <- data.frame(Parameter = NA)
}


# Effect Existence

if (!is.null(test)) {
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")
Expand Down Expand Up @@ -281,7 +323,7 @@ describe_posterior.default <- function(posterior, ...) {

if ("p_rope" %in% test) {
test_prope <- .prepare_output(
p_rope(x_df, range = rope_range, ...),
p_rope(x_df, range = rope_range, verbose = verbose, ...),
cleaned_parameters,
is_stanmvreg
)
Expand Down Expand Up @@ -369,11 +411,11 @@ describe_posterior.default <- function(posterior, ...) {
if (any(c("bf", "bayesfactor", "bayes_factor") %in% test)) {
test_bf <- tryCatch(
.prepare_output(
bayesfactor_parameters(x, prior = bf_prior, ...),
bayesfactor_parameters(x, prior = bf_prior, verbose = verbose, ...),
cleaned_parameters,
is_stanmvreg
),
error = function(e) data.frame("Parameter" = NA)
error = function(e) data.frame(Parameter = NA)
)
if (!"Parameter" %in% names(test_bf)) {
test_bf <- cbind(
Expand All @@ -382,50 +424,8 @@ describe_posterior.default <- function(posterior, ...) {
)
}
} else {
test_bf <- data.frame("Parameter" = NA)
test_bf <- data.frame(Parameter = NA)
}
} else {
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
)
}


Expand Down Expand Up @@ -515,9 +515,9 @@ describe_posterior.default <- function(posterior, ...) {

#' @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))
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
}

Expand Down
10 changes: 9 additions & 1 deletion R/equivalence_test.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -249,7 +249,15 @@ equivalence_test.stanreg <- function(x,
range = "default",
ci = 0.95,
effects = c("fixed", "random", "all"),
component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"),
component = c(
"location",
"all",
"conditional",
"smooth_terms",
"sigma",
"distributional",
"auxiliary"
),
parameters = NULL,
verbose = TRUE,
...) {
Expand Down
84 changes: 68 additions & 16 deletions R/p_rope.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,8 +30,8 @@ p_rope.default <- function(x, ...) {

#' @rdname p_rope
#' @export
p_rope.numeric <- function(x, range = "default", ...) {
out <- .p_rope(rope(x, range = range, ci = 1, ...))
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
}
Expand All @@ -42,19 +42,19 @@ p_rope.data.frame <- p_rope.numeric


#' @export
p_rope.draws <- function(x, range = "default", ...) {
p_rope(.posterior_draws_to_df(x), range = range, ...)
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", ...) {
p_rope.emmGrid <- function(x, range = "default", verbose = TRUE, ...) {
xdf <- insight::get_parameters(x)

out <- p_rope(xdf, range = range)
out <- p_rope(xdf, range = range, verbose = verbose)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}
Expand All @@ -71,8 +71,31 @@ p_rope.MCMCglmm <- p_rope.numeric

#' @rdname p_rope
#' @export
p_rope.stanreg <- function(x, range = "default", effects = c("fixed", "random", "all"), component = c("location", "all", "conditional", "smooth_terms", "sigma", "distributional", "auxiliary"), parameters = NULL, ...) {
out <- .p_rope(rope(x, range = range, ci = 1, effects = effects, component = component, parameters = parameters, ...))
p_rope.stanreg <- function(x,
range = "default",
effects = c("fixed", "random", "all"),
component = c(
"location",
"all",
"conditional",
"smooth_terms",
"sigma",
"distributional",
"auxiliary"
),
parameters = NULL,
verbose = verbose,
...) {
out <- .p_rope(rope(
x,
range = range,
ci = 1,
effects = effects,
component = component,
parameters = parameters,
verbose = verbose,
...
))
out <- .add_clean_parameters_attribute(out, x)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
Expand All @@ -87,8 +110,23 @@ p_rope.blavaan <- p_rope.stanreg

#' @rdname p_rope
#' @export
p_rope.brmsfit <- function(x, range = "default", effects = c("fixed", "random", "all"), component = c("conditional", "zi", "zero_inflated", "all"), parameters = NULL, ...) {
out <- .p_rope(rope(x, range = range, ci = 1, effects = effects, component = component, parameters = parameters, ...))
p_rope.brmsfit <- function(x,
range = "default",
effects = c("fixed", "random", "all"),
component = c("conditional", "zi", "zero_inflated", "all"),
parameters = NULL,
verbose = verbose,
...) {
out <- .p_rope(rope(
x,
range = range,
ci = 1,
effects = effects,
component = component,
parameters = parameters,
verbose = verbose,
...
))
out <- .add_clean_parameters_attribute(out, x)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
Expand All @@ -100,24 +138,38 @@ p_rope.sim.merMod <- p_rope.stanreg


#' @export
p_rope.sim <- function(x, range = "default", parameters = NULL, ...) {
out <- .p_rope(rope(x, range = range, ci = 1, parameters = parameters, ...))
p_rope.sim <- function(x, range = "default", parameters = NULL, verbose = TRUE, ...) {
out <- .p_rope(rope(x, range = range, ci = 1, parameters = parameters, verbose = verbose, ...))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
out
}

#' @export
p_rope.bamlss <- function(x, range = "default", component = c("all", "conditional", "location"), parameters = NULL, ...) {
p_rope.bamlss <- function(x,
range = "default",
component = c("all", "conditional", "location"),
parameters = NULL,
verbose = TRUE,
...) {
component <- match.arg(component)
out <- .p_rope(rope(x, range = range, ci = 1, effects = "all", component = component, parameters = parameters, ...))
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, ...) {
out <- .p_rope(rope(x, range = range, ci = 1, parameters = parameters, ...))
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
}
Expand Down
6 changes: 5 additions & 1 deletion man/p_rope.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

8 changes: 2 additions & 6 deletions tests/testthat/_snaps/windows/print.md
View file
Original file line number Diff line number Diff line change
@@ -1,9 +1,7 @@
# print.describe_posterior

Code
describe_posterior(m)
Warning <simpleWarning>
Could not estimate a good default ROPE range. Using 'c(-0.1, 0.1)'.
describe_posterior(m, verbose = FALSE)
Output
Summary of Posterior Distribution
Expand All @@ -16,9 +14,7 @@
---

Code
describe_posterior(m, effects = "all", component = "all")
Warning <simpleWarning>
Could not estimate a good default ROPE range. Using 'c(-0.1, 0.1)'.
describe_posterior(m, effects = "all", component = "all", verbose = FALSE)
Output
Summary of Posterior Distribution
Expand Down
Loading

0 comments on commit cd64f9a

Please sign in to comment.