From 93de7a9f98ea64cef79be8617933303c844e2161 Mon Sep 17 00:00:00 2001 From: Daniel Date: Mon, 16 Sep 2024 19:38:08 +0200 Subject: [PATCH] fix p_significance --- R/p_significance.R | 35 +++++++++++++++++++++++++++++++++-- R/print.R | 40 ++++++++++++++++++++++++++++------------ R/print_html.R | 18 +++++++++++++----- R/print_md.R | 18 +++++++++++++----- 4 files changed, 87 insertions(+), 24 deletions(-) diff --git a/R/p_significance.R b/R/p_significance.R index 46c8bd1c5..7c1e01898 100644 --- a/R/p_significance.R +++ b/R/p_significance.R @@ -133,6 +133,28 @@ p_significance.data.frame <- function(x, threshold = "default", rvar_col = NULL, if (ncol(x) == 1) { ps <- .p_significance(x[, 1], threshold = threshold, ...) + } else if (is.list(threshold)) { + if (length(threshold) != ncol(x)) { + insight::format_error("Length of `threshold` should match the number of parameters.") + } + # check if list of values contains only valid values + checks <- vapply(threshold, function(r) { + !all(r == "default") || !all(is.numeric(r)) || length(r) != 2 + }, logical(1)) + if (!all(checks)) { + insight::format_error("`threshold` should be 'default' or a vector of 2 numeric values (e.g., c(-0.1, 0.1)).") + } + ps <- mapply( + function(p, thres) { + .p_significance( + p, + threshold = thres + ) + }, + x, + threshold, + SIMPLIFY = FALSE + ) } else { ps <- sapply(x, .p_significance, threshold = threshold, simplify = TRUE, ...) } @@ -365,6 +387,15 @@ as.double.p_significance <- as.numeric.p_significance #' @keywords internal .select_threshold_ps <- function(model = NULL, threshold = "default", verbose = TRUE) { + if (is.list(threshold)) { + lapply(threshold, .select_threshold_list, model = model, verbose = verbose) + } 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)) { @@ -372,11 +403,11 @@ as.double.p_significance <- as.numeric.p_significance } else { threshold <- rope_range(model, verbose = verbose)[2] } - } else if (!all(is.numeric(threshold)) || length(threshold) > 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)", + "- 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)`)" ) } diff --git a/R/print.R b/R/print.R index fbe3a2fd6..c4f464f58 100644 --- a/R/print.R +++ b/R/print.R @@ -70,14 +70,19 @@ print.map_estimate <- function(x, #' @export print.p_rope <- function(x, digits = 2, ...) { - caption <- sprintf( - "Proportion of samples inside the ROPE [%.*f, %.*f]", - digits, - x$ROPE_low[1], - digits, - x$ROPE_high[1] - ) - x$ROPE_low <- x$ROPE_high <- NULL + # 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, @@ -90,14 +95,25 @@ print.p_rope <- function(x, digits = 2, ...) { #' @export print.p_significance <- function(x, digits = 2, ...) { - caption <- sprintf( - "Practical Significance (threshold: %s)", - insight::format_value(attributes(x)$threshold, digits = digits) - ) + 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 <- cbind(x, out) + 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, ... ) } diff --git a/R/print_html.R b/R/print_html.R index a7a4be75c..b9f958814 100644 --- a/R/print_html.R +++ b/R/print_html.R @@ -31,11 +31,19 @@ print_html.p_map <- function(x, digits = 2, caption = "MAP-based p-value", ...) #' @export print_html.p_rope <- function(x, digits = 2, ...) { - caption <- sprintf( - "Proportion of samples inside the ROPE [%.*f, %.*f]", - digits, x$ROPE_low[1], digits, x$ROPE_high[1] - ) - x$ROPE_low <- x$ROPE_high <- NULL + # 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", ...) } diff --git a/R/print_md.R b/R/print_md.R index f8910a123..643c7d50a 100644 --- a/R/print_md.R +++ b/R/print_md.R @@ -30,11 +30,19 @@ print_md.p_map <- function(x, digits = 2, caption = "MAP-based p-value", ...) { #' @export print_md.p_rope <- function(x, digits = 2, ...) { - caption <- sprintf( - "Proportion of samples inside the ROPE [%.*f, %.*f]", - digits, x$ROPE_low[1], digits, x$ROPE_high[1] - ) - x$ROPE_low <- x$ROPE_high <- NULL + # 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_md_default(x = x, digits = digits, caption = caption, ci_string = "ROPE", ...) }