Nothing
#' Methods for `{effectsize}` Tables
#'
#' Printing, formatting and plotting methods for `effectsize` tables.
#'
#' @param x Object to print.
#' @inheritParams insight::format_value
#' @inheritParams is_effectsize_name
#' @param ... Arguments passed to or from other functions.
#'
#' @section Plotting with `see`:
#' The `see` package contains relevant plotting functions. See the [plotting
#' vignette in the `see`
#' package](https://easystats.github.io/see/articles/effectsize.html).
#'
#' @seealso [insight::display()]
#'
#' @export
print.effectsize_table <- function(x, digits = 2, use_symbols = getOption("es.use_symbols", FALSE), ...) {
x_fmt <- format(x, digits = digits, output = "text", use_symbols = use_symbols, ...)
cat(insight::export_table(x_fmt, format = NULL, ...))
invisible(x)
}
#' @export
#' @rdname print.effectsize_table
print_md.effectsize_table <- function(x, digits = 2, use_symbols = getOption("es.use_symbols", FALSE), ...) {
x_fmt <- format(x, digits = digits, output = "markdown", ...)
insight::export_table(x_fmt, format = "markdown", ...)
}
#' @export
#' @rdname print.effectsize_table
print_html.effectsize_table <- function(x, digits = 2, use_symbols = getOption("es.use_symbols", FALSE), ...) {
x_fmt <- format(x, digits = digits, output = "html", ...)
insight::export_table(x_fmt, format = "html", ...)
}
#' @rdname print.effectsize_table
#' @param output Which output is the formatting intended for? Affects how title
#' and footers are formatted.
#' @export
format.effectsize_table <- function(x, digits = 2, output = c("text", "markdown", "html"), use_symbols = getOption("es.use_symbols", FALSE), ...) {
output <- match.arg(output)
## Clean footer
footer <- attr(x, "table_footer")
alt <- attr(x, "alternative")
if (!is.null(alt) && alt != "two.sided") {
bound <- if (alt == "less") x$CI_low[1] else x$CI_high[1]
bound_ <- insight::format_value(bound, digits = digits)
if (!is.character(digits) &&
!isTRUE(all.equal(bound, as.numeric(bound_)))) {
bound_ <- paste0(bound_, "~")
}
side <- if (alt == "less") "lower" else "upper"
ci_footer <- sprintf(
"One-sided CIs: %s bound fixed at [%s].",
side, bound_
)
footer <- c(footer, ci_footer)
}
# if (isTRUE(attr(x, "approximate"))) {
# approx_footer <- "Effect size is approximated."
# footer <- c(footer, approx_footer)
# }
rule_name <- attr(attr(x, "rules"), "rule_name", exact = TRUE)
if (!is.null(rule_name)) {
rule_footer <- sprintf("Interpretation rule: %s", rule_name)
footer <- c(footer, rule_footer)
}
if (output == "text" && !is.null(footer)) {
footer <- lapply(footer, function(ftr) {
c(paste0("\n- ", ftr), .pcl["footer"])
})
}
attr(x, "table_footer") <- footer
## Clean caption
caption <- attr(x, "table_caption")
if (output == "text" && !is.null(caption)) {
caption <- c(paste0("# ", caption), .pcl["title"])
}
attr(x, "table_caption") <- caption
## Clean subtitle
subtitle <- attr(x, "table_subtitle")
if (output == "text" && !is.null(subtitle)) {
subtitle <- c(paste0("\n", subtitle), .pcl["subtitle"])
}
attr(x, "table_subtitle") <- subtitle
## Clean column names
i <- is_effectsize_name(colnames(x))
labs <- get_effectsize_label(colnames(x), use_symbols = use_symbols)
colnames(x)[i] <- labs[i]
attr(x, "ci") <- NULL
attr(x, "ci_method") <- NULL
insight::format_table(x,
digits = digits, ci_digits = digits,
preserve_attributes = TRUE, ...
)
}
# Print -------------------------------------------------------------------
#' @export
#' @rdname print.effectsize_table
#' @param append_CLES Which Common Language Effect Sizes should be printed as
#' well? Only applicable to Cohen's *d*, Hedges' *g* for independent samples
#' of equal variance (pooled sd) or for the rank-biserial correlation for
#' independent samples (See [d_to_cles]).
print.effectsize_difference <- function(x, digits = 2, append_CLES = NULL, ...) {
x_orig <- x
print.effectsize_table(x, digits = digits, ...)
if (is.logical(append_CLES) || is.character(append_CLES)) {
if (colnames(x_orig)[1] == "r_rank_biserial") {
cles_tab <- rb_to_p_superiority(x_orig)
} else if (colnames(x_orig)[1] %in% c("Cohens_d", "Hedges_g")) {
if (isTRUE(append_CLES)) {
append_CLES <- c("p_superiority", "u1", "u2", "u3", "overlap")
}
foos <- lapply(paste0("d_to_", append_CLES), match.fun)
cles <- lapply(foos, function(f) f(x_orig))
names(cles) <- sapply(cles, function(x) colnames(x)[1])
cles <- lapply(cles, function(x) {
colnames(x)[1] <- "CLES"
x
})
cles_tab <- do.call(rbind, cles)
cles_tab$Name <- get_effectsize_label(names(cles))
cles_tab <- cles_tab[c(ncol(cles_tab), seq_len(ncol(cles_tab) - 1))]
} else {
insight::format_error("CLES not applicable for this effect size.")
}
insight::print_color("\n\n## Common Language Effect Sizes:\n", .pcl["subtitle"])
print(cles_tab, digits = digits, ...)
}
invisible(x_orig)
}
# Format ------------------------------------------------------------------
#' @export
format.effectsize_difference <- function(x, digits = 2, ...) {
caption <- subtitle <- NULL
footer <- attr(x, "table_footer")
## Add footer
mu <- attr(x, "mu")
if (mu != 0) {
mu_footer <- sprintf("Deviation from a difference of %g.", mu)
footer <- c(footer, mu_footer)
}
sd_type <- attr(x, "pooled_sd", exact = TRUE)
if (!is.null(sd_type)) {
sd_type <- sprintf(
"Estimated using %spooled SD.",
ifelse(sd_type, "", "un-")
)
footer <- c(footer, sd_type)
}
attr(x, "table_footer") <- footer
attr(x, "table_caption") <- caption
attr(x, "table_subtitle") <- subtitle
format.effectsize_table(x, digits = digits, ...)
}
#' @export
format.effectsize_anova <- function(x, digits = 2, ...) {
footer <- attr(x, "table_footer")
caption <- subtitle <- NULL
## Title (caption)
anova_type <- attr(x, "anova_type", exact = TRUE)
if (is.null(anova_type) || is.na(anova_type)) {
type <- ""
} else {
type <- sprintf(" (Type %s)", utils::as.roman(anova_type))
}
caption <- sprintf("Effect Size for ANOVA%s", type)
## Footer
obs <- attr(x, "generalized")
if (is.character(obs) || isTRUE(obs)) {
if (isTRUE(obs)) {
obs <- "All"
} else {
obs <- toString(obs)
}
gen_footer <- sprintf("Observed variables: %s", obs)
footer <- c(footer, gen_footer)
}
attr(x, "table_footer") <- footer
attr(x, "table_caption") <- caption
attr(x, "table_subtitle") <- subtitle
format.effectsize_table(x, digits = digits, ...)
}
#' @export
format.equivalence_test_effectsize <- function(x, digits = 2, ...) {
colnames(x)[colnames(x) == "ROPE_Equivalence"] <- "H0"
caption <- footer <- subtitle <- NULL
## Title (caption)
if (attr(x, "rule", exact = TRUE) == "cet") {
rule <- "Conditional "
} else {
rule <- ""
}
caption <- sprintf("%sTest for Practical Equivalence", rule)
## Rope range
.rope <- attr(x, "rope", exact = TRUE)
.rope <- insight::format_value(.rope, digits = digits)
subtitle <- sprintf("ROPE: [%s, %s]", .rope[1], .rope[2])
## ROPE_Equivalence
if (attr(x, "rule", exact = TRUE) == "bayes") {
footer <- "Using Bayesian guidlines"
}
attr(x, "table_footer") <- footer
attr(x, "table_caption") <- caption
attr(x, "table_subtitle") <- subtitle
format.effectsize_table(x, digits = digits, ...)
}
# Colors ------------------------------------------------------------------
.pcl <- c(title = "blue", subtitle = "blue", footer = "cyan", interpret = "italic")
# "red", "yellow", "green", "blue", "violet","cyan", "grey", "bold", "italic"
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.