Skip to content

Commit

Permalink
fix p_significance
Browse files Browse the repository at this point in the history
  • Loading branch information
strengejacke committed Sep 16, 2024
1 parent b9fa98a commit 93de7a9
Show file tree
Hide file tree
Showing 4 changed files with 87 additions and 24 deletions.
35 changes: 33 additions & 2 deletions R/p_significance.R
Original file line number Diff line number Diff line change
Expand Up @@ -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(

Check warning on line 147 in R/p_significance.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files

file=R/p_significance.R,line=147,col=11,[undesirable_function_linter] Avoid undesirable function "mapply".
function(p, thres) {
.p_significance(
p,
threshold = thres
)
},
x,
threshold,
SIMPLIFY = FALSE
)
} else {
ps <- sapply(x, .p_significance, threshold = threshold, simplify = TRUE, ...)
}
Expand Down Expand Up @@ -365,18 +387,27 @@ 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)) {
threshold <- 0.1
} 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)`)"
)
}
Expand Down
40 changes: 28 additions & 12 deletions R/print.R
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand All @@ -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,
...
)
}
Expand Down
18 changes: 13 additions & 5 deletions R/print_html.R
Original file line number Diff line number Diff line change
Expand Up @@ -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", ...)
}

Expand Down
18 changes: 13 additions & 5 deletions R/print_md.R
Original file line number Diff line number Diff line change
Expand Up @@ -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", ...)
}

Expand Down

0 comments on commit 93de7a9

Please sign in to comment.