diff --git a/.Rbuildignore b/.Rbuildignore index f809dcf3c..aed6dc096 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -53,3 +53,5 @@ hextools # ^vignettes/(?!additional).* ^vignettes/additional ^LICENSE\.md$ +^\.vscode$ +^[.]?air[.]toml$ diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 000000000..344f76eba --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,5 @@ +{ + "recommendations": [ + "Posit.air-vscode" + ] +} diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 000000000..a9f69fe41 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,10 @@ +{ + "[r]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "Posit.air-vscode" + }, + "[quarto]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "quarto.quarto" + } +} diff --git a/R/cohens_d.R b/R/cohens_d.R index d11777ff2..03b763813 100644 --- a/R/cohens_d.R +++ b/R/cohens_d.R @@ -136,22 +136,37 @@ #' Correcting error and bias in research findings. Sage. #' #' @export -cohens_d <- function(x, y = NULL, data = NULL, - pooled_sd = TRUE, mu = 0, paired = FALSE, - reference = NULL, - adjust = FALSE, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +cohens_d <- function( + x, + y = NULL, + data = NULL, + pooled_sd = TRUE, + mu = 0, + paired = FALSE, + reference = NULL, + adjust = FALSE, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { var.equal <- eval.parent(match.call()[["var.equal"]]) - if (!is.null(var.equal)) pooled_sd <- var.equal + if (!is.null(var.equal)) { + pooled_sd <- var.equal + } .effect_size_difference( x, - y = y, data = data, - type = "d", adjust = adjust, - pooled_sd = pooled_sd, mu = mu, paired = paired, + y = y, + data = data, + type = "d", + adjust = adjust, + pooled_sd = pooled_sd, + mu = mu, + paired = paired, reference = reference, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose, ... ) @@ -159,11 +174,19 @@ cohens_d <- function(x, y = NULL, data = NULL, #' @rdname cohens_d #' @export -hedges_g <- function(x, y = NULL, data = NULL, - pooled_sd = TRUE, mu = 0, paired = FALSE, - reference = NULL, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +hedges_g <- function( + x, + y = NULL, + data = NULL, + pooled_sd = TRUE, + mu = 0, + paired = FALSE, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { cl <- match.call() cl[[1]] <- quote(effectsize::cohens_d) cl$adjust <- TRUE @@ -172,47 +195,77 @@ hedges_g <- function(x, y = NULL, data = NULL, #' @rdname cohens_d #' @export -glass_delta <- function(x, y = NULL, data = NULL, - mu = 0, adjust = TRUE, - reference = NULL, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +glass_delta <- function( + x, + y = NULL, + data = NULL, + mu = 0, + adjust = TRUE, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { .effect_size_difference( x, - y = y, data = data, + y = y, + data = data, type = "delta", - mu = mu, adjust = adjust, + mu = mu, + adjust = adjust, reference = reference, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose, - pooled_sd = NULL, paired = FALSE, + pooled_sd = NULL, + paired = FALSE, ... ) } - #' @keywords internal -.effect_size_difference <- function(x, y = NULL, data = NULL, - type = "d", adjust = FALSE, - mu = 0, pooled_sd = TRUE, paired = FALSE, - reference = NULL, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { - if (type == "d" && adjust) type <- "g" +.effect_size_difference <- function( + x, + y = NULL, + data = NULL, + type = "d", + adjust = FALSE, + mu = 0, + pooled_sd = TRUE, + paired = FALSE, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { + if (type == "d" && adjust) { + type <- "g" + } # TODO: Check if we can do anything with `reference` for these classes if (type != "delta") { if (.is_htest_of_type(x, "t-test")) { return(effectsize(x, type = type, verbose = verbose, data = data, ...)) - } else if (.is_BF_of_type(x, c("BFoneSample", "BFindepSample"), "t-squared")) { + } else if ( + .is_BF_of_type(x, c("BFoneSample", "BFindepSample"), "t-squared") + ) { return(effectsize(x, ci = ci, verbose = verbose, ...)) } } - alternative <- .match.alt(alternative) - out <- .get_data_2_samples(x, y, data, paired = paired, reference = reference, verbose = verbose, ...) + out <- .get_data_2_samples( + x, + y, + data, + paired = paired, + reference = reference, + verbose = verbose, + ... + ) x <- out[["x"]] y <- out[["y"]] paired <- out[["paired"]] @@ -225,7 +278,9 @@ glass_delta <- function(x, y = NULL, data = NULL, if (is.null(y)) { if (type == "delta") { - insight::format_error("For Glass' Delta, please provide data from two samples.") + insight::format_error( + "For Glass' Delta, please provide data from two samples." + ) } y <- 0 is_paired_or_onesample <- TRUE @@ -236,7 +291,9 @@ glass_delta <- function(x, y = NULL, data = NULL, # Compute index if (is_paired_or_onesample) { if (type == "delta") { - insight::format_error("This effect size is only applicable for two independent samples.") + insight::format_error( + "This effect size is only applicable for two independent samples." + ) } d <- mean(x - y) @@ -304,7 +361,10 @@ glass_delta <- function(x, y = NULL, data = NULL, if (adjust) { J <- .J(df1) - col_to_adjust <- intersect(colnames(out), c(types[type], "CI_low", "CI_high")) + col_to_adjust <- intersect( + colnames(out), + c(types[type], "CI_low", "CI_high") + ) out[, col_to_adjust] <- out[, col_to_adjust] * J if (type == "delta") { @@ -312,9 +372,20 @@ glass_delta <- function(x, y = NULL, data = NULL, } } - class(out) <- c("effectsize_difference", "effectsize_table", "see_effectsize_table", class(out)) + class(out) <- c( + "effectsize_difference", + "effectsize_table", + "see_effectsize_table", + class(out) + ) .someattributes(out) <- .nlist( - paired, pooled_sd, mu, ci, ci_method, alternative, adjust, + paired, + pooled_sd, + mu, + ci, + ci_method, + alternative, + adjust, approximate = FALSE ) out diff --git a/R/cohens_g.R b/R/cohens_g.R index 7a66ad0c8..e63dfbf62 100644 --- a/R/cohens_g.R +++ b/R/cohens_g.R @@ -52,16 +52,13 @@ #' # Test 2 gives a negative result more than test 1! #' #' @export -cohens_g <- function(x, y = NULL, - ci = 0.95, alternative = "two.sided", - ...) { +cohens_g <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { alternative <- .match.alt(alternative) if (.is_htest_of_type(x, "McNemar")) { return(effectsize(x, ci = ci, alternative = alternative)) } - if (!is.matrix(x)) { if (is.null(y)) { insight::format_error("if 'x' is not a matrix, 'y' must be given") @@ -73,14 +70,17 @@ cohens_g <- function(x, y = NULL, x <- as.factor(x[OK]) y <- as.factor(y[OK]) if ((nlevels(x) < 2) || (nlevels(y) != nlevels(x))) { - insight::format_error("'x' and 'y' must have the same number of levels (minimum 2)") + insight::format_error( + "'x' and 'y' must have the same number of levels (minimum 2)" + ) } x <- table(x, y) } else if ((nrow(x) < 2) || (ncol(x) != nrow(x))) { - insight::format_error("'x' must be square with at least two rows and columns") + insight::format_error( + "'x' must be square with at least two rows and columns" + ) } - a <- x[upper.tri(x)] b <- t(x)[upper.tri(x)] @@ -95,7 +95,9 @@ cohens_g <- function(x, y = NULL, n <- sum(a) + sum(b) k <- P * n - res <- stats::prop.test(k, n, + res <- stats::prop.test( + k, + n, p = 0.5, alternative = alternative, conf.level = ci, diff --git a/R/common_language.R b/R/common_language.R index 2b504bfa6..d4f0ee9e1 100644 --- a/R/common_language.R +++ b/R/common_language.R @@ -109,21 +109,40 @@ #' #' @export #' @aliases cles -p_superiority <- function(x, y = NULL, data = NULL, - mu = 0, paired = FALSE, parametric = TRUE, - reference = NULL, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +p_superiority <- function( + x, + y = NULL, + data = NULL, + mu = 0, + paired = FALSE, + parametric = TRUE, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { if (.is_htest_of_type(x, "(t-test|Wilcoxon)", "t-test or a Wilcoxon-test")) { return(effectsize(x, type = "p_superiority", verbose = verbose, ...)) } else if (.is_BF_of_type(x, c("BFindepSample", "BFoneSample"), "t-test")) { - return(effectsize(x, type = "p_superiority", ci = ci, verbose = verbose, ...)) + return(effectsize( + x, + type = "p_superiority", + ci = ci, + verbose = verbose, + ... + )) } - data <- .get_data_2_samples(x, y, data, - paired = paired, reference = reference, + data <- .get_data_2_samples( + x, + y, + data, + paired = paired, + reference = reference, allow_ordered = !parametric, - verbose = verbose, ... + verbose = verbose, + ... ) x <- data[["x"]] y <- data[["y"]] @@ -133,7 +152,8 @@ p_superiority <- function(x, y = NULL, data = NULL, d <- cohens_d( x = x, y = y, - paired = paired, pooled_sd = TRUE, + paired = paired, + pooled_sd = TRUE, mu = mu, ci = ci, alternative = alternative, @@ -157,34 +177,51 @@ p_superiority <- function(x, y = NULL, data = NULL, #' @export #' @rdname p_superiority -cohens_u1 <- function(x, y = NULL, data = NULL, - mu = 0, parametric = TRUE, - ci = 0.95, alternative = "two.sided", iterations = 200, - verbose = TRUE, ...) { +cohens_u1 <- function( + x, + y = NULL, + data = NULL, + mu = 0, + parametric = TRUE, + ci = 0.95, + alternative = "two.sided", + iterations = 200, + verbose = TRUE, + ... +) { if (.is_htest_of_type(x, "(t-test|Wilcoxon)", "t-test or a Wilcoxon-test")) { return(effectsize(x, type = "u1", verbose = verbose, ...)) } else if (.is_BF_of_type(x, "BFindepSample", "t-test")) { return(effectsize(x, type = "u1", ci = ci, verbose = verbose, ...)) } - data <- .get_data_2_samples(x, y, data, + data <- .get_data_2_samples( + x, + y, + data, allow_ordered = !parametric, - verbose = verbose, ... + verbose = verbose, + ... ) x <- data[["x"]] y <- data[["y"]] if (is.null(y) || isTRUE(match.call()$paired) || isTRUE(data[["paired"]])) { - insight::format_error("This effect size is only applicable for two independent samples.") + insight::format_error( + "This effect size is only applicable for two independent samples." + ) } if (!parametric) { - insight::format_error("Cohen's U1 only available for parametric estimation.") + insight::format_error( + "Cohen's U1 only available for parametric estimation." + ) } d <- cohens_d( x = x, y = y, - paired = FALSE, pooled_sd = TRUE, + paired = FALSE, + pooled_sd = TRUE, mu = mu, ci = ci, alternative = alternative, @@ -198,31 +235,46 @@ cohens_u1 <- function(x, y = NULL, data = NULL, #' @export #' @rdname p_superiority -cohens_u2 <- function(x, y = NULL, data = NULL, - mu = 0, parametric = TRUE, - ci = 0.95, alternative = "two.sided", iterations = 200, - verbose = TRUE, ...) { +cohens_u2 <- function( + x, + y = NULL, + data = NULL, + mu = 0, + parametric = TRUE, + ci = 0.95, + alternative = "two.sided", + iterations = 200, + verbose = TRUE, + ... +) { if (.is_htest_of_type(x, "(t-test|Wilcoxon)", "t-test or a Wilcoxon-test")) { return(effectsize(x, type = "u2", verbose = verbose, ...)) } else if (.is_BF_of_type(x, "BFindepSample", "t-test")) { return(effectsize(x, type = "u2", ci = ci, verbose = verbose, ...)) } - data <- .get_data_2_samples(x, y, data, + data <- .get_data_2_samples( + x, + y, + data, allow_ordered = !parametric, - verbose = verbose, ... + verbose = verbose, + ... ) x <- data[["x"]] y <- data[["y"]] if (is.null(y) || isTRUE(match.call()$paired) || isTRUE(data[["paired"]])) { - insight::format_error("This effect size is only applicable for two independent samples.") + insight::format_error( + "This effect size is only applicable for two independent samples." + ) } if (parametric) { d <- cohens_d( x = x, y = y, - paired = FALSE, pooled_sd = TRUE, + paired = FALSE, + pooled_sd = TRUE, mu = mu, ci = ci, alternative = alternative, @@ -231,9 +283,11 @@ cohens_u2 <- function(x, y = NULL, data = NULL, out <- d_to_u2(d) } else { out <- .cohens_u2_non_parametric( - x, y, + x, + y, ci = ci, - mu = mu, alternative = alternative, + mu = mu, + alternative = alternative, iterations = iterations ) } @@ -243,33 +297,48 @@ cohens_u2 <- function(x, y = NULL, data = NULL, #' @export #' @rdname p_superiority -cohens_u3 <- function(x, y = NULL, data = NULL, - mu = 0, parametric = TRUE, - reference = NULL, - ci = 0.95, alternative = "two.sided", iterations = 200, - verbose = TRUE, ...) { +cohens_u3 <- function( + x, + y = NULL, + data = NULL, + mu = 0, + parametric = TRUE, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + iterations = 200, + verbose = TRUE, + ... +) { if (.is_htest_of_type(x, "(t-test|Wilcoxon)", "t-test or a Wilcoxon-test")) { return(effectsize(x, type = "u3", verbose = verbose, ...)) } else if (.is_BF_of_type(x, "BFindepSample", "t-test")) { return(effectsize(x, type = "u3", ci = ci, verbose = verbose, ...)) } - - data <- .get_data_2_samples(x, y, data, - allow_ordered = !parametric, reference = reference, - verbose = verbose, ... + data <- .get_data_2_samples( + x, + y, + data, + allow_ordered = !parametric, + reference = reference, + verbose = verbose, + ... ) x <- data[["x"]] y <- data[["y"]] if (is.null(y) || isTRUE(match.call()$paired) || isTRUE(data[["paired"]])) { - insight::format_error("This effect size is only applicable for two independent samples.") + insight::format_error( + "This effect size is only applicable for two independent samples." + ) } if (parametric) { d <- cohens_d( x = x, y = y, - paired = FALSE, pooled_sd = TRUE, + paired = FALSE, + pooled_sd = TRUE, mu = mu, ci = ci, alternative = alternative, @@ -278,9 +347,11 @@ cohens_u3 <- function(x, y = NULL, data = NULL, out <- d_to_u3(d) } else { out <- .cohens_u3_non_parametric( - x, y, + x, + y, ci = ci, - mu = mu, alternative = alternative, + mu = mu, + alternative = alternative, iterations = iterations ) } @@ -289,31 +360,46 @@ cohens_u3 <- function(x, y = NULL, data = NULL, #' @export #' @rdname p_superiority -p_overlap <- function(x, y = NULL, data = NULL, - mu = 0, parametric = TRUE, - ci = 0.95, alternative = "two.sided", iterations = 200, - verbose = TRUE, ...) { +p_overlap <- function( + x, + y = NULL, + data = NULL, + mu = 0, + parametric = TRUE, + ci = 0.95, + alternative = "two.sided", + iterations = 200, + verbose = TRUE, + ... +) { if (.is_htest_of_type(x, "(t-test|Wilcoxon)", "t-test or a Wilcoxon-test")) { return(effectsize(x, type = "overlap", verbose = verbose, ...)) } else if (.is_BF_of_type(x, "BFindepSample", "t-test")) { return(effectsize(x, type = "overlap", ci = ci, verbose = verbose, ...)) } - data <- .get_data_2_samples(x, y, data, + data <- .get_data_2_samples( + x, + y, + data, allow_ordered = !parametric, - verbose = verbose, ... + verbose = verbose, + ... ) x <- data[["x"]] y <- data[["y"]] if (is.null(y) || isTRUE(match.call()$paired) || isTRUE(data[["paired"]])) { - insight::format_error("This effect size is only applicable for two independent samples.") + insight::format_error( + "This effect size is only applicable for two independent samples." + ) } if (parametric) { d <- cohens_d( x = x, y = y, - paired = FALSE, pooled_sd = TRUE, + paired = FALSE, + pooled_sd = TRUE, mu = mu, ci = ci, alternative = alternative, @@ -322,9 +408,11 @@ p_overlap <- function(x, y = NULL, data = NULL, out <- d_to_overlap(d) } else { out <- .overlap_non_parametric( - x, y, + x, + y, ci = ci, - mu = mu, alternative = alternative, + mu = mu, + alternative = alternative, iterations = iterations ) } @@ -333,10 +421,16 @@ p_overlap <- function(x, y = NULL, data = NULL, #' @export #' @rdname p_superiority -vd_a <- function(x, y = NULL, data = NULL, - mu = 0, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +vd_a <- function( + x, + y = NULL, + data = NULL, + mu = 0, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { cl <- match.call() cl[[1]] <- quote(effectsize::p_superiority) cl$parametric <- FALSE @@ -346,10 +440,17 @@ vd_a <- function(x, y = NULL, data = NULL, #' @export #' @rdname p_superiority -wmw_odds <- function(x, y = NULL, data = NULL, - mu = 0, paired = FALSE, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +wmw_odds <- function( + x, + y = NULL, + data = NULL, + mu = 0, + paired = FALSE, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { cl <- match.call() cl[[1]] <- quote(effectsize::rank_biserial) out <- eval.parent(cl) @@ -358,9 +459,6 @@ wmw_odds <- function(x, y = NULL, data = NULL, } - - - # Utils ------------------------------------------------------------------- #' @keywords internal @@ -371,14 +469,17 @@ wmw_odds <- function(x, y = NULL, data = NULL, y <- data[data$g == "y", "r"] .foo <- function(p) { - difference <- stats::quantile(x, probs = c(p, 1 - p)) - stats::quantile(y, probs = c(1 - p, p)) + difference <- stats::quantile(x, probs = c(p, 1 - p)) - + stats::quantile(y, probs = c(1 - p, p)) min(abs(difference)) } stats::optim( - par = 0.5, fn = .foo, + par = 0.5, + fn = .foo, method = "L-BFGS-B", - lower = 0.5, upper = 1, + lower = 0.5, + upper = 1, control = list(pgtol = 1e-09) )$par } @@ -436,13 +537,15 @@ wmw_odds <- function(x, y = NULL, data = NULL, #' @keywords internal .cles_non_parametric <- - function(x, - y, - est, - ci = 0.95, - mu = 0, - alternative = "two.sided", - iterations = 200) { + function( + x, + y, + est, + ci = 0.95, + mu = 0, + alternative = "two.sided", + iterations = 200 + ) { d <- data.frame( r = c(x, y), g = rep(c("x", "y"), c(length(x), length(y))), @@ -451,8 +554,10 @@ wmw_odds <- function(x, y = NULL, data = NULL, out <- data.frame(ES = est(d)) - if (.test_ci(ci) && - insight::check_if_installed("boot", "for estimating CIs", stop = FALSE)) { + if ( + .test_ci(ci) && + insight::check_if_installed("boot", "for estimating CIs", stop = FALSE) + ) { ci.level <- .adjust_ci(ci, alternative) out$CI <- ci @@ -467,7 +572,10 @@ wmw_odds <- function(x, y = NULL, data = NULL, bCI <- utils::tail(as.vector(bCI), 2) out$CI_low <- bCI[1] out$CI_high <- bCI[2] - ci_method <- list(method = "percentile bootstrap", iterations = iterations) + ci_method <- list( + method = "percentile bootstrap", + iterations = iterations + ) } else { ci_method <- alternative <- ci <- NULL } @@ -476,7 +584,10 @@ wmw_odds <- function(x, y = NULL, data = NULL, # TODO # class(out) <- c("effectsize_difference", "effectsize_table", "see_effectsize_table", class(out)) .someattributes(out) <- .nlist( - mu, ci, ci_method, alternative, + mu, + ci, + ci_method, + alternative, approximate = TRUE, table_footer = "Non-parametric CLES" ) diff --git a/R/convert_between_anova.R b/R/convert_between_anova.R index 63cd36317..6251c5502 100644 --- a/R/convert_between_anova.R +++ b/R/convert_between_anova.R @@ -53,9 +53,6 @@ f_to_eta2 <- function(f) { f2_to_eta2(f^2) } - - - # eta2_to_F <- function(eta2, df, df_error, ...) { # eta2 * df_error / ((1 - eta2) * df) # } diff --git a/R/convert_between_common_language.R b/R/convert_between_common_language.R index 6dc1fc9f6..5f1c54482 100644 --- a/R/convert_between_common_language.R +++ b/R/convert_between_common_language.R @@ -49,8 +49,6 @@ #' @name diff_to_cles #' @aliases d_to_cles rb_to_cles - - # p_superiority ------------------------------------------------------ #' @export @@ -151,7 +149,9 @@ rb_to_wmw_odds.numeric <- function(rb) { #' @export rb_to_wmw_odds.effectsize_difference <- function(rb) { if (!any(colnames(rb) == "r_rank_biserial")) { - insight::format_error("Common language effect size only applicable rank-biserial correlation.") + insight::format_error( + "Common language effect size only applicable rank-biserial correlation." + ) } cols_to_conv <- colnames(rb) %in% c("r_rank_biserial", "CI_low", "CI_high") @@ -167,12 +167,15 @@ rb_to_wmw_odds.effectsize_difference <- function(rb) { } - # From Cohen's d ---------------------------------------------------------- #' @export d_to_p_superiority.effectsize_difference <- function(d) { - out <- .cohens_d_to_cles(d, converter = d_to_p_superiority, allow_paired = TRUE) + out <- .cohens_d_to_cles( + d, + converter = d_to_p_superiority, + allow_paired = TRUE + ) colnames(out)[1] <- "p_superiority" out } @@ -275,10 +278,13 @@ d_to_overlap.effectsize_difference <- function(d) { #' @keywords internal .cohens_d_to_cles <- function(d, converter, allow_paired = FALSE) { if (!.is_cles_applicable(d, allow_paired)) { - insight::format_error("Common language effect size only applicable to 2-sample Cohen's d with pooled SD.") + insight::format_error( + "Common language effect size only applicable to 2-sample Cohen's d with pooled SD." + ) } - cols_to_convert <- colnames(d) %in% c("Cohens_d", "Hedges_g", "CI_low", "CI_high") + cols_to_convert <- colnames(d) %in% + c("Cohens_d", "Hedges_g", "CI_low", "CI_high") out <- d out[cols_to_convert] <- lapply(d[cols_to_convert], converter) @@ -290,15 +296,14 @@ d_to_overlap.effectsize_difference <- function(d) { } - - - # From r {rbs} ------------------------------------------------------------ #' @export rb_to_p_superiority.effectsize_difference <- function(rb) { if (!any(colnames(rb) == "r_rank_biserial")) { - insight::format_error("Common language effect size only applicable rank-biserial correlation.") + insight::format_error( + "Common language effect size only applicable rank-biserial correlation." + ) } cols_to_conv <- colnames(rb) %in% c("r_rank_biserial", "CI_low", "CI_high") diff --git a/R/convert_between_d_to_r.R b/R/convert_between_d_to_r.R index 0921e34ff..372cd8c6d 100644 --- a/R/convert_between_d_to_r.R +++ b/R/convert_between_d_to_r.R @@ -83,7 +83,6 @@ oddsratio_to_d <- function(OR, p0, log = FALSE, ...) { return(log_OR * (sqrt(3) / pi)) } - if (log) { OR <- exp(OR) } @@ -118,8 +117,6 @@ d_to_logoddsratio <- function(d, log = TRUE, ...) { } - - # OR - r ---------------------------------------------------------------- #' @rdname d_to_r @@ -156,8 +153,12 @@ r_to_logoddsratio <- function(r, n1, n2, log = TRUE, ...) { return(4) } - if (missing(n1)) n1 <- n2 - if (missing(n2)) n2 <- n1 + if (missing(n1)) { + n1 <- n2 + } + if (missing(n2)) { + n2 <- n1 + } m <- n1 + n2 - 2 m / n1 + m / n2 } diff --git a/R/convert_between_riskchange.R b/R/convert_between_riskchange.R index 393df8011..335963fb6 100644 --- a/R/convert_between_riskchange.R +++ b/R/convert_between_riskchange.R @@ -17,7 +17,7 @@ #' @inheritParams cohens_d #' #' @details -#' If an impossible combination of risk ratio `RR` and baseline risk `p0` is provided, +#' If an impossible combination of risk ratio `RR` and baseline risk `p0` is provided, #' such that `RR * p0 > 1`, then this conversion will produce invalid results where #' the expected risk is larger than 1. In such cases `riskratio_to_*()` functions will return `NA`. #' @@ -60,8 +60,16 @@ oddsratio_to_riskratio <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { } #' @export -oddsratio_to_riskratio.numeric <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { - if (log) OR <- exp(OR) +oddsratio_to_riskratio.numeric <- function( + OR, + p0, + log = FALSE, + verbose = TRUE, + ... +) { + if (log) { + OR <- exp(OR) + } RR <- OR / (1 - p0 + (p0 * OR)) @@ -69,9 +77,21 @@ oddsratio_to_riskratio.numeric <- function(OR, p0, log = FALSE, verbose = TRUE, } #' @export -oddsratio_to_riskratio.default <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { - .model_to_riskchange(OR, p0 = p0, verbose = verbose, - link = "logit", trans = "riskratio", ...) +oddsratio_to_riskratio.default <- function( + OR, + p0, + log = FALSE, + verbose = TRUE, + ... +) { + .model_to_riskchange( + OR, + p0 = p0, + verbose = verbose, + link = "logit", + trans = "riskratio", + ... + ) } #' @rdname oddsratio_to_riskratio @@ -82,15 +102,23 @@ oddsratio_to_arr <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { #' @export oddsratio_to_arr.numeric <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { - if (log) OR <- exp(OR) + if (log) { + OR <- exp(OR) + } RR <- oddsratio_to_riskratio(OR, p0, log = FALSE, verbose = verbose) riskratio_to_arr(RR, p0, verbose = verbose) } #' @export oddsratio_to_arr.default <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { - .model_to_riskchange(OR, p0 = p0, verbose = verbose, - link = "logit", trans = "arr", ...) + .model_to_riskchange( + OR, + p0 = p0, + verbose = verbose, + link = "logit", + trans = "arr", + ... + ) } #' @rdname oddsratio_to_riskratio @@ -107,8 +135,14 @@ oddsratio_to_nnt.numeric <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { #' @export oddsratio_to_nnt.default <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { - .model_to_riskchange(OR, p0 = p0, verbose = verbose, - link = "logit", trans = "nnt", ...) + .model_to_riskchange( + OR, + p0 = p0, + verbose = verbose, + link = "logit", + trans = "nnt", + ... + ) } @@ -116,7 +150,13 @@ oddsratio_to_nnt.default <- function(OR, p0, log = FALSE, verbose = TRUE, ...) { #' @rdname oddsratio_to_riskratio #' @export -logoddsratio_to_riskratio <- function(logOR, p0, log = TRUE, verbose = TRUE, ...) { +logoddsratio_to_riskratio <- function( + logOR, + p0, + log = TRUE, + verbose = TRUE, + ... +) { oddsratio_to_riskratio(logOR, p0, log = log, verbose = verbose) } @@ -135,7 +175,6 @@ logoddsratio_to_nnt <- function(logOR, p0, log = TRUE, verbose = TRUE, ...) { } - # From RR ----------------------------------------------------------------- #' @rdname oddsratio_to_riskratio @@ -145,19 +184,39 @@ riskratio_to_oddsratio <- function(RR, p0, log = FALSE, verbose = TRUE, ...) { } #' @export -riskratio_to_oddsratio.numeric <- function(RR, p0, log = FALSE, verbose = TRUE, ...) { +riskratio_to_oddsratio.numeric <- function( + RR, + p0, + log = FALSE, + verbose = TRUE, + ... +) { p1 <- RR * p0 OR <- RR * (1 - p0) / (1 - p1) OR[p1 > 1] <- NA - if (log) OR <- log(OR) + if (log) { + OR <- log(OR) + } return(OR) } #' @export -riskratio_to_oddsratio.default <- function(RR, p0, log = FALSE, verbose = TRUE, ...) { - .model_to_riskchange(RR, p0 = p0, verbose = verbose, - link = "log", trans = if (log) "logoddsratio" else "oddsratio", ...) +riskratio_to_oddsratio.default <- function( + RR, + p0, + log = FALSE, + verbose = TRUE, + ... +) { + .model_to_riskchange( + RR, + p0 = p0, + verbose = verbose, + link = "log", + trans = if (log) "logoddsratio" else "oddsratio", + ... + ) } #' @rdname oddsratio_to_riskratio @@ -174,8 +233,14 @@ riskratio_to_arr.numeric <- function(RR, p0, verbose = TRUE, ...) { #' @export riskratio_to_arr.default <- function(RR, p0, verbose = TRUE, ...) { - .model_to_riskchange(RR, p0 = p0, verbose = verbose, - link = "log", trans = "arr", ...) + .model_to_riskchange( + RR, + p0 = p0, + verbose = verbose, + link = "log", + trans = "arr", + ... + ) } #' @rdname oddsratio_to_riskratio @@ -198,8 +263,14 @@ riskratio_to_nnt.numeric <- function(RR, p0, verbose = TRUE, ...) { #' @export riskratio_to_nnt.default <- function(RR, p0, verbose = TRUE, ...) { - .model_to_riskchange(RR, p0 = p0, verbose = verbose, - link = "log", trans = "nnt", ...) + .model_to_riskchange( + RR, + p0 = p0, + verbose = verbose, + link = "log", + trans = "nnt", + ... + ) } @@ -262,29 +333,57 @@ nnt_to_arr <- function(NNT, ...) { } - # Utils ------------------------------------------------------------------- #' @keywords internal -.model_to_riskchange <- function(model, p0, - trans = c("oddsratio", "logoddsratio", "riskratio", "nnt", "arr"), - link = c("logit", "log"), - verbose = TRUE, - ...) { +.model_to_riskchange <- function( + model, + p0, + trans = c("oddsratio", "logoddsratio", "riskratio", "nnt", "arr"), + link = c("logit", "log"), + verbose = TRUE, + ... +) { link <- match.arg(link) trans <- match.arg(trans) to_log <- trans == "logoddsratio" - if (to_log) trans <- "oddsratio" - ftrans <- match.fun(paste0(ifelse(link == "logit", "oddsratio", "riskratio"), "_to_", trans)) + if (to_log) { + trans <- "oddsratio" + } + ftrans <- match.fun(paste0( + ifelse(link == "logit", "oddsratio", "riskratio"), + "_to_", + trans + )) mi <- .get_model_info(model, ...) if (!mi$is_binomial || mi$link_function != link) { - insight::format_error(sprintf("Model must be a binomial model with a %s link function.", link)) + insight::format_error(sprintf( + "Model must be a binomial model with a %s link function.", + link + )) } # Coef table - pars <- parameters::model_parameters(model, exponentiate = TRUE, effects = "fixed", ...) - pars[,setdiff(colnames(pars), c("Effects", "Group", "Component", "Parameter", "Coefficient", "CI", "CI_low", "CI_high"))] <- NULL + pars <- parameters::model_parameters( + model, + exponentiate = TRUE, + effects = "fixed", + ... + ) + pars[, setdiff( + colnames(pars), + c( + "Effects", + "Group", + "Component", + "Parameter", + "Coefficient", + "CI", + "CI_low", + "CI_high" + ) + )] <- NULL # p0 if (missing(p0)) { @@ -300,7 +399,10 @@ nnt_to_arr <- function(NNT, ...) { if (verbose) { insight::format_warning( "'p0' not provided:", - sprintf("Computing effect size relative to the intercept (p0 = %.3f);", p0), + sprintf( + "Computing effect size relative to the intercept (p0 = %.3f);", + p0 + ), "Make sure your intercept is meaningful." ) } @@ -308,21 +410,34 @@ nnt_to_arr <- function(NNT, ...) { # transform trans_cols <- intersect(colnames(pars), c("Coefficient", "CI_low", "CI_high")) - pars_out <- datawizard::data_modify(pars, .at = trans_cols, - .modify = function(x) ftrans(x, p0 = p0)) + pars_out <- datawizard::data_modify( + pars, + .at = trans_cols, + .modify = function(x) ftrans(x, p0 = p0) + ) if (trans == "nnt" && "CI" %in% colnames(pars_out)) { for (i in seq_len(nrow(pars_out))) { ci_sign <- unlist(sign(pars_out[i, c("CI_low", "CI_high")])) if (all(ci_sign == 1) || all(ci_sign == -1)) { - pars_out[i, c("CI_low", "CI_high")] <- pars_out[i, c("CI_high", "CI_low")] + pars_out[i, c("CI_low", "CI_high")] <- pars_out[ + i, + c("CI_high", "CI_low") + ] } else { - pars_out[i, c("CI_low", "CI_high")] <- pars_out[i, c("CI_low", "CI_high")] + pars_out[i, c("CI_low", "CI_high")] <- pars_out[ + i, + c("CI_low", "CI_high") + ] } } } if (to_log) { - pars_out <- datawizard::data_modify(pars_out, .at = trans_cols, .modify = log) + pars_out <- datawizard::data_modify( + pars_out, + .at = trans_cols, + .modify = log + ) trans <- "logoddsratio" } @@ -331,12 +446,13 @@ nnt_to_arr <- function(NNT, ...) { pars_out[pars_out$Parameter == "(Intercept)", c("CI_low", "CI_high")] <- NA pars_out[pars_out$Parameter == "(Intercept)", "Parameter"] <- "(p0)" - attr(pars_out, "coefficient_name") <- switch (trans, - "oddsratio" = "Odds ratio", - "logoddsratio" = "log(Odds ratio)", - "riskratio" = "Risk ratio", - "nnt" = "NNT", - "arr" = "ARR" + attr(pars_out, "coefficient_name") <- switch( + trans, + "oddsratio" = "Odds ratio", + "logoddsratio" = "log(Odds ratio)", + "riskratio" = "Risk ratio", + "nnt" = "NNT", + "arr" = "ARR" ) return(pars_out) } diff --git a/R/convert_stat_chisq.R b/R/convert_stat_chisq.R index d7d59870d..a6c200a5e 100644 --- a/R/convert_stat_chisq.R +++ b/R/convert_stat_chisq.R @@ -111,17 +111,28 @@ #' tests to effect sizes for meta-analysis. PloS one, 5(4), e10059. #' #' @export -chisq_to_phi <- function(chisq, n, nrow = 2, ncol = 2, - adjust = TRUE, - ci = 0.95, alternative = "greater", - ...) { +chisq_to_phi <- function( + chisq, + n, + nrow = 2, + ncol = 2, + adjust = TRUE, + ci = 0.95, + alternative = "greater", + ... +) { if ((!missing(nrow) && nrow != 2) || (!missing(ncol) && ncol != 2)) { insight::format_error("Phi is not appropriate for non-2x2 tables.") } - res <- .chisq_to_generic_phi(chisq, n, nrow, ncol, + res <- .chisq_to_generic_phi( + chisq, + n, + nrow, + ncol, adjust = adjust, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, ... ) @@ -139,11 +150,23 @@ chisq_to_phi <- function(chisq, n, nrow = 2, ncol = 2, #' @rdname chisq_to_phi #' @export -chisq_to_cohens_w <- function(chisq, n, nrow, ncol, p, - ci = 0.95, alternative = "greater", - ...) { - res <- .chisq_to_generic_phi(chisq, n, nrow, ncol, - ci = ci, alternative = alternative, +chisq_to_cohens_w <- function( + chisq, + n, + nrow, + ncol, + p, + ci = 0.95, + alternative = "greater", + ... +) { + res <- .chisq_to_generic_phi( + chisq, + n, + nrow, + ncol, + ci = ci, + alternative = alternative, ... ) colnames(res)[1] <- "Cohens_w" @@ -173,24 +196,40 @@ chisq_to_cohens_w <- function(chisq, n, nrow, ncol, p, #' @rdname chisq_to_phi #' @export -chisq_to_cramers_v <- function(chisq, n, nrow, ncol, - adjust = TRUE, - ci = 0.95, alternative = "greater", - ...) { +chisq_to_cramers_v <- function( + chisq, + n, + nrow, + ncol, + adjust = TRUE, + ci = 0.95, + alternative = "greater", + ... +) { if (nrow == 1 || ncol == 1) { insight::format_error("Cramer's V not applicable to goodness-of-fit tests.") } - res <- .chisq_to_generic_phi(chisq, n, nrow, ncol, + res <- .chisq_to_generic_phi( + chisq, + n, + nrow, + ncol, adjust = adjust, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, ... ) # Convert kl <- .possibly_adjust_k_and_l(nrow, ncol, n, adjust = adjust) to_convert <- grepl("^(phi|CI_)", colnames(res)) - res[to_convert] <- lapply(res[to_convert], w_to_v, nrow = kl[["k"]], ncol = kl[["l"]]) + res[to_convert] <- lapply( + res[to_convert], + w_to_v, + nrow = kl[["k"]], + ncol = kl[["l"]] + ) colnames(res)[1] <- gsub("phi", "Cramers_v", colnames(res)[1], fixed = TRUE) if ("CI" %in% colnames(res)) { @@ -205,25 +244,48 @@ chisq_to_cramers_v <- function(chisq, n, nrow, ncol, #' @rdname chisq_to_phi #' @export -chisq_to_tschuprows_t <- function(chisq, n, nrow, ncol, - adjust = TRUE, - ci = 0.95, alternative = "greater", - ...) { +chisq_to_tschuprows_t <- function( + chisq, + n, + nrow, + ncol, + adjust = TRUE, + ci = 0.95, + alternative = "greater", + ... +) { if (nrow == 1 || ncol == 1) { - insight::format_error("Tschuprow's T not applicable to goodness-of-fit tests.") + insight::format_error( + "Tschuprow's T not applicable to goodness-of-fit tests." + ) } - res <- .chisq_to_generic_phi(chisq, n, nrow, ncol, + res <- .chisq_to_generic_phi( + chisq, + n, + nrow, + ncol, adjust = adjust, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, ... ) # Convert kl <- .possibly_adjust_k_and_l(nrow, ncol, n, adjust = adjust) to_convert <- grepl("^(phi|CI_)", colnames(res)) - res[to_convert] <- lapply(res[to_convert], w_to_t, nrow = kl[["k"]], ncol = kl[["l"]]) - colnames(res)[1] <- gsub("phi", "Tschuprows_t", colnames(res)[1], fixed = TRUE) + res[to_convert] <- lapply( + res[to_convert], + w_to_t, + nrow = kl[["k"]], + ncol = kl[["l"]] + ) + colnames(res)[1] <- gsub( + "phi", + "Tschuprows_t", + colnames(res)[1], + fixed = TRUE + ) if ("CI" %in% colnames(res)) { if (attr(res, "alternative") == "greater") { @@ -239,9 +301,16 @@ chisq_to_tschuprows_t <- function(chisq, n, nrow, ncol, #' @rdname chisq_to_phi #' @export #' @param p Vector of expected values. See [stats::chisq.test()]. -chisq_to_fei <- function(chisq, n, nrow, ncol, p, - ci = 0.95, alternative = "greater", - ...) { +chisq_to_fei <- function( + chisq, + n, + nrow, + ncol, + p, + ci = 0.95, + alternative = "greater", + ... +) { if (!missing(nrow) && !missing(ncol)) { if (!1 %in% c(nrow, ncol)) { insight::format_error("Fei is only applicable to goodness of fit tests.") @@ -252,8 +321,13 @@ chisq_to_fei <- function(chisq, n, nrow, ncol, p, } } - res <- .chisq_to_generic_phi(chisq, n, nrow, ncol, - ci = ci, alternative = alternative, + res <- .chisq_to_generic_phi( + chisq, + n, + nrow, + ncol, + ci = ci, + alternative = alternative, ... ) @@ -274,18 +348,32 @@ chisq_to_fei <- function(chisq, n, nrow, ncol, p, is_uniform <- insight::n_unique(p) == 1L if (!is_uniform || max(ncol, nrow) > 2) { attr(res, "table_footer") <- - sprintf("Adjusted for %suniform expected probabilities.", if (is_uniform) "non-" else "") + sprintf( + "Adjusted for %suniform expected probabilities.", + if (is_uniform) "non-" else "" + ) } return(res) } #' @rdname chisq_to_phi #' @export -chisq_to_pearsons_c <- function(chisq, n, nrow, ncol, - ci = 0.95, alternative = "greater", - ...) { - res <- .chisq_to_generic_phi(chisq, n, nrow, ncol, - ci = ci, alternative = alternative, +chisq_to_pearsons_c <- function( + chisq, + n, + nrow, + ncol, + ci = 0.95, + alternative = "greater", + ... +) { + res <- .chisq_to_generic_phi( + chisq, + n, + nrow, + ncol, + ci = ci, + alternative = alternative, ... ) @@ -314,10 +402,16 @@ phi_to_chisq <- function(phi, n, ...) { # Utils ------------------------------------------------------------------ #' @keywords internal -.chisq_to_generic_phi <- function(chisq, n, nrow, ncol, - adjust = FALSE, - ci = NULL, alternative = "greater", - ...) { +.chisq_to_generic_phi <- function( + chisq, + n, + nrow, + ncol, + adjust = FALSE, + ci = NULL, + alternative = "greater", + ... +) { alternative <- .match.alt(alternative, FALSE) ci_numeric <- .test_ci(ci) @@ -337,7 +431,8 @@ phi_to_chisq <- function(phi, n, ...) { res$CI <- ci ci.level <- .adjust_ci(ci, alternative) - chisqs <- vapply(chisq, + chisqs <- vapply( + chisq, .get_ncp_chi, FUN.VALUE = numeric(2), df = df, diff --git a/R/convert_stat_to_anova.R b/R/convert_stat_to_anova.R index 7a95fe1ba..f9044f1af 100644 --- a/R/convert_stat_to_anova.R +++ b/R/convert_stat_to_anova.R @@ -117,48 +117,62 @@ #' Psychological Methods, 9, 164-182. #' #' @export -F_to_eta2 <- function(f, df, df_error, - ci = 0.95, alternative = "greater", - ...) { - .F_to_pve(f, df, df_error, +F_to_eta2 <- function( + f, + df, + df_error, + ci = 0.95, + alternative = "greater", + ... +) { + .F_to_pve( + f, + df, + df_error, es = "eta2", - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, ... ) } #' @rdname F_to_eta2 #' @export -t_to_eta2 <- function(t, df_error, - ci = 0.95, alternative = "greater", - ...) { - F_to_eta2(t^2, 1, df_error, - ci = ci, alternative = alternative, - ... - ) +t_to_eta2 <- function(t, df_error, ci = 0.95, alternative = "greater", ...) { + F_to_eta2(t^2, 1, df_error, ci = ci, alternative = alternative, ...) } #' @rdname F_to_eta2 #' @export -F_to_epsilon2 <- function(f, df, df_error, - ci = 0.95, alternative = "greater", - ...) { - .F_to_pve(f, df, df_error, +F_to_epsilon2 <- function( + f, + df, + df_error, + ci = 0.95, + alternative = "greater", + ... +) { + .F_to_pve( + f, + df, + df_error, es = "epsilon2", - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, ... ) } #' @rdname F_to_eta2 #' @export -t_to_epsilon2 <- function(t, df_error, - ci = 0.95, alternative = "greater", - ...) { - F_to_epsilon2(t^2, 1, df_error, - ci = ci, alternative = alternative, - ... - ) +t_to_epsilon2 <- function( + t, + df_error, + ci = 0.95, + alternative = "greater", + ... +) { + F_to_epsilon2(t^2, 1, df_error, ci = ci, alternative = alternative, ...) } #' @rdname F_to_eta2 @@ -171,43 +185,48 @@ t_to_eta2_adj <- t_to_epsilon2 #' @rdname F_to_eta2 #' @export -F_to_omega2 <- function(f, df, df_error, - ci = 0.95, alternative = "greater", - ...) { - .F_to_pve(f, df, df_error, +F_to_omega2 <- function( + f, + df, + df_error, + ci = 0.95, + alternative = "greater", + ... +) { + .F_to_pve( + f, + df, + df_error, es = "omega2", - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, ... ) } #' @rdname F_to_eta2 #' @export -t_to_omega2 <- function(t, df_error, - ci = 0.95, alternative = "greater", - ...) { - F_to_omega2(t^2, 1, df_error, - ci = ci, alternative = alternative, - ... - ) +t_to_omega2 <- function(t, df_error, ci = 0.95, alternative = "greater", ...) { + F_to_omega2(t^2, 1, df_error, ci = ci, alternative = alternative, ...) } #' @rdname F_to_eta2 #' @param squared Return Cohen's *f* or Cohen's *f*-squared? #' @export -F_to_f <- function(f, df, df_error, - squared = FALSE, - ci = 0.95, alternative = "greater", - ...) { - res_eta <- F_to_eta2(f, df, df_error, - ci = ci, alternative = alternative, - ... - ) +F_to_f <- function( + f, + df, + df_error, + squared = FALSE, + ci = 0.95, + alternative = "greater", + ... +) { + res_eta <- F_to_eta2(f, df, df_error, ci = ci, alternative = alternative, ...) res <- data.frame( - Cohens_f2_partial = - res_eta$Eta2_partial / (1 - res_eta$Eta2_partial) + Cohens_f2_partial = res_eta$Eta2_partial / (1 - res_eta$Eta2_partial) ) ci_method <- NULL @@ -235,53 +254,91 @@ F_to_f <- function(f, df, df_error, #' @rdname F_to_eta2 #' @export -t_to_f <- function(t, df_error, - squared = FALSE, - ci = 0.95, alternative = "greater", - ...) { - F_to_f(t^2, 1, df_error, +t_to_f <- function( + t, + df_error, + squared = FALSE, + ci = 0.95, + alternative = "greater", + ... +) { + F_to_f( + t^2, + 1, + df_error, squared = squared, - ci = ci, alternative = alternative, ... + ci = ci, + alternative = alternative, + ... ) } #' @rdname F_to_eta2 #' @export -F_to_f2 <- function(f, df, df_error, - squared = TRUE, - ci = 0.95, alternative = "greater", - ...) { - F_to_f(f, df, df_error, +F_to_f2 <- function( + f, + df, + df_error, + squared = TRUE, + ci = 0.95, + alternative = "greater", + ... +) { + F_to_f( + f, + df, + df_error, squared = squared, - ci = ci, alternative = alternative, ... + ci = ci, + alternative = alternative, + ... ) } #' @rdname F_to_eta2 #' @export -t_to_f2 <- function(t, df_error, - squared = TRUE, - ci = 0.95, alternative = "greater", - ...) { - F_to_f(t^2, 1, df_error, +t_to_f2 <- function( + t, + df_error, + squared = TRUE, + ci = 0.95, + alternative = "greater", + ... +) { + F_to_f( + t^2, + 1, + df_error, squared = squared, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, ... ) } #' @keywords internal -.F_to_pve <- function(f, df, df_error, - es = "eta2", - ci = 0.95, alternative = "greater", - verbose = TRUE, ...) { +.F_to_pve <- function( + f, + df, + df_error, + es = "eta2", + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative, FALSE) - res <- switch(tolower(es), + res <- switch( + tolower(es), eta2 = data.frame(Eta2_partial = (f * df) / (f * df + df_error)), - epsilon2 = data.frame(Epsilon2_partial = pmax(0, ((f - 1) * df) / (f * df + df_error))), - omega2 = data.frame(Omega2_partial = pmax(0, ((f - 1) * df) / (f * df + df_error + 1))), + epsilon2 = data.frame( + Epsilon2_partial = pmax(0, ((f - 1) * df) / (f * df + df_error)) + ), + omega2 = data.frame( + Omega2_partial = pmax(0, ((f - 1) * df) / (f * df + df_error + 1)) + ), insight::format_error("'es' must be 'eta2', 'epsilon2', or 'omega2'.") ) @@ -294,7 +351,9 @@ t_to_f2 <- function(t, df_error, fs <- t(mapply(.get_ncp_F, f, df, df_error, ci.level)) / df if (isTRUE(verbose) && anyNA(fs)) { - insight::format_warning("Some CIs could not be estimated due to non-finite F, df, or df_error values.") + insight::format_warning( + "Some CIs could not be estimated due to non-finite F, df, or df_error values." + ) } # This really is a generic F_to_R2 diff --git a/R/convert_stat_to_d.R b/R/convert_stat_to_d.R index c2efe5897..39af1affd 100644 --- a/R/convert_stat_to_d.R +++ b/R/convert_stat_to_d.R @@ -1,8 +1,13 @@ #' @rdname t_to_r #' @export -t_to_d <- function(t, df_error, - paired = FALSE, - ci = 0.95, alternative = "two.sided", ...) { +t_to_d <- function( + t, + df_error, + paired = FALSE, + ci = 0.95, + alternative = "two.sided", + ... +) { alternative <- .match.alt(alternative) # Will be 1 if TRUE, and 2 if FALSE @@ -16,7 +21,9 @@ t_to_d <- function(t, df_error, ts <- t(mapply( .get_ncp_t, - t, df_error, ci.level + t, + df_error, + ci.level )) res$CI_low <- paired * ts[, 1] / sqrt(df_error) @@ -36,18 +43,18 @@ t_to_d <- function(t, df_error, } - - # z ----------------------------------------------------------------------- - - #' @rdname t_to_r #' @export -z_to_d <- function(z, n, - paired = FALSE, - ci = 0.95, alternative = "two.sided", - ...) { +z_to_d <- function( + z, + n, + paired = FALSE, + ci = 0.95, + alternative = "two.sided", + ... +) { alternative <- .match.alt(alternative) # Will be 1 if TRUE, and 2 if FALSE @@ -84,21 +91,28 @@ z_to_d <- function(z, n, # F ----------------------------------------------------------------------- - - - #' @rdname t_to_r #' @export -F_to_d <- function(f, df, df_error, - paired = FALSE, - ci = 0.95, alternative = "two.sided", - ...) { +F_to_d <- function( + f, + df, + df_error, + paired = FALSE, + ci = 0.95, + alternative = "two.sided", + ... +) { if (df > 1) { - insight::format_error("Cannot convert F with more than 1 df to (partial) r.") + insight::format_error( + "Cannot convert F with more than 1 df to (partial) r." + ) } - t_to_d(sqrt(f), df_error, + t_to_d( + sqrt(f), + df_error, paired = paired, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, ... ) } diff --git a/R/convert_stat_to_r.R b/R/convert_stat_to_r.R index 77d5c43f7..c20cb1bc1 100644 --- a/R/convert_stat_to_r.R +++ b/R/convert_stat_to_r.R @@ -95,9 +95,7 @@ #' distributions. Educational and Psychological Measurement, 61(4), 532-574. #' #' @export -t_to_r <- function(t, df_error, - ci = 0.95, alternative = "two.sided", - ...) { +t_to_r <- function(t, df_error, ci = 0.95, alternative = "two.sided", ...) { alternative <- .match.alt(alternative) res <- data.frame(r = t / sqrt(t^2 + df_error)) @@ -108,7 +106,9 @@ t_to_r <- function(t, df_error, ts <- t(mapply( .get_ncp_t, - t, df_error, ci.level + t, + df_error, + ci.level )) res$CI_low <- ts[, 1] / sqrt(ts[, 1]^2 + df_error) @@ -129,13 +129,9 @@ t_to_r <- function(t, df_error, # z ----------------------------------------------------------------------- - - #' @rdname t_to_r #' @export -z_to_r <- function(z, n, - ci = 0.95, alternative = "two.sided", - ...) { +z_to_r <- function(z, n, ci = 0.95, alternative = "two.sided", ...) { alternative <- .match.alt(alternative) res <- data.frame(r = z / sqrt(z^2 + n)) @@ -170,14 +166,9 @@ z_to_r <- function(z, n, #' @rdname t_to_r #' @export -F_to_r <- function(f, df, df_error, - ci = 0.95, alternative = "two.sided", - ...) { +F_to_r <- function(f, df, df_error, ci = 0.95, alternative = "two.sided", ...) { if (df > 1) { insight::format_error("Cannot convert F with more than 1 df to r.") } - t_to_r(sqrt(f), df_error, - ci = ci, alternative = alternative, - ... - ) + t_to_r(sqrt(f), df_error, ci = ci, alternative = alternative, ...) } diff --git a/R/datasets.R b/R/datasets.R index 7a6ac62b9..a467f4467 100644 --- a/R/datasets.R +++ b/R/datasets.R @@ -86,8 +86,6 @@ NULL # Tables ------------------------------------------------------------------ - - #' Fictional Results from a Workers' Randomized Control Trial #' #' @docType data diff --git a/R/docs_extra.R b/R/docs_extra.R index cb133e6bc..f523b5b0b 100644 --- a/R/docs_extra.R +++ b/R/docs_extra.R @@ -168,7 +168,6 @@ NULL NULL - #' `effectsize` options #' #' Currently, the following global options are supported: diff --git a/R/effectsize.BFBayesFactor.R b/R/effectsize.BFBayesFactor.R index b0cb7d261..5bd6ede82 100644 --- a/R/effectsize.BFBayesFactor.R +++ b/R/effectsize.BFBayesFactor.R @@ -1,7 +1,14 @@ #' @export #' @rdname effectsize #' @inheritParams bayestestR::describe_posterior -effectsize.BFBayesFactor <- function(model, type = NULL, ci = 0.95, test = NULL, verbose = TRUE, ...) { +effectsize.BFBayesFactor <- function( + model, + type = NULL, + ci = 0.95, + test = NULL, + verbose = TRUE, + ... +) { insight::check_if_installed("BayesFactor") if (length(model) > 1) { @@ -12,15 +19,24 @@ effectsize.BFBayesFactor <- function(model, type = NULL, ci = 0.95, test = NULL, } if (inherits(model@numerator[[1]], "BFcontingencyTable")) { - pars <- .effectsize_contingencyTableBF(model, type = type, verbose = verbose, ...) - } else if (inherits(model@numerator[[1]], c("BFoneSample", "BFindepSample"))) { + pars <- .effectsize_contingencyTableBF( + model, + type = type, + verbose = verbose, + ... + ) + } else if ( + inherits(model@numerator[[1]], c("BFoneSample", "BFindepSample")) + ) { pars <- .effectsize_ttestBF(model, type = type, verbose = verbose) } else if (inherits(model@numerator[[1]], "BFcorrelation")) { pars <- .effectsize_correlationBF(model, type = type, verbose = verbose) } else if (inherits(model@numerator[[1]], "BFproportion")) { pars <- .effectsize_proportionBF(model, type = type, verbose = verbose) } else { - insight::format_error("No effect size for this type of 'BayesFactor' object.") + insight::format_error( + "No effect size for this type of 'BayesFactor' object." + ) } # Clean up @@ -32,7 +48,12 @@ effectsize.BFBayesFactor <- function(model, type = NULL, ci = 0.95, test = NULL, out$Parameter <- NULL } - class(out) <- c(pars$xtra_class, "effectsize_table", "see_effectsize_table", class(out)) + class(out) <- c( + pars$xtra_class, + "effectsize_table", + "see_effectsize_table", + class(out) + ) .someattributes(out) <- pars$attr .someattributes(out) <- list( ci = out$CI, @@ -43,10 +64,19 @@ effectsize.BFBayesFactor <- function(model, type = NULL, ci = 0.95, test = NULL, } #' @keywords internal -.effectsize_contingencyTableBF <- function(model, type = NULL, verbose = TRUE, adjust = TRUE, ...) { - if (is.null(type)) type <- "cramers_v" +.effectsize_contingencyTableBF <- function( + model, + type = NULL, + verbose = TRUE, + adjust = TRUE, + ... +) { + if (is.null(type)) { + type <- "cramers_v" + } - f <- switch(tolower(type), + f <- switch( + tolower(type), v = , cramers_v = cramers_v, t = , @@ -90,7 +120,11 @@ effectsize.BFBayesFactor <- function(model, type = NULL, ci = 0.95, test = NULL, type <- "d" } - samps <- as.data.frame(BayesFactor::posterior(model, iterations = 4000, progress = FALSE)) + samps <- as.data.frame(BayesFactor::posterior( + model, + iterations = 4000, + progress = FALSE + )) paired <- inherits(model@numerator[[1]], "BFoneSample") if (!paired) { @@ -105,11 +139,17 @@ effectsize.BFBayesFactor <- function(model, type = NULL, ci = 0.95, test = NULL, if (type == "d") { xtra_class <- "effectsize_difference" - } else if (tolower(type) %in% c("p_superiority", "u1", "u2", "u3", "overlap")) { - if (paired && type != "p_superiority") insight::format_error("CLES only applicable to two independent samples.") + } else if ( + tolower(type) %in% c("p_superiority", "u1", "u2", "u3", "overlap") + ) { + if (paired && type != "p_superiority") { + insight::format_error("CLES only applicable to two independent samples.") + } converter <- match.fun(paste0("d_to_", tolower(type))) - if (grepl("^(u|U)", type)) type <- paste0("Cohens_", toupper(type)) + if (grepl("^(u|U)", type)) { + type <- paste0("Cohens_", toupper(type)) + } res <- data.frame(converter(res$Cohens_d), check.names = FALSE) colnames(res) <- type diff --git a/R/effectsize.R b/R/effectsize.R index 3c27eab42..f813855e3 100644 --- a/R/effectsize.R +++ b/R/effectsize.R @@ -109,9 +109,12 @@ effectsize <- function(model, ...) { #' @export effectsize.anova <- function(model, type = NULL, ...) { - if (is.null(type)) type <- "eta" + if (is.null(type)) { + type <- "eta" + } - f <- switch(tolower(type), + f <- switch( + tolower(type), eta = , eta2 = , eta_squared = eta_squared, diff --git a/R/effectsize.data_tabulate.R b/R/effectsize.data_tabulate.R index e955b45de..b398b6621 100644 --- a/R/effectsize.data_tabulate.R +++ b/R/effectsize.data_tabulate.R @@ -1,34 +1,40 @@ - # Cross-tab --------------------------------------------------------------- #' @export #' @rdname effectsize #' @param drop Should empty rows/cols be dropped? -effectsize.datawizard_crosstabs <- function(model, type = NULL, - drop = TRUE, - verbose = TRUE, ...) { +effectsize.datawizard_crosstabs <- function( + model, + type = NULL, + drop = TRUE, + verbose = TRUE, + ... +) { tab <- .get_dw_table(model, drop = drop, verbose = verbose) - if (is.null(type)) type <- "cramers_v" - - f <- switch(tolower(type), - v = , - cramers_v = cramers_v, - t = , - tschuprows_t = tschuprows_t, - w = , - cohens_w = cohens_w, - phi = phi, - c = , - pearsons_c = pearsons_c, - or = , - oddsratio = oddsratio, - rr = , - riskratio = riskratio, - h = , - cohens_h = cohens_h, - arr = arr, - nnt = nnt + if (is.null(type)) { + type <- "cramers_v" + } + + f <- switch( + tolower(type), + v = , + cramers_v = cramers_v, + t = , + tschuprows_t = tschuprows_t, + w = , + cohens_w = cohens_w, + phi = phi, + c = , + pearsons_c = pearsons_c, + or = , + oddsratio = oddsratio, + rr = , + riskratio = riskratio, + h = , + cohens_h = cohens_h, + arr = arr, + nnt = nnt ) f(tab, verbose = verbose, ...) @@ -43,19 +49,26 @@ effectsize.datawizard_crosstab <- effectsize.datawizard_crosstabs #' @export #' @rdname effectsize -effectsize.datawizard_tables <- function(model, type = NULL, - drop = TRUE, - verbose = TRUE, ...) { +effectsize.datawizard_tables <- function( + model, + type = NULL, + drop = TRUE, + verbose = TRUE, + ... +) { tab <- .get_dw_table(model, drop = drop, verbose = verbose) - if (is.null(type)) type <- "fei" + if (is.null(type)) { + type <- "fei" + } - f <- switch(tolower(type), - w = , - cohens_w = cohens_w, - c = , - pearsons_c = pearsons_c, - fei = fei + f <- switch( + tolower(type), + w = , + cohens_w = cohens_w, + c = , + pearsons_c = pearsons_c, + fei = fei ) f(tab, verbose = verbose, ...) @@ -70,18 +83,18 @@ effectsize.datawizard_table <- effectsize.datawizard_tables #' @keywords internal .get_dw_table <- function(x, drop = TRUE, verbose = TRUE) { - ltab <- as.table(x, remove_na = drop, - verbose = verbose, simplify = FALSE) + ltab <- as.table(x, remove_na = drop, verbose = verbose, simplify = FALSE) if (length(ltab) > 1L) { - insight::format_error("Multilpe tables not yet supported.", - "Try lapply(model, effectsize, ...).") + insight::format_error( + "Multilpe tables not yet supported.", + "Try lapply(model, effectsize, ...)." + ) } tab <- ltab[[1]] - if (length(dim(tab)) > 1L && isTRUE(drop) && any(tab==0)) { - tab <- tab[rowSums(tab, na.rm = TRUE) > 0, - colSums(tab, na.rm = TRUE) > 0] + if (length(dim(tab)) > 1L && isTRUE(drop) && any(tab == 0)) { + tab <- tab[rowSums(tab, na.rm = TRUE) > 0, colSums(tab, na.rm = TRUE) > 0] } tab diff --git a/R/effectsize.htest.R b/R/effectsize.htest.R index 205862874..bcba7f23f 100644 --- a/R/effectsize.htest.R +++ b/R/effectsize.htest.R @@ -5,7 +5,13 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { .effectsize_t.test(model, type = type, verbose = verbose, ...) } else if (grepl("Pearson's Chi-squared", model$method, fixed = TRUE)) { .effectsize_chisq.test_dep(model, type = type, verbose = verbose, ...) - } else if (grepl("Chi-squared test for given probabilities", model$method, fixed = TRUE)) { + } else if ( + grepl( + "Chi-squared test for given probabilities", + model$method, + fixed = TRUE + ) + ) { .effectsize_chisq.test_gof(model, type = type, verbose = verbose, ...) } else if (grepl("Fisher's Exact", model$method, fixed = TRUE)) { .effectsize_fisher.test(model, type = type, verbose = verbose, ...) @@ -59,7 +65,11 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { } else if (grepl("$", vars, fixed = TRUE)) { # Special case for square bracket subsetting # E.g., x = dat$mpg[dat$am == 1], y = dat$mpg[dat$am == 0] - vars_cols <- gsub("(\\b\\w+\\$)", paste0(match.call()[["data"]], "$"), vars) + vars_cols <- gsub( + "(\\b\\w+\\$)", + paste0(match.call()[["data"]], "$"), + vars + ) columns <- unlist(strsplit(vars_cols, " and ", fixed = TRUE)) x <- eval(parse(text = columns[1])) y <- eval(parse(text = columns[2])) @@ -79,7 +89,9 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { form <- stats::as.formula(paste0(vars, "~1")) data_out <- .resolve_formula(form, ...) } else if (verbose) { - message("To use the `data` argument, consider using modifiers outside the formula.") + message( + "To use the `data` argument, consider using modifiers outside the formula." + ) } } else { data_out <- model_data @@ -95,8 +107,12 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { approx1 <- is.null(data1) - if (is.null(type) || tolower(type) == "cohens_d") type <- "d" - if (tolower(type) == "hedges_g") type <- "g" + if (is.null(type) || tolower(type) == "cohens_d") { + type <- "d" + } + if (tolower(type) == "hedges_g") { + type <- "g" + } cl <- match.call() cl <- cl[-which(names(cl) == "subset")] @@ -145,10 +161,7 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { } if (type %in% c("d", "g")) { - f <- switch(tolower(type), - d = cohens_d, - g = hedges_g - ) + f <- switch(tolower(type), d = cohens_d, g = hedges_g) } else if (dots$paired && startsWith(type, "rm")) { args1[c("x", "y")] <- split(args1$x, args1$y) dots$paired <- args1$pooled_sd <- NULL @@ -156,10 +169,13 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { f <- rm_d } else { if (!dots$paired && !args1$pooled_sd) { - insight::format_error("Common language effect size only applicable to Cohen's d with pooled SD.") + insight::format_error( + "Common language effect size only applicable to Cohen's d with pooled SD." + ) } - f <- switch(tolower(type), + f <- switch( + tolower(type), u1 = cohens_u1, u2 = cohens_u2, u3 = cohens_u3, @@ -176,7 +192,12 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { } #' @keywords internal -.effectsize_chisq.test_dep <- function(model, type = NULL, verbose = TRUE, ...) { +.effectsize_chisq.test_dep <- function( + model, + type = NULL, + verbose = TRUE, + ... +) { # Get data? model_data <- insight::get_data(model) data1 <- .data_from_formula(model_data, model, verbose, ...) @@ -188,15 +209,20 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { Exp <- model$expected if (any(c(colSums(Obs), rowSums(Obs)) == 0L)) { - insight::format_error("Cannot have empty rows/columns in the contingency tables.") + insight::format_error( + "Cannot have empty rows/columns in the contingency tables." + ) } nr <- nrow(Obs) nc <- ncol(Obs) - if (is.null(type)) type <- "cramers_v" + if (is.null(type)) { + type <- "cramers_v" + } if (grepl("(c|v|t|w|phi)$", tolower(type)) && tolower(type) != "nnt") { - f <- switch(tolower(type), + f <- switch( + tolower(type), v = , cramers_v = chisq_to_cramers_v, t = , @@ -217,7 +243,8 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { ... ) } else { - f <- switch(tolower(type), + f <- switch( + tolower(type), or = , oddsratio = oddsratio, rr = , @@ -237,7 +264,9 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { #' @keywords internal .effectsize_fisher.test <- function(model, type = NULL, verbose = TRUE, ...) { - if (is.null(type)) type <- "cramers_v" + if (is.null(type)) { + type <- "cramers_v" + } # If OR - return OR if (tolower(type) %in% c("or", "oddsratio")) { @@ -255,7 +284,8 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { class(out) <- c("effectsize_table", "see_effectsize_table", "data.frame") .someattributes(out) <- .nlist( - ci = out$CI, ci_method, + ci = out$CI, + ci_method, approximate = FALSE, alternative = model[["alternative"]] ) @@ -263,13 +293,18 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { } dots <- list(...) - if (!is.null(model[["conf.int"]])) dots$ci <- attr(model[["conf.int"]], "conf.level") - if (!is.null(model[["alternative"]])) dots$alternative <- model[["alternative"]] + if (!is.null(model[["conf.int"]])) { + dots$ci <- attr(model[["conf.int"]], "conf.level") + } + if (!is.null(model[["alternative"]])) { + dots$alternative <- model[["alternative"]] + } data1 <- insight::get_data(model) .fail_if_approx(is.null(data1), type) - f <- switch(tolower(type), + f <- switch( + tolower(type), v = , cramers_v = cramers_v, t = , @@ -299,7 +334,12 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { } #' @keywords internal -.effectsize_chisq.test_gof <- function(model, type = NULL, verbose = TRUE, ...) { +.effectsize_chisq.test_gof <- function( + model, + type = NULL, + verbose = TRUE, + ... +) { # Get data? model_data <- insight::get_data(model) data1 <- .data_from_formula(model_data, model, verbose, ...) @@ -312,15 +352,20 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { nr <- length(Obs) p <- Exp - if (is.null(type)) type <- "fei" + if (is.null(type)) { + type <- "fei" + } - f <- switch(tolower(type), + f <- switch( + tolower(type), w = , cohens_w = chisq_to_cohens_w, c = , pearsons_c = chisq_to_pearsons_c, fei = chisq_to_fei, - insight::format_error("The selected effect size is not supported for goodness-of-fit tests.") + insight::format_error( + "The selected effect size is not supported for goodness-of-fit tests." + ) ) out <- f( @@ -347,12 +392,17 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { approx1 <- grepl("not assuming", model$method, fixed = TRUE) if (approx1 && verbose) { - insight::format_alert("`var.equal = FALSE` - effect size is an {.b approximation.}") + insight::format_alert( + "`var.equal = FALSE` - effect size is an {.b approximation.}" + ) } - if (is.null(type)) type <- "eta" + if (is.null(type)) { + type <- "eta" + } - f <- switch(tolower(type), + f <- switch( + tolower(type), eta = , eta2 = , eta_squared = F_to_eta2, @@ -407,7 +457,9 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { approx1 <- is.null(data1) - if (is.null(type) || tolower(type) == "rank_biserial") type <- "rb" + if (is.null(type) || tolower(type) == "rank_biserial") { + type <- "rb" + } cl <- match.call() cl <- cl[-which(names(cl) == "subset")] @@ -425,7 +477,8 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { } data1 <- stats::na.omit(data1) - f <- switch(tolower(type), + f <- switch( + tolower(type), rb = rank_biserial, u1 = cohens_u1, u2 = cohens_u2, @@ -444,7 +497,9 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { if (tolower(type) != "rb") { if (dots$paired) { - insight::format_error("Common language effect size only applicable to 2-sample rank-biserial correlation.") + insight::format_error( + "Common language effect size only applicable to 2-sample rank-biserial correlation." + ) } args1$parametric <- FALSE } @@ -461,14 +516,13 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { approx1 <- is.null(data1) - if (is.null(type)) type <- "epsilon" + if (is.null(type)) { + type <- "epsilon" + } .fail_if_approx(approx1, "rank_epsilon_squared") - f <- switch(type, - epsilon = rank_epsilon_squared, - eta = rank_eta_squared - ) + f <- switch(type, epsilon = rank_epsilon_squared, eta = rank_eta_squared) if (inherits(data1, "data.frame")) { out <- f(data1[[1]], data1[[2]], verbose = verbose, ...) @@ -499,7 +553,6 @@ effectsize.htest <- function(model, type = NULL, verbose = TRUE, ...) { # Utils ------------------------------------------------------------------- - #' @keywords internal .chisq <- function(Obs, Exp) { sum(((Obs - Exp)^2) / Exp) diff --git a/R/equivalence_test.R b/R/equivalence_test.R index d415491e0..612aba866 100644 --- a/R/equivalence_test.R +++ b/R/equivalence_test.R @@ -79,9 +79,12 @@ #' } #' #' @export -equivalence_test.effectsize_table <- function(x, - range = "default", - rule = c("classic", "cet", "bayes"), ...) { +equivalence_test.effectsize_table <- function( + x, + range = "default", + rule = c("classic", "cet", "bayes"), + ... +) { rule <- match.arg(rule) if (!all(c("CI", "CI_low", "CI_high") %in% colnames(x))) { @@ -107,14 +110,19 @@ equivalence_test.effectsize_table <- function(x, } range <- sort(range) - if (range[1] < x_es_info$lb) { range[1] <- x_es_info$lb - insight::format_warning(sprintf("Lower bound set to %s.", insight::format_value(range[1]))) + insight::format_warning(sprintf( + "Lower bound set to %s.", + insight::format_value(range[1]) + )) } if (range[2] > x_es_info$ub) { range[2] <- x_es_info$ub - insight::format_warning(sprintf("Upper bound set to %s.", insight::format_value(range[2]))) + insight::format_warning(sprintf( + "Upper bound set to %s.", + insight::format_value(range[2]) + )) } # Test --- @@ -137,7 +145,12 @@ equivalence_test.effectsize_table <- function(x, # x$ROPE_Equivalence[x$CI_low == x$CI_high] <- NA_character_ - class(x) <- c("equivalence_test_effectsize", "effectsize_table", "see_equivalence_test_effectsize", "data.frame") + class(x) <- c( + "equivalence_test_effectsize", + "effectsize_table", + "see_equivalence_test_effectsize", + "data.frame" + ) attr(x, "rope") <- range attr(x, "rule") <- rule return(x) diff --git a/R/eta_squared-main.R b/R/eta_squared-main.R index ee1849323..1e69479e2 100644 --- a/R/eta_squared-main.R +++ b/R/eta_squared-main.R @@ -207,50 +207,101 @@ #' Psychological Methods, 9, 164-182. #' #' @export -eta_squared <- function(model, - partial = TRUE, generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, ...) { +eta_squared <- function( + model, + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative, FALSE) out <- .anova_es( model, type = "eta", partial = partial, generalized = generalized, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose, ... ) - class(out) <- unique(c("effectsize_anova", "effectsize_table", "see_effectsize_table", class(out))) - if ("CI" %in% colnames(out)) attr(out, "ci_method") <- list(method = "ncp", distribution = "F") + class(out) <- unique(c( + "effectsize_anova", + "effectsize_table", + "see_effectsize_table", + class(out) + )) + if ("CI" %in% colnames(out)) { + attr(out, "ci_method") <- list(method = "ncp", distribution = "F") + } attr(out, "approximate") <- isTRUE(attr(out, "approximate", exact = TRUE)) return(out) } #' @rdname eta_squared #' @export -omega_squared <- function(model, - partial = TRUE, - ci = 0.95, alternative = "greater", - verbose = TRUE, ...) { +omega_squared <- function( + model, + partial = TRUE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative, FALSE) - out <- .anova_es(model, type = "omega", partial = partial, ci = ci, alternative = alternative, verbose = verbose, ...) - class(out) <- unique(c("effectsize_anova", "effectsize_table", "see_effectsize_table", class(out))) - if ("CI" %in% colnames(out)) attr(out, "ci_method") <- list(method = "ncp", distribution = "F") + out <- .anova_es( + model, + type = "omega", + partial = partial, + ci = ci, + alternative = alternative, + verbose = verbose, + ... + ) + class(out) <- unique(c( + "effectsize_anova", + "effectsize_table", + "see_effectsize_table", + class(out) + )) + if ("CI" %in% colnames(out)) { + attr(out, "ci_method") <- list(method = "ncp", distribution = "F") + } attr(out, "approximate") <- isTRUE(attr(out, "approximate", exact = TRUE)) return(out) } #' @rdname eta_squared #' @export -epsilon_squared <- function(model, - partial = TRUE, - ci = 0.95, alternative = "greater", - verbose = TRUE, ...) { +epsilon_squared <- function( + model, + partial = TRUE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative, FALSE) - out <- .anova_es(model, type = "epsilon", partial = partial, ci = ci, alternative = alternative, verbose = verbose, ...) - class(out) <- unique(c("effectsize_anova", "effectsize_table", "see_effectsize_table", class(out))) - if ("CI" %in% colnames(out)) attr(out, "ci_method") <- list(method = "ncp", distribution = "F") + out <- .anova_es( + model, + type = "epsilon", + partial = partial, + ci = ci, + alternative = alternative, + verbose = verbose, + ... + ) + class(out) <- unique(c( + "effectsize_anova", + "effectsize_table", + "see_effectsize_table", + class(out) + )) + if ("CI" %in% colnames(out)) { + attr(out, "ci_method") <- list(method = "ncp", distribution = "F") + } attr(out, "approximate") <- isTRUE(attr(out, "approximate", exact = TRUE)) return(out) } @@ -261,33 +312,44 @@ epsilon_squared <- function(model, #' @param model2 Optional second model for Cohen's f (/squared). If specified, #' returns the effect size for R-squared-change between the two models. #' @export -cohens_f <- function(model, - partial = TRUE, generalized = FALSE, - squared = FALSE, - method = c("eta", "omega", "epsilon"), - model2 = NULL, - ci = 0.95, alternative = "greater", - verbose = TRUE, ...) { +cohens_f <- function( + model, + partial = TRUE, + generalized = FALSE, + squared = FALSE, + method = c("eta", "omega", "epsilon"), + model2 = NULL, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative, FALSE) if (!is.null(model2)) { - return(.cohens_f_delta(model, model2, + return(.cohens_f_delta( + model, + model2, squared = squared, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose )) } method <- match.arg(method) - f <- switch(method, + f <- switch( + method, eta = eta_squared, generalized = generalized, omega = omega_squared, epsilon = epsilon_squared ) - res <- f(model, + res <- f( + model, partial = partial, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose, ... ) @@ -305,59 +367,91 @@ cohens_f <- function(model, res$CI_high <- res$CI_high / (1 - res$CI_high) } - if (!squared) { - i <- colnames(res) %in% c("Cohens_f2", "Cohens_f2_partial", "CI_low", "CI_high") + i <- colnames(res) %in% + c("Cohens_f2", "Cohens_f2_partial", "CI_low", "CI_high") res[i] <- sqrt(res[i]) colnames(res)[colnames(res) %in% c("Cohens_f2", "Cohens_f2_partial")] <- if ("Cohens_f2" %in% colnames(res)) "Cohens_f" else "Cohens_f_partial" } - if ("CI" %in% colnames(res)) attr(res, "ci_method") <- list(method = "ncp", distribution = "F") - class(res) <- unique(c("effectsize_anova", "effectsize_table", "see_effectsize_table", class(res))) + if ("CI" %in% colnames(res)) { + attr(res, "ci_method") <- list(method = "ncp", distribution = "F") + } + class(res) <- unique(c( + "effectsize_anova", + "effectsize_table", + "see_effectsize_table", + class(res) + )) attr(res, "approximate") <- isTRUE(attr(res, "approximate", exact = TRUE)) - attr(res, "table_footer") <- if (method != "eta") sprintf("Based on %s squared.", paste0(toupper(substring(method, 1, 1)), substring(method, 2))) + attr(res, "table_footer") <- if (method != "eta") { + sprintf( + "Based on %s squared.", + paste0(toupper(substring(method, 1, 1)), substring(method, 2)) + ) + } res } #' @rdname eta_squared #' @export -cohens_f_squared <- function(model, - partial = TRUE, generalized = FALSE, - squared = TRUE, - method = c("eta", "omega", "epsilon"), - model2 = NULL, - ci = 0.95, alternative = "greater", - verbose = TRUE, ...) { +cohens_f_squared <- function( + model, + partial = TRUE, + generalized = FALSE, + squared = TRUE, + method = c("eta", "omega", "epsilon"), + model2 = NULL, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { cohens_f( model, - partial = partial, generalized = generalized, + partial = partial, + generalized = generalized, squared = squared, method = method, model2 = model2, - ci = ci, alternative = alternative, - verbose = verbose, ... + ci = ci, + alternative = alternative, + verbose = verbose, + ... ) } #' @keywords internal -.cohens_f_delta <- function(model, model2, - squared = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE) { +.cohens_f_delta <- function( + model, + model2, + squared = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE +) { # check - if (!inherits(model, "lm") || - !inherits(model2, "lm") || - !insight::model_info(model)$is_linear || - !insight::model_info(model2)$is_linear) { - insight::format_error("Cohen's f for R2-change only supported for fixed effect linear models.") + if ( + !inherits(model, "lm") || + !inherits(model2, "lm") || + !insight::model_info(model)$is_linear || + !insight::model_info(model2)$is_linear + ) { + insight::format_error( + "Cohen's f for R2-change only supported for fixed effect linear models." + ) } # Anova ANOVA <- stats::anova(model, model2) - out <- F_to_f(ANOVA[2, "F"], abs(ANOVA[2, "Df"]), min(ANOVA["Res.Df"]), - ci = ci, alternative = alternative, + out <- F_to_f( + ANOVA[2, "F"], + abs(ANOVA[2, "Df"]), + min(ANOVA["Res.Df"]), + ci = ci, + alternative = alternative, squared = squared ) @@ -376,12 +470,16 @@ cohens_f_squared <- function(model, #' #' @rdname effectsize_API #' @export -.es_aov_simple <- function(aov_table, - type = c("eta", "omega", "epsilon"), - partial = TRUE, generalized = FALSE, - include_intercept = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE) { +.es_aov_simple <- function( + aov_table, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + include_intercept = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE +) { type <- match.arg(type) aov_table <- as.data.frame(aov_table) @@ -391,14 +489,17 @@ cohens_f_squared <- function(model, } if (!"Residuals" %in% aov_table$Parameter) { - insight::format_error("No residuals data found - cannot compute effect size.") + insight::format_error( + "No residuals data found - cannot compute effect size." + ) } - # Include intercept? --- if (include_intercept) { if (verbose && !"(Intercept)" %in% aov_table$Parameter) { - insight::format_warning("Could not find Sum-of-Squares for the (Intercept) in the ANOVA table.") + insight::format_warning( + "Could not find Sum-of-Squares for the (Intercept) in the ANOVA table." + ) } values <- .values_aov(aov_table[aov_table$Parameter != "(Intercept)", ]) } else { @@ -410,17 +511,25 @@ cohens_f_squared <- function(model, df_error <- aov_table$df[aov_table$Parameter == "Residuals"] aov_table <- aov_table[aov_table$Parameter != "Residuals", , drop = FALSE] - # Validate anova type (1,2,3) and partial --- anova_type <- NULL - if (nrow(aov_table) == 1L && - (partial || isTRUE(generalized) || is.character(generalized))) { + if ( + nrow(aov_table) == 1L && + (partial || isTRUE(generalized) || is.character(generalized)) + ) { if (verbose) { - txt_type <- ifelse(isTRUE(generalized) || is.character(generalized), "generalized", "partial") + txt_type <- ifelse( + isTRUE(generalized) || is.character(generalized), + "generalized", + "partial" + ) insight::format_alert( sprintf( "For one-way between subjects designs, %s %s squared is equivalent to %s squared. Returning %s squared.", - txt_type, type, type, type + txt_type, + type, + type, + type ) ) } @@ -428,9 +537,9 @@ cohens_f_squared <- function(model, anova_type <- NA } - # Estimate effect size --- - if (type == "eta") { # nolint + if (type == "eta") { + # nolint if (isTRUE(generalized) || is.character(generalized)) { ## copied from afex obs <- logical(nrow(aov_table)) @@ -438,7 +547,12 @@ cohens_f_squared <- function(model, for (o in generalized) { oi <- grepl(paste0("\\b", o, "\\b"), aov_table$Parameter) - if (!any(oi)) insight::format_error(sprintf("Observed variable not in data: %s", o)) + if (!any(oi)) { + insight::format_error(sprintf( + "Observed variable not in data: %s", + o + )) + } obs <- obs | oi } @@ -447,11 +561,14 @@ cohens_f_squared <- function(model, obs_SSn2 <- aov_table$Sum_Squares * obs aov_table$Eta2_generalized <- aov_table$Sum_Squares / - (aov_table$Sum_Squares + values$Sum_Squares_residuals + obs_SSn1 - obs_SSn2) + (aov_table$Sum_Squares + + values$Sum_Squares_residuals + + obs_SSn1 - + obs_SSn2) } else if (isTRUE(partial)) { aov_table$Eta2_partial <- aov_table$Sum_Squares / - (aov_table$Sum_Squares + values$Sum_Squares_residuals) + (aov_table$Sum_Squares + values$Sum_Squares_residuals) } else { aov_table$Eta2 <- aov_table$Sum_Squares / values$Sum_Squares_total } @@ -459,24 +576,25 @@ cohens_f_squared <- function(model, if (isTRUE(partial)) { aov_table$Omega2_partial <- (aov_table$Sum_Squares - aov_table$df * values$Mean_Square_residuals) / - (aov_table$Sum_Squares + (values$n - aov_table$df) * values$Mean_Square_residuals) + (aov_table$Sum_Squares + + (values$n - aov_table$df) * values$Mean_Square_residuals) aov_table$Omega2_partial <- pmax(0, aov_table$Omega2_partial) } else { aov_table$Omega2 <- (aov_table$Sum_Squares - aov_table$df * values$Mean_Square_residuals) / - (values$Sum_Squares_total + values$Mean_Square_residuals) + (values$Sum_Squares_total + values$Mean_Square_residuals) aov_table$Omega2 <- pmax(0, aov_table$Omega2) } } else if (type == "epsilon") { if (isTRUE(partial)) { aov_table$Epsilon2_partial <- (aov_table$Sum_Squares - aov_table$df * values$Mean_Square_residuals) / - (aov_table$Sum_Squares + values$Sum_Squares_residuals) + (aov_table$Sum_Squares + values$Sum_Squares_residuals) aov_table$Epsilon2_partial <- pmax(0, aov_table$Epsilon2_partial) } else { aov_table$Epsilon2 <- (aov_table$Sum_Squares - aov_table$df * values$Mean_Square_residuals) / - values$Sum_Squares_total + values$Sum_Squares_total aov_table$Epsilon2 <- pmax(0, aov_table$Epsilon2) } } @@ -490,10 +608,12 @@ cohens_f_squared <- function(model, f <- (ES / out$df) / ((1 - ES) / df_error) CI_tab <- # This really is a generic F_to_R2 - F_to_eta2(f, + F_to_eta2( + f, out$df, df_error, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose )[-1] @@ -502,15 +622,22 @@ cohens_f_squared <- function(model, alternative <- NULL } - # Clean up output --- - out <- out[, colnames(out) %in% c( - "Parameter", - "Eta2", "Eta2_partial", "Eta2_generalized", - "Omega2", "Omega2_partial", - "Epsilon2", "Epsilon2_partial", - if (!is.null(ci)) c("CI", "CI_low", "CI_high") - ), drop = FALSE] + out <- out[, + colnames(out) %in% + c( + "Parameter", + "Eta2", + "Eta2_partial", + "Eta2_generalized", + "Omega2", + "Omega2_partial", + "Epsilon2", + "Epsilon2_partial", + if (!is.null(ci)) c("CI", "CI_low", "CI_high") + ), + drop = FALSE + ] rownames(out) <- NULL out$Parameter <- as.character(out$Parameter) @@ -528,12 +655,17 @@ cohens_f_squared <- function(model, #' #' @rdname effectsize_API #' @export -.es_aov_strata <- function(aov_table, DV_names, - type = c("eta", "omega", "epsilon"), - partial = TRUE, generalized = FALSE, - include_intercept = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE) { +.es_aov_strata <- function( + aov_table, + DV_names, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + include_intercept = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE +) { type <- match.arg(type) aov_table <- as.data.frame(aov_table) @@ -543,33 +675,46 @@ cohens_f_squared <- function(model, } if (!"Residuals" %in% aov_table$Parameter) { - insight::format_error("No residuals data found - cannot compute effect size.") + insight::format_error( + "No residuals data found - cannot compute effect size." + ) } - # Include intercept? --- if (include_intercept) { if (verbose && !"(Intercept)" %in% aov_table$Parameter) { - insight::format_warning("Could not find Sum-of-Squares for the (Intercept) in the ANOVA table.") + insight::format_warning( + "Could not find Sum-of-Squares for the (Intercept) in the ANOVA table." + ) } - values <- .values_aov(aov_table[aov_table$Parameter != "(Intercept)", ], group = TRUE) + values <- .values_aov( + aov_table[aov_table$Parameter != "(Intercept)", ], + group = TRUE + ) } else { aov_table <- aov_table[aov_table$Parameter != "(Intercept)", ] values <- .values_aov(aov_table, group = TRUE) } - # Get all the correct SSs... --- aov_table <- aov_table[aov_table$Parameter != "Residuals", , drop = FALSE] Sum_Squares_total <- sum(sapply(values, "[[", "Sum_Squares_total")) - Sum_Squares_residuals <- sapply(values[aov_table$Group], "[[", "Sum_Squares_residuals") - Mean_Square_residuals <- sapply(values[aov_table$Group], "[[", "Mean_Square_residuals") + Sum_Squares_residuals <- sapply( + values[aov_table$Group], + "[[", + "Sum_Squares_residuals" + ) + Mean_Square_residuals <- sapply( + values[aov_table$Group], + "[[", + "Mean_Square_residuals" + ) df_residuals <- sapply(values[aov_table$Group], "[[", "df_residuals") ns <- sapply(values[aov_table$Group], "[[", "n") - # Estimate effect size --- - if (type == "eta") { # nolint + if (type == "eta") { + # nolint if (isTRUE(generalized) || is.character(generalized)) { ## copied from afex obs <- logical(nrow(aov_table)) @@ -577,7 +722,12 @@ cohens_f_squared <- function(model, for (o in generalized) { oi <- grepl(paste0("\\b", o, "\\b"), aov_table$Parameter) - if (!any(oi)) insight::format_error(sprintf("Observed variable not in data: %s", o)) + if (!any(oi)) { + insight::format_error(sprintf( + "Observed variable not in data: %s", + o + )) + } obs <- obs | oi } @@ -586,12 +736,14 @@ cohens_f_squared <- function(model, obs_SSn2 <- aov_table$Sum_Squares * obs aov_table$Eta2_generalized <- aov_table$Sum_Squares / - (aov_table$Sum_Squares + sum(sapply(values, "[[", "Sum_Squares_residuals")) + - obs_SSn1 - obs_SSn2) + (aov_table$Sum_Squares + + sum(sapply(values, "[[", "Sum_Squares_residuals")) + + obs_SSn1 - + obs_SSn2) } else if (isTRUE(partial)) { aov_table$Eta2_partial <- aov_table$Sum_Squares / - (aov_table$Sum_Squares + Sum_Squares_residuals) + (aov_table$Sum_Squares + Sum_Squares_residuals) } else { aov_table$Eta2 <- aov_table$Sum_Squares / Sum_Squares_total } @@ -605,32 +757,33 @@ cohens_f_squared <- function(model, if (isTRUE(partial)) { aov_table$Omega2_partial <- (aov_table$Sum_Squares - aov_table$df * Mean_Square_residuals) / - (aov_table$Sum_Squares + is_within * Sum_Squares_residuals + - Sum_Squares_Subjects + Mean_Squares_Subjects) + (aov_table$Sum_Squares + + is_within * Sum_Squares_residuals + + Sum_Squares_Subjects + + Mean_Squares_Subjects) aov_table$Omega2_partial <- pmax(0, aov_table$Omega2_partial) } else { aov_table$Omega2 <- (aov_table$Sum_Squares - aov_table$df * Mean_Square_residuals) / - (Sum_Squares_total + Mean_Squares_Subjects) + (Sum_Squares_total + Mean_Squares_Subjects) aov_table$Omega2 <- pmax(0, aov_table$Omega2) } } else if (type == "epsilon") { if (isTRUE(partial)) { aov_table$Epsilon2_partial <- (aov_table$Sum_Squares - aov_table$df * Mean_Square_residuals) / - (aov_table$Sum_Squares + Sum_Squares_residuals) + (aov_table$Sum_Squares + Sum_Squares_residuals) aov_table$Epsilon2_partial <- pmax(0, aov_table$Epsilon2_partial) } else { aov_table$Epsilon2 <- (aov_table$Sum_Squares - aov_table$df * Mean_Square_residuals) / - Sum_Squares_total + Sum_Squares_total aov_table$Epsilon2 <- pmax(0, aov_table$Epsilon2) } } out <- aov_table - # Add CIs --- if (!is.null(ci)) { # based on MBESS::ci.R2 @@ -638,10 +791,12 @@ cohens_f_squared <- function(model, f <- (ES / out$df) / ((1 - ES) / df_residuals) CI_tab <- # This really is a generic F_to_R2 - F_to_eta2(f, + F_to_eta2( + f, out$df, df_residuals, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose )[-1] @@ -650,16 +805,23 @@ cohens_f_squared <- function(model, alternative <- NULL } - # Clean up output --- - out <- out[, colnames(out) %in% c( - "Group", - "Parameter", - "Eta2", "Eta2_generalized", "Eta2_partial", - "Omega2", "Omega2_partial", - "Epsilon2", "Epsilon2_partial", - if (!is.null(ci)) c("CI", "CI_low", "CI_high") - ), drop = FALSE] + out <- out[, + colnames(out) %in% + c( + "Group", + "Parameter", + "Eta2", + "Eta2_generalized", + "Eta2_partial", + "Omega2", + "Omega2_partial", + "Epsilon2", + "Epsilon2_partial", + if (!is.null(ci)) c("CI", "CI_low", "CI_high") + ), + drop = FALSE + ] rownames(out) <- NULL out$Parameter <- as.character(out$Parameter) @@ -672,64 +834,77 @@ cohens_f_squared <- function(model, #' @rdname effectsize_API #' @export -.es_aov_table <- function(aov_table, - type = c("eta", "omega", "epsilon"), - partial = TRUE, generalized = FALSE, - include_intercept = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE) { +.es_aov_table <- function( + aov_table, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + include_intercept = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE +) { aov_table <- as.data.frame(aov_table) # Get correct function --- type <- match.arg(type) - es_fun <- switch(type, + es_fun <- switch( + type, eta = F_to_eta2, omega = F_to_omega2, epsilon = F_to_epsilon2 ) - # Non-Partial / Generalized -> BAD --- if (verbose) { if (!isTRUE(partial)) { insight::format_warning( - sprintf("Currently only supports partial %s squared for this class of objects.", type) + sprintf( + "Currently only supports partial %s squared for this class of objects.", + type + ) ) } if (isTRUE(generalized) || is.character(generalized)) { insight::format_warning( - sprintf("Generalized %s squared is not supported for this class of object.", type) + sprintf( + "Generalized %s squared is not supported for this class of object.", + type + ) ) } } - # Turn ts to Fs (if needed) --- if (!"F" %in% colnames(aov_table)) { if ("t" %in% colnames(aov_table)) { aov_table[["F"]] <- aov_table[["t"]]^2 aov_table[["df"]] <- 1 } else { - insight::format_error("ANOVA table does not have F values - cannot compute effect size.") + insight::format_error( + "ANOVA table does not have F values - cannot compute effect size." + ) } } - # include_intercept? --- if (include_intercept) { if (verbose && !"(Intercept)" %in% aov_table$Parameter) { - insight::format_warning("Could not find F statistic for the (Intercept) in the ANOVA table.") + insight::format_warning( + "Could not find F statistic for the (Intercept) in the ANOVA table." + ) } } else { aov_table <- aov_table[aov_table$Parameter != "(Intercept)", , drop = FALSE] } - - ES_tab <- es_fun(aov_table[["F"]], + ES_tab <- es_fun( + aov_table[["F"]], aov_table[["df"]], aov_table[["df_error"]], - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose ) @@ -751,13 +926,16 @@ cohens_f_squared <- function(model, #' @keywords internal .anova_es <- - function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - ...) { + function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... + ) { UseMethod(".anova_es") } @@ -768,14 +946,17 @@ cohens_f_squared <- function(model, } #' @keywords internal -.anova_es.anova <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - include_intercept = FALSE, - ...) { +.anova_es.anova <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + include_intercept = FALSE, + ... +) { F.nm <- c("F value", "approx F", "F-value", "F") df.nm <- c("NumDF", "num Df", "numDF", "npar", "Df") df_error.nm <- c("DenDF", "den Df", "denDF", "df_error", "Df.res") @@ -783,11 +964,13 @@ cohens_f_squared <- function(model, # If there is no df_error *or* if there IS a residuals row... if (!any(df_error.nm %in% colnames(model))) { # Pass to AOV method - res <- .anova_es.aov(model, + res <- .anova_es.aov( + model, partial = partial, type = type, generalized = generalized, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose, include_intercept = include_intercept, ... @@ -850,14 +1033,17 @@ cohens_f_squared <- function(model, } #' @keywords internal -.anova_es.aov <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - include_intercept = FALSE, - ...) { +.anova_es.aov <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + include_intercept = FALSE, + ... +) { # if (!inherits(model, c("Gam", "anova"))) { # # Pass to ANOVA table method # res <- .anova_es.anova( @@ -881,11 +1067,16 @@ cohens_f_squared <- function(model, es_type = NULL, include_intercept = include_intercept ) - out <- .es_aov_simple(as.data.frame(params), + out <- .es_aov_simple( + as.data.frame(params), type = type, - partial = partial, generalized = generalized, - ci = ci, alternative = alternative, verbose = verbose, - include_intercept = include_intercept, ... + partial = partial, + generalized = generalized, + ci = ci, + alternative = alternative, + verbose = verbose, + include_intercept = include_intercept, + ... ) if (is.null(attr(out, "anova_type"))) { attr(out, "anova_type") <- attr(params, "anova_type") @@ -901,14 +1092,17 @@ cohens_f_squared <- function(model, .anova_es.glm <- .anova_es.lm #' @keywords internal -.anova_es.aovlist <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - include_intercept = FALSE, - ...) { +.anova_es.aovlist <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + include_intercept = FALSE, + ... +) { ## TODO: add back `effects = "fixed"` once the deprecation warning in parameters is removed params <- parameters::model_parameters( model, @@ -928,7 +1122,8 @@ cohens_f_squared <- function(model, type = type, partial = partial, generalized = generalized, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose, include_intercept = include_intercept ) diff --git a/R/eta_squared-methods.R b/R/eta_squared-methods.R index ae30b91c1..0f3969c52 100644 --- a/R/eta_squared-methods.R +++ b/R/eta_squared-methods.R @@ -1,16 +1,23 @@ # Specific tables --------------------------------------------------------- #' @keywords internal -.anova_es.afex_aov <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - include_intercept = FALSE, - ...) { +.anova_es.afex_aov <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + include_intercept = FALSE, + ... +) { type <- match.arg(type) - if (type == "eta" && isTRUE(generalized) && length(attr(model$anova_table, "observed"))) { + if ( + type == "eta" && + isTRUE(generalized) && + length(attr(model$anova_table, "observed")) + ) { generalized <- attr(model$anova_table, "observed") } @@ -20,7 +27,8 @@ type = type, partial = partial, generalized = generalized, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = FALSE, include_intercept = include_intercept, ... @@ -32,21 +40,29 @@ } #' @keywords internal -.anova_es.mixed <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - include_intercept = FALSE, - ...) { +.anova_es.mixed <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + include_intercept = FALSE, + ... +) { aov_tab <- as.data.frame(model[["anova_table"]]) if (!"F" %in% colnames(aov_tab)) { - insight::format_error("Cannot estimate approx effect size for `mixed` type model - no F-statistic found.") + insight::format_error( + "Cannot estimate approx effect size for `mixed` type model - no F-statistic found." + ) } if (verbose && include_intercept && !"(Intercept)" %in% rownames(aov_tab)) { - insight::format_warning("Cannot estimate (Intercept) effect size for `mixed` model.") + insight::format_warning( + "Cannot estimate (Intercept) effect size for `mixed` model." + ) include_intercept <- FALSE } @@ -55,12 +71,16 @@ aov_tab$df_error <- aov_tab[["den Df"]] aov_tab <- aov_tab[, c("Parameter", "df", "df_error", "F")] - out <- .es_aov_table(aov_tab, + out <- .es_aov_table( + aov_tab, type = type, - partial = partial, generalized = generalized, - ci = ci, alternative = alternative, + partial = partial, + generalized = generalized, + ci = ci, + alternative = alternative, verbose = verbose, - include_intercept = include_intercept, ... + include_intercept = include_intercept, + ... ) attr(out, "anova_type") <- attr(model, "type") @@ -70,14 +90,17 @@ #' @keywords internal .anova_es.Anova.mlm <- - function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - include_intercept = FALSE, - ...) { + function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + include_intercept = FALSE, + ... + ) { suppressWarnings({ aov_tab <- summary(model)$univariate.tests }) @@ -87,12 +110,18 @@ # TODO this should be the method for manova, # so this should be copied there, and here happsed to: # .anova_es.manova - aov_tab <- parameters::model_parameters(model, include_intercept = include_intercept) + aov_tab <- parameters::model_parameters( + model, + include_intercept = include_intercept + ) aov_tab$df <- aov_tab$df_num - out <- .anova_es(aov_tab, + out <- .anova_es( + aov_tab, type = type, - partial = partial, generalized = generalized, - ci = ci, alternative = alternative, + partial = partial, + generalized = generalized, + ci = ci, + alternative = alternative, include_intercept = include_intercept, verbose = verbose ) @@ -106,7 +135,13 @@ aov_tab$Parameter <- rownames(aov_tab) colnames(aov_tab)[colnames(aov_tab) == "Sum Sq"] <- "Sum_Squares" colnames(aov_tab)[colnames(aov_tab) == "num Df"] <- "df" - aov_tab <- aov_tab[c("Parameter", "Sum_Squares", "Error SS", "df", "den Df")] + aov_tab <- aov_tab[c( + "Parameter", + "Sum_Squares", + "Error SS", + "df", + "den Df" + )] id <- "Subject" within_subj <- names(model$idata) @@ -137,7 +172,10 @@ aov_tab[["F"]] <- ifelse(aov_tab$Parameter == "Residuals", NA, 1) aov_tab$Mean_Square <- aov_tab$Sum_Squares / aov_tab$df - DV_names <- c(id, setdiff(unlist(strsplit(model$terms, ":", fixed = TRUE)), "(Intercept)")) + DV_names <- c( + id, + setdiff(unlist(strsplit(model$terms, ":", fixed = TRUE)), "(Intercept)") + ) out <- .es_aov_strata( @@ -146,7 +184,8 @@ type = type, partial = partial, generalized = generalized, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose, include_intercept = include_intercept ) @@ -182,19 +221,27 @@ .anova_es.anova.lme <- .anova_es.anova #' @keywords internal -.anova_es.parameters_model <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - by_response = TRUE, - ...) { +.anova_es.parameters_model <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + by_response = TRUE, + ... +) { if (by_response && "Response" %in% colnames(model)) { out <- split(model, model[["Response"]]) - out <- lapply(out, .anova_es.parameters_model, - type = type, partial = partial, generalized = generalized, - ci = ci, alternative = alternative, + out <- lapply( + out, + .anova_es.parameters_model, + type = type, + partial = partial, + generalized = generalized, + ci = ci, + alternative = alternative, verbose = verbose, by_response = FALSE, ... @@ -213,32 +260,45 @@ return(out) } - approximate <- FALSE - if ("Sum_Squares" %in% colnames(model) && "Residuals" %in% model[["Parameter"]]) { + if ( + "Sum_Squares" %in% colnames(model) && "Residuals" %in% model[["Parameter"]] + ) { if ("Group" %in% colnames(model)) { DVs <- unlist(insight::find_predictors(.get_object_from_params(model))) out <- .es_aov_strata( model, DV_names = DVs, - type = type, partial = partial, generalized = generalized, - ci = ci, alternative = alternative, - verbose = verbose, ... + type = type, + partial = partial, + generalized = generalized, + ci = ci, + alternative = alternative, + verbose = verbose, + ... ) } else { out <- .es_aov_simple( model, - type = type, partial = partial, generalized = generalized, - ci = ci, alternative = alternative, - verbose = verbose, ... + type = type, + partial = partial, + generalized = generalized, + ci = ci, + alternative = alternative, + verbose = verbose, + ... ) } } else { out <- .es_aov_table( model, - type = type, partial = partial, generalized = generalized, - ci = ci, alternative = alternative, - verbose = verbose, ... + type = type, + partial = partial, + generalized = generalized, + ci = ci, + alternative = alternative, + verbose = verbose, + ... ) approximate <- TRUE } @@ -250,23 +310,36 @@ # Specific models --------------------------------------------------------- #' @keywords internal -.anova_es.maov <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - ...) { +.anova_es.maov <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { ## TODO: add back `effects = "fixed"` once the deprecation warning in parameters is removed - params <- parameters::model_parameters(model, verbose = verbose, es_type = NULL) + params <- parameters::model_parameters( + model, + verbose = verbose, + es_type = NULL + ) anova_type <- attr(params, "anova_type") - params <- split(params, factor(params$Response, levels = unique(params$Response))) # make sure row order is not changed - params <- lapply(params, .es_aov_simple, + params <- split( + params, + factor(params$Response, levels = unique(params$Response)) + ) # make sure row order is not changed + params <- lapply( + params, + .es_aov_simple, type = type, partial = partial, generalized = generalized, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose, ... ) @@ -293,38 +366,60 @@ #' @keywords internal -.anova_es.htest <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - ...) { +.anova_es.htest <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { if (!grepl("One-way", model$method, fixed = TRUE)) { insight::format_error("'model' is not a one-way test!") } - if (verbose && (partial || isTRUE(generalized) || is.character(generalized))) { - txt_type <- ifelse(isTRUE(generalized) || is.character(generalized), "generalized", "partial") + if ( + verbose && (partial || isTRUE(generalized) || is.character(generalized)) + ) { + txt_type <- ifelse( + isTRUE(generalized) || is.character(generalized), + "generalized", + "partial" + ) insight::format_alert( sprintf( "For one-way between subjects designs, %s %s squared is equivalent to %s squared. Returning %s squared.", - txt_type, type, type, type + txt_type, + type, + type, + type ) ) } - effectsize(model, type = type, ci = ci, alternative = alternative, verbose = verbose, ...) + effectsize( + model, + type = type, + ci = ci, + alternative = alternative, + verbose = verbose, + ... + ) } #' @keywords internal -.anova_es.merMod <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - ...) { +.anova_es.merMod <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { insight::check_if_installed("lmerTest") model <- lmerTest::as_lmerModLmerTest(model) @@ -344,13 +439,16 @@ } #' @keywords internal -.anova_es.gam <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - ...) { +.anova_es.gam <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { model <- stats::anova(model) p.table <- as.data.frame(model$pTerms.table) @@ -371,7 +469,8 @@ type = type, generalized = generalized, partial = partial, - ci = ci, alternative = alternative, + ci = ci, + alternative = alternative, verbose = verbose ) out$Component <- tab$Component @@ -384,13 +483,16 @@ #' @keywords internal -.anova_es.rms <- function(model, - type = c("eta", "omega", "epsilon"), - partial = TRUE, - generalized = FALSE, - ci = 0.95, alternative = "greater", - verbose = TRUE, - ...) { +.anova_es.rms <- function( + model, + type = c("eta", "omega", "epsilon"), + partial = TRUE, + generalized = FALSE, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { if (!inherits(model, "anova.rms")) { model <- stats::anova(model, test = "F") } @@ -440,9 +542,11 @@ NULL } ) - if (is.null(model) || - # prevent self reference - inherits(model, "parameters_model")) { + if ( + is.null(model) || + # prevent self reference + inherits(model, "parameters_model") + ) { model <- tryCatch( { get(obj_name, envir = globalenv()) diff --git a/R/eta_squared_posterior.R b/R/eta_squared_posterior.R index c763a1a75..a8bfbb39b 100644 --- a/R/eta_squared_posterior.R +++ b/R/eta_squared_posterior.R @@ -7,29 +7,35 @@ #' #' @export #' @rdname eta_squared -eta_squared_posterior <- function(model, - partial = TRUE, - generalized = FALSE, - ss_function = stats::anova, - draws = 500, - verbose = TRUE, - ...) { +eta_squared_posterior <- function( + model, + partial = TRUE, + generalized = FALSE, + ss_function = stats::anova, + draws = 500, + verbose = TRUE, + ... +) { UseMethod("eta_squared_posterior") } #' @export -eta_squared_posterior.stanreg <- function(model, - partial = TRUE, - generalized = FALSE, - ss_function = stats::anova, - draws = 500, - verbose = TRUE, - ...) { +eta_squared_posterior.stanreg <- function( + model, + partial = TRUE, + generalized = FALSE, + ss_function = stats::anova, + draws = 500, + verbose = TRUE, + ... +) { insight::check_if_installed("rstantools") mi <- .get_model_info(model, ...) if (!mi$is_linear || mi$is_multivariate) { - insight::format_error("Computation of Eta Squared is only applicable to univariate linear models.") + insight::format_error( + "Computation of Eta Squared is only applicable to univariate linear models." + ) } if (mi$is_mixed) { @@ -56,7 +62,6 @@ eta_squared_posterior.stanreg <- function(model, } } - ## 1. get model data f <- insight::find_formula(model)$conditional X <- insight::get_predictors(model) @@ -66,7 +71,8 @@ eta_squared_posterior.stanreg <- function(model, # if (verbose) .all_centered(X) ## 2. get ppd - ppd <- rstantools::posterior_predict(model, + ppd <- rstantools::posterior_predict( + model, draws = draws, # for rstanreg nsamples = draws # for brms ) @@ -90,7 +96,13 @@ eta_squared_posterior.stanreg <- function(model, ANOVA <- suppressWarnings(ss_function(temp_fit, ...)) } - es <- eta_squared(ANOVA, ci = NULL, partial = partial, generalized = generalized, verbose = verbose) + es <- eta_squared( + ANOVA, + ci = NULL, + partial = partial, + generalized = generalized, + verbose = verbose + ) es <- stats::setNames( es[[if (partial) "Eta2_partial" else "Eta2"]], @@ -107,7 +119,6 @@ eta_squared_posterior.stanreg <- function(model, #' @export eta_squared_posterior.brmsfit <- eta_squared_posterior.stanreg - #' #' @keywords internal #' .all_centered <- function(X) { #' numeric <- sapply(X, inherits, what = c("numeric", "integer")) diff --git a/R/format_standardize.R b/R/format_standardize.R index 365e7916e..fb970f0b3 100644 --- a/R/format_standardize.R +++ b/R/format_standardize.R @@ -16,7 +16,14 @@ #' format_standardize(standardize(mtcars$wt), digits = 1) #' format_standardize(standardize(mtcars$wt, robust = TRUE), digits = 1) #' @export -format_standardize <- function(x, reference = x, robust = FALSE, digits = 1, protect_integers = TRUE, ...) { +format_standardize <- function( + x, + reference = x, + robust = FALSE, + digits = 1, + protect_integers = TRUE, + ... +) { # Check if robust info stored in attributes if ("robust" %in% names(attributes(reference))) { robust <- attributes(reference)$robust @@ -43,7 +50,6 @@ format_standardize <- function(x, reference = x, robust = FALSE, digits = 1, pro deviation <- attributes(reference)$scale } - # Express in deviations if (length(x) != length(reference) || any(x != reference)) { x <- (x - central) / deviation @@ -52,12 +58,14 @@ format_standardize <- function(x, reference = x, robust = FALSE, digits = 1, pro # Round x <- round(x, digits = digits) - # Format vector as character L <- insight::format_value(x, digits = digits, ...) # Complete - L[!grepl("-", L, fixed = TRUE)] <- paste0("+", L[!grepl("-", L, fixed = TRUE)]) + L[!grepl("-", L, fixed = TRUE)] <- paste0( + "+", + L[!grepl("-", L, fixed = TRUE)] + ) L <- paste(L, deviation_name) L[x == 0] <- central_name diff --git a/R/interpret.R b/R/interpret.R index 668780175..5f31c93d9 100644 --- a/R/interpret.R +++ b/R/interpret.R @@ -1,6 +1,5 @@ # Rules --------------------------------------------------------------- - #' Create an Interpretation Grid #' #' Create a container for interpretation rules of thumb. Usually used in conjunction with [interpret]. @@ -73,20 +72,14 @@ rules <- function(values, labels = NULL, name = NULL, right = TRUE) { } - - #' @rdname rules #' @param x An arbitrary R object. #' @export is.rules <- function(x) inherits(x, "rules") - - # Interpret --------------------------------------------------------------- - - #' Generic Function for Interpretation #' #' Interpret a value based on a set of rules. See [rules()]. @@ -143,8 +136,13 @@ interpret <- function(x, ...) { #' @rdname interpret #' @export -interpret.numeric <- function(x, rules, name = attr(rules, "rule_name"), - transform = NULL, ...) { +interpret.numeric <- function( + x, + rules, + name = attr(rules, "rule_name"), + transform = NULL, + ... +) { # This is meant to circumvent https://github.com/easystats/report/issues/442 if (is.character(transform)) { transform <- match.fun(transform) @@ -158,7 +156,9 @@ interpret.numeric <- function(x, rules, name = attr(rules, "rule_name"), rules <- rules(rules) } - if (is.null(name)) name <- "Custom rules" + if (is.null(name)) { + name <- "Custom rules" + } attr(rules, "rule_name") <- name if (length(x_tran) > 1) { @@ -180,7 +180,9 @@ interpret.numeric <- function(x, rules, name = attr(rules, "rule_name"), #' @rdname interpret #' @export interpret.effectsize_table <- function(x, rules, transform = NULL, ...) { - if (missing(rules)) insight::format_error("You {.b must} specify the rules of interpretation!") + if (missing(rules)) { + insight::format_error("You {.b must} specify the rules of interpretation!") + } # This is meant to circumvent https://github.com/easystats/report/issues/442 if (is.character(transform)) { @@ -192,7 +194,8 @@ interpret.effectsize_table <- function(x, rules, transform = NULL, ...) { es_name <- colnames(x)[is_effectsize_name(colnames(x))] value <- transform(x[[es_name]]) - x$Interpretation <- switch(es_name, + x$Interpretation <- switch( + es_name, ## std diff Cohens_d = , Hedges_g = , @@ -233,7 +236,10 @@ interpret.effectsize_table <- function(x, rules, transform = NULL, ...) { Cohens_f = , Cohens_f_partial = interpret_omega_squared(f_to_eta2(value), rules = rules), Cohens_f2 = , - Cohens_f2_partial = interpret_omega_squared(f2_to_eta2(value), rules = rules), + Cohens_f2_partial = interpret_omega_squared( + f2_to_eta2(value), + rules = rules + ), ## Rank r_rank_biserial = interpret_r(value, rules = rules), diff --git a/R/interpret_bf.R b/R/interpret_bf.R index 78c580a01..f82160608 100644 --- a/R/interpret_bf.R +++ b/R/interpret_bf.R @@ -44,32 +44,44 @@ #' #' @keywords interpreters #' @export -interpret_bf <- function(bf, - rules = "jeffreys1961", - log = FALSE, - include_value = FALSE, - protect_ratio = TRUE, - exact = TRUE) { +interpret_bf <- function( + bf, + rules = "jeffreys1961", + log = FALSE, + include_value = FALSE, + protect_ratio = TRUE, + exact = TRUE +) { if (!log && any(bf < 0, na.rm = TRUE)) { - insight::format_error("Negative BFs detected. These are not possible, and are {.i ignored}.") + insight::format_error( + "Negative BFs detected. These are not possible, and are {.i ignored}." + ) } - if (!log) bf <- log(bf) + if (!log) { + bf <- log(bf) + } # interpret strength rules <- .match.rules( rules, list( - jeffreys1961 = rules(c(3, 10, 30, 100), c("anecdotal", "moderate", "strong", "very strong", "extreme"), + jeffreys1961 = rules( + c(3, 10, 30, 100), + c("anecdotal", "moderate", "strong", "very strong", "extreme"), name = "jeffreys1961" ), - raftery1995 = rules(c(3, 20, 150), c("weak", "positive", "strong", "very strong"), + raftery1995 = rules( + c(3, 20, 150), + c("weak", "positive", "strong", "very strong"), name = "raftery1995" ) ) ) - interpretation <- interpret(bf, rules, transform = function(.x) exp(ifelse(.x < 0, -.x, .x))) + interpretation <- interpret(bf, rules, transform = function(.x) { + exp(ifelse(.x < 0, -.x, .x)) + }) interpretation[bf == 0] <- "no" # interpret direction @@ -78,8 +90,17 @@ interpret_bf <- function(bf, # Format text if (include_value) { - bf_fmt <- insight::format_bf(exp(bf), protect_ratio = protect_ratio, exact = exact) - interpretation[] <- sprintf("%s evidence (%s) %s", interpretation, bf_fmt, direction) + bf_fmt <- insight::format_bf( + exp(bf), + protect_ratio = protect_ratio, + exact = exact + ) + interpretation[] <- sprintf( + "%s evidence (%s) %s", + interpretation, + bf_fmt, + direction + ) } else { interpretation[] <- paste0(interpretation, " evidence ", direction) } diff --git a/R/interpret_cfa_fit.R b/R/interpret_cfa_fit.R index 7899005af..3b579fb95 100644 --- a/R/interpret_cfa_fit.R +++ b/R/interpret_cfa_fit.R @@ -123,7 +123,12 @@ interpret_gfi <- function(x, rules = "byrne1994") { rules <- .match.rules( rules, list( - byrne1994 = rules(c(0.95), c("poor", "satisfactory"), name = "byrne1994", right = FALSE) + byrne1994 = rules( + c(0.95), + c("poor", "satisfactory"), + name = "byrne1994", + right = FALSE + ) ) ) @@ -137,7 +142,12 @@ interpret_agfi <- function(x, rules = "byrne1994") { rules <- .match.rules( rules, list( - byrne1994 = rules(c(0.90), c("poor", "satisfactory"), name = "byrne1994", right = FALSE) + byrne1994 = rules( + c(0.90), + c("poor", "satisfactory"), + name = "byrne1994", + right = FALSE + ) ) ) @@ -151,8 +161,18 @@ interpret_nfi <- function(x, rules = "byrne1994") { rules <- .match.rules( rules, list( - byrne1994 = rules(c(0.90), c("poor", "satisfactory"), name = "byrne1994", right = FALSE), - schumacker2004 = rules(c(0.95), c("poor", "satisfactory"), name = "schumacker2004", right = FALSE) + byrne1994 = rules( + c(0.90), + c("poor", "satisfactory"), + name = "byrne1994", + right = FALSE + ), + schumacker2004 = rules( + c(0.95), + c("poor", "satisfactory"), + name = "schumacker2004", + right = FALSE + ) ) ) @@ -170,8 +190,18 @@ interpret_cfi <- function(x, rules = "byrne1994") { rules <- .match.rules( rules, list( - "hu&bentler1999" = rules(c(0.96), c("poor", "satisfactory"), name = "hu&bentler1999", right = FALSE), - "byrne1994" = rules(c(0.90), c("poor", "satisfactory"), name = "byrne1994", right = FALSE) + "hu&bentler1999" = rules( + c(0.96), + c("poor", "satisfactory"), + name = "hu&bentler1999", + right = FALSE + ), + "byrne1994" = rules( + c(0.90), + c("poor", "satisfactory"), + name = "byrne1994", + right = FALSE + ) ) ) @@ -184,7 +214,12 @@ interpret_rfi <- function(x, rules = "default") { rules <- .match.rules( rules, list( - default = rules(c(0.90), c("poor", "satisfactory"), name = "default", right = FALSE) + default = rules( + c(0.90), + c("poor", "satisfactory"), + name = "default", + right = FALSE + ) ) ) @@ -197,7 +232,12 @@ interpret_ifi <- function(x, rules = "default") { rules <- .match.rules( rules, list( - default = rules(c(0.90), c("poor", "satisfactory"), name = "default", right = FALSE) + default = rules( + c(0.90), + c("poor", "satisfactory"), + name = "default", + right = FALSE + ) ) ) @@ -224,7 +264,11 @@ interpret_rmsea <- function(x, rules = "byrne1994") { rules, list( byrne1994 = rules(c(0.05), c("satisfactory", "poor"), name = "byrne1994"), - awang2012 = rules(c(0.05, 0.08), c("good", "satisfactory", "poor"), name = "awang2012") + awang2012 = rules( + c(0.05, 0.08), + c("good", "satisfactory", "poor"), + name = "awang2012" + ) ) ) @@ -257,14 +301,23 @@ interpret.lavaan <- function(x, ...) { #' @export interpret.performance_lavaan <- function(x, ...) { mfits <- c( - "GFI", "AGFI", "NFI", "NNFI", - "CFI", "RMSEA", "SRMR", "RFI", - "IFI", "PNFI" + "GFI", + "AGFI", + "NFI", + "NNFI", + "CFI", + "RMSEA", + "SRMR", + "RFI", + "IFI", + "PNFI" ) mfits <- intersect(names(x), mfits) table <- lapply(mfits, function(ind_name) { - .interpret_ind <- eval(parse(text = paste0("interpret_", tolower(ind_name)))) + .interpret_ind <- eval(parse( + text = paste0("interpret_", tolower(ind_name)) + )) interp <- .interpret_ind(x[[ind_name]]) rules <- attr(interp, "rules") data.frame( diff --git a/R/interpret_cohens_d.R b/R/interpret_cohens_d.R index a87243db0..ba1f2d6c1 100644 --- a/R/interpret_cohens_d.R +++ b/R/interpret_cohens_d.R @@ -66,16 +66,31 @@ interpret_cohens_d <- function(d, rules = "cohen1988", ...) { rules <- .match.rules( rules, list( - cohen1988 = rules(c(0.2, 0.5, 0.8), c("very small", "small", "medium", "large"), - name = "cohen1988", right = FALSE + cohen1988 = rules( + c(0.2, 0.5, 0.8), + c("very small", "small", "medium", "large"), + name = "cohen1988", + right = FALSE ), - sawilowsky2009 = rules(c(0.1, 0.2, 0.5, 0.8, 1.2, 2), - c("tiny", "very small", "small", "medium", "large", "very large", "huge"), - name = "sawilowsky2009", right = FALSE + sawilowsky2009 = rules( + c(0.1, 0.2, 0.5, 0.8, 1.2, 2), + c( + "tiny", + "very small", + "small", + "medium", + "large", + "very large", + "huge" + ), + name = "sawilowsky2009", + right = FALSE ), - lovakov2021 = rules(c(0.15, 0.36, 0.65), + lovakov2021 = rules( + c(0.15, 0.36, 0.65), c("very small", "small", "medium", "large"), - name = "lovakov2021", right = FALSE + name = "lovakov2021", + right = FALSE ), gignac2016 = NA # added for the correct error msg ) diff --git a/R/interpret_cohens_g.R b/R/interpret_cohens_g.R index 3c1418a02..199b74ed2 100644 --- a/R/interpret_cohens_g.R +++ b/R/interpret_cohens_g.R @@ -36,8 +36,11 @@ interpret_cohens_g <- function(g, rules = "cohen1988", ...) { rules <- .match.rules( rules, list( - cohen1988 = rules(c(0.05, 0.15, 0.25), c("very small", "small", "medium", "large"), - name = "cohen1988", right = FALSE + cohen1988 = rules( + c(0.05, 0.15, 0.25), + c("very small", "small", "medium", "large"), + name = "cohen1988", + right = FALSE ) ) ) diff --git a/R/interpret_direction.R b/R/interpret_direction.R index 4b0fc4269..13eeaa7c7 100644 --- a/R/interpret_direction.R +++ b/R/interpret_direction.R @@ -11,7 +11,9 @@ #' @keywords interpreters #' @export interpret_direction <- function(x) { - interpret(x, rules(0, c("negative", "positive"), name = "math", right = FALSE), + interpret( + x, + rules(0, c("negative", "positive"), name = "math", right = FALSE), transform = function(.x) { s <- sign(.x) replace(s, s == 0, NA_real_) diff --git a/R/interpret_ess_rhat.R b/R/interpret_ess_rhat.R index 9207b4fed..6caa1e3a6 100644 --- a/R/interpret_ess_rhat.R +++ b/R/interpret_ess_rhat.R @@ -45,7 +45,12 @@ interpret_ess <- function(ess, rules = "burkner2017") { rules <- .match.rules( rules, list( - burkner2017 = rules(1000, c("insufficient", "sufficient"), name = "burkner2017", right = FALSE) + burkner2017 = rules( + 1000, + c("insufficient", "sufficient"), + name = "burkner2017", + right = FALSE + ) ) ) @@ -53,7 +58,6 @@ interpret_ess <- function(ess, rules = "burkner2017") { } - #' @rdname interpret_ess #' @export interpret_rhat <- function(rhat, rules = "vehtari2019") { diff --git a/R/interpret_icc.R b/R/interpret_icc.R index 362346883..d19eb1767 100644 --- a/R/interpret_icc.R +++ b/R/interpret_icc.R @@ -26,9 +26,11 @@ interpret_icc <- function(icc, rules = "koo2016", ...) { rules <- .match.rules( rules, list( - koo2016 = rules(c(0.5, 0.75, 0.9), + koo2016 = rules( + c(0.5, 0.75, 0.9), c("poor", "moderate", "good", "excellent"), - name = "koo2016", right = FALSE + name = "koo2016", + right = FALSE ) ) ) diff --git a/R/interpret_kendalls_w.R b/R/interpret_kendalls_w.R index 95dbfc794..0b0376d94 100644 --- a/R/interpret_kendalls_w.R +++ b/R/interpret_kendalls_w.R @@ -22,10 +22,14 @@ interpret_kendalls_w <- function(w, rules = "landis1977") { rules <- .match.rules( rules, list( - landis1977 = rules(c(0.2, 0.4, 0.6, 0.8), + landis1977 = rules( + c(0.2, 0.4, 0.6, 0.8), c( - "slight agreement", "fair agreement", "moderate agreement", - "substantial agreement", "almost perfect agreement" + "slight agreement", + "fair agreement", + "moderate agreement", + "substantial agreement", + "almost perfect agreement" ), name = "landis1977", right = FALSE diff --git a/R/interpret_oddsratio.R b/R/interpret_oddsratio.R index 8c65906e6..5642cba9f 100644 --- a/R/interpret_oddsratio.R +++ b/R/interpret_oddsratio.R @@ -37,7 +37,13 @@ #' #' @keywords interpreters #' @export -interpret_oddsratio <- function(OR, rules = "cohen1988", p0 = NULL, log = FALSE, ...) { +interpret_oddsratio <- function( + OR, + rules = "cohen1988", + p0 = NULL, + log = FALSE, + ... +) { if (is.character(rules) && rules == "cohen1988") { d <- oddsratio_to_d(OR, p0, log = log) return(interpret_cohens_d(d, rules = rules)) diff --git a/R/interpret_omega_squared.R b/R/interpret_omega_squared.R index 73287c4ed..0082af54b 100644 --- a/R/interpret_omega_squared.R +++ b/R/interpret_omega_squared.R @@ -36,13 +36,17 @@ interpret_omega_squared <- function(es, rules = "field2013", ...) { rules <- .match.rules( rules, list( - field2013 = rules(c(0.01, 0.06, 0.14), + field2013 = rules( + c(0.01, 0.06, 0.14), c("very small", "small", "medium", "large"), - name = "field2013", right = FALSE + name = "field2013", + right = FALSE ), - cohen1992 = rules(c(0.02, 0.13, 0.26), + cohen1992 = rules( + c(0.02, 0.13, 0.26), c("very small", "small", "medium", "large"), - name = "cohen1992", right = FALSE + name = "cohen1992", + right = FALSE ) ) ) diff --git a/R/interpret_p.R b/R/interpret_p.R index 9f1b7c73f..364f904e3 100644 --- a/R/interpret_p.R +++ b/R/interpret_p.R @@ -32,11 +32,17 @@ interpret_p <- function(p, rules = "default") { rules <- .match.rules( rules, list( - default = rules(0.05, c("significant", "not significant"), - name = "default", right = FALSE + default = rules( + 0.05, + c("significant", "not significant"), + name = "default", + right = FALSE ), - rss = rules(c(0.005, 0.05), c("significant", "suggestive", "not significant"), - name = "rss", right = FALSE + rss = rules( + c(0.005, 0.05), + c("significant", "suggestive", "not significant"), + name = "rss", + right = FALSE ) ) ) diff --git a/R/interpret_pd.R b/R/interpret_pd.R index 305a138a2..12aae3cdf 100644 --- a/R/interpret_pd.R +++ b/R/interpret_pd.R @@ -30,11 +30,23 @@ interpret_pd <- function(pd, rules = "default", ...) { rules <- .match.rules( rules, list( - default = rules(0.975, c("not significant", "significant"), - name = "default", right = TRUE + default = rules( + 0.975, + c("not significant", "significant"), + name = "default", + right = TRUE ), - makowski2019 = rules(c(0.95, 0.97, 0.99, 0.999), c("uncertain", "possibly existing", "likely existing", "probably existing", "certainly existing"), - name = "makowski2019", right = TRUE + makowski2019 = rules( + c(0.95, 0.97, 0.99, 0.999), + c( + "uncertain", + "possibly existing", + "likely existing", + "probably existing", + "certainly existing" + ), + name = "makowski2019", + right = TRUE ) ) ) diff --git a/R/interpret_r.R b/R/interpret_r.R index bc3bbe24b..49d96d9ed 100644 --- a/R/interpret_r.R +++ b/R/interpret_r.R @@ -83,25 +83,35 @@ interpret_r <- function(r, rules = "funder2019", ...) { rules <- .match.rules( rules, list( - funder2019 = rules(c(0.05, 0.1, 0.2, 0.3, 0.4), + funder2019 = rules( + c(0.05, 0.1, 0.2, 0.3, 0.4), c("tiny", "very small", "small", "medium", "large", "very large"), - name = "funder2019", right = FALSE + name = "funder2019", + right = FALSE ), - gignac2016 = rules(c(0.1, 0.2, 0.3), + gignac2016 = rules( + c(0.1, 0.2, 0.3), c("very small", "small", "moderate", "large"), - name = "gignac2016", right = FALSE + name = "gignac2016", + right = FALSE ), - cohen1988 = rules(c(0.1, 0.3, 0.5), + cohen1988 = rules( + c(0.1, 0.3, 0.5), c("very small", "small", "moderate", "large"), - name = "cohen1988", right = FALSE + name = "cohen1988", + right = FALSE ), - evans1996 = rules(c(0.2, 0.4, 0.6, 0.8), + evans1996 = rules( + c(0.2, 0.4, 0.6, 0.8), c("very weak", "weak", "moderate", "strong", "very strong"), - name = "evans1996", right = FALSE + name = "evans1996", + right = FALSE ), - lovakov2021 = rules(c(0.12, 0.24, 0.41), + lovakov2021 = rules( + c(0.12, 0.24, 0.41), c("very small", "small", "medium", "large"), - name = "lovakov2021", right = FALSE + name = "lovakov2021", + right = FALSE ) ) ) diff --git a/R/interpret_r2.R b/R/interpret_r2.R index f8cb9ea0d..408730228 100644 --- a/R/interpret_r2.R +++ b/R/interpret_r2.R @@ -52,17 +52,29 @@ interpret_r2 <- function(r2, rules = "cohen1988") { rules <- .match.rules( rules, list( - cohen1988 = rules(c(0.02, 0.13, 0.26), c("very weak", "weak", "moderate", "substantial"), - name = "cohen1988", right = FALSE + cohen1988 = rules( + c(0.02, 0.13, 0.26), + c("very weak", "weak", "moderate", "substantial"), + name = "cohen1988", + right = FALSE ), - falk1992 = rules(0.10, c("negligible", "adequate"), - name = "falk1992", right = FALSE + falk1992 = rules( + 0.10, + c("negligible", "adequate"), + name = "falk1992", + right = FALSE ), - chin1998 = rules(c(0.19, 0.33, 0.67), c("very weak", "weak", "moderate", "substantial"), - name = "chin1998", right = FALSE + chin1998 = rules( + c(0.19, 0.33, 0.67), + c("very weak", "weak", "moderate", "substantial"), + name = "chin1998", + right = FALSE ), - hair2011 = rules(c(0.25, 0.50, 0.75), c("very weak", "weak", "moderate", "substantial"), - name = "hair2011", right = FALSE + hair2011 = rules( + c(0.25, 0.50, 0.75), + c("very weak", "weak", "moderate", "substantial"), + name = "hair2011", + right = FALSE ) ) ) diff --git a/R/interpret_rope.R b/R/interpret_rope.R index 21860dd8c..91475feba 100644 --- a/R/interpret_rope.R +++ b/R/interpret_rope.R @@ -34,16 +34,20 @@ interpret_rope <- function(rope, rules = "default", ci = 0.9) { if (ci < 1) { e <- .Machine$double.eps - default_rule <- rules(c(0, 0 + e, 1 - e, 1), + default_rule <- rules( + c(0, 0 + e, 1 - e, 1), c("significant", "undecided", "undecided", "negligible"), name = "default" ) } else { - default_rule <- rules(c(0.01, 0.025, 0.975, 0.99), + default_rule <- rules( + c(0.01, 0.025, 0.975, 0.99), c( - "significant", "probably significant", + "significant", + "probably significant", "undecided", - "probably negligible", "negligible" + "probably negligible", + "negligible" ), name = "default" ) diff --git a/R/interpret_vif.R b/R/interpret_vif.R index c955b7660..13d697208 100644 --- a/R/interpret_vif.R +++ b/R/interpret_vif.R @@ -22,9 +22,11 @@ interpret_vif <- function(vif, rules = "default") { rules <- .match.rules( rules, list( - default = rules(c(5, 10), + default = rules( + c(5, 10), c("low", "moderate", "high"), - name = "default", right = FALSE + name = "default", + right = FALSE ) ) ) diff --git a/R/is_effectsize_name.R b/R/is_effectsize_name.R index 57e293767..ac893794b 100644 --- a/R/is_effectsize_name.R +++ b/R/is_effectsize_name.R @@ -26,7 +26,11 @@ get_effectsize_name <- function(x, ignore_case = TRUE) { #' @export #' @rdname is_effectsize_name -get_effectsize_label <- function(x, ignore_case = TRUE, use_symbols = getOption("es.use_symbols", FALSE)) { +get_effectsize_label <- function( + x, + ignore_case = TRUE, + use_symbols = getOption("es.use_symbols", FALSE) +) { x_comp <- es_info$name use_symbols <- .resolve_use_symbols(use_symbols) @@ -46,7 +50,6 @@ get_effectsize_label <- function(x, ignore_case = TRUE, use_symbols = getOption( # Utils ------------------------------------------------------------------- - #' @keywords internal .resolve_use_symbols <- function(use_symbols) { use_symbols && l10n_info()[["UTF-8"]] diff --git a/R/mahalanobis_D.R b/R/mahalanobis_D.R index c365b4519..73d4763b2 100644 --- a/R/mahalanobis_D.R +++ b/R/mahalanobis_D.R @@ -81,35 +81,49 @@ #' ) #' #' @export -mahalanobis_d <- function(x, y = NULL, data = NULL, - pooled_cov = TRUE, mu = 0, - ci = 0.95, alternative = "greater", - verbose = TRUE, ...) { +mahalanobis_d <- function( + x, + y = NULL, + data = NULL, + pooled_cov = TRUE, + mu = 0, + ci = 0.95, + alternative = "greater", + verbose = TRUE, + ... +) { # TODO add paired samples case DV1 + DV2 ~ 1 | ID alternative <- .match.alt(alternative, FALSE) data <- .get_data_multivariate(x, y, data, verbose = verbose, ...) x <- data[["x"]] y <- data[["y"]] - # deal with mu if (is.vector(mu)) { if (length(mu) == 1L) { mu <- rep(mu, length.out = ncol(x)) names(mu) <- colnames(x) } else if (length(mu) != ncol(x) || is.null(names(mu))) { - insight::format_error("mu must be of length 1 or a named vector/list of length ncol(x).") + insight::format_error( + "mu must be of length 1 or a named vector/list of length ncol(x)." + ) } mu <- as.list(mu) } if (!is.list(mu)) { - insight::format_error("mu must be of length 1 or a named vector/list of length ncol(x).") + insight::format_error( + "mu must be of length 1 or a named vector/list of length ncol(x)." + ) } else if (!all(names(mu) == colnames(x))) { - insight::format_error("x,y must have the same variables (in the same order)") + insight::format_error( + "x,y must have the same variables (in the same order)" + ) } else if (!all(lengths(mu) == 1L) || !all(vapply(mu, is.numeric, TRUE))) { - insight::format_error("Each element of mu must be a numeric vector of length 1.") + insight::format_error( + "Each element of mu must be a numeric vector of length 1." + ) } mu <- unlist(mu) @@ -160,11 +174,18 @@ mahalanobis_d <- function(x, y = NULL, data = NULL, ci_method <- alternative <- NULL } - class(out) <- c("effectsize_difference", "effectsize_table", "see_effectsize_table", class(out)) + class(out) <- c( + "effectsize_difference", + "effectsize_table", + "see_effectsize_table", + class(out) + ) .someattributes(out) <- .nlist( pooled_cov, mu = sqrt(sum(mu^2)), - ci, ci_method, alternative, + ci, + ci_method, + alternative, approximate = FALSE ) return(out) diff --git a/R/means_ratio.R b/R/means_ratio.R index e2652f77b..a68239a98 100644 --- a/R/means_ratio.R +++ b/R/means_ratio.R @@ -61,17 +61,28 @@ #' \doi{10.1890/0012-9658(1999)080[1150:TMAORR]2.0.CO;2} #' #' @export -means_ratio <- function(x, y = NULL, data = NULL, - paired = FALSE, adjust = TRUE, log = FALSE, - reference = NULL, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +means_ratio <- function( + x, + y = NULL, + data = NULL, + paired = FALSE, + adjust = TRUE, + log = FALSE, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative) ## Prep data out <- .get_data_2_samples( - x = x, y = y, data = data, - paired = paired, reference = reference, + x = x, + y = y, + data = data, + paired = paired, + reference = reference, verbose = verbose, ... ) @@ -80,7 +91,9 @@ means_ratio <- function(x, y = NULL, data = NULL, paired <- out[["paired"]] if (is.null(y)) { - insight::format_error("Only one sample provided. y or data must be provided.") + insight::format_error( + "Only one sample provided. y or data must be provided." + ) } if (any(x < 0) || any(y < 0)) { @@ -94,10 +107,11 @@ means_ratio <- function(x, y = NULL, data = NULL, sd2 <- stats::sd(y) if (isTRUE(all.equal(m1, 0)) || isTRUE(all.equal(m2, 0))) { - insight::format_error("Mean(s) equal to equal zero. Unable to calculate means ratio.") + insight::format_error( + "Mean(s) equal to equal zero. Unable to calculate means ratio." + ) } - if (paired) { ## ------------------ paired case ------------------- df1 <- n <- length(x) @@ -148,7 +162,8 @@ means_ratio <- function(x, y = NULL, data = NULL, SE <- sqrt(log_val[["var_rom"]]) # Normal approx - interval <- log_val[["log_rom"]] + c(-1, 1) * stats::qnorm(alpha / 2, lower.tail = FALSE) * SE + interval <- log_val[["log_rom"]] + + c(-1, 1) * stats::qnorm(alpha / 2, lower.tail = FALSE) * SE ci_method <- list(method = "normal") @@ -170,9 +185,17 @@ means_ratio <- function(x, y = NULL, data = NULL, colnames(out)[1] <- gsub("log_", "", colnames(out)[1], fixed = TRUE) } - class(out) <- c("effectsize_difference", "effectsize_table", "see_effectsize_table", class(out)) + class(out) <- c( + "effectsize_difference", + "effectsize_table", + "see_effectsize_table", + class(out) + ) .someattributes(out) <- .nlist( - paired, ci, ci_method, alternative, + paired, + ci, + ci_method, + alternative, mu = 0, approximate = TRUE ) @@ -181,19 +204,22 @@ means_ratio <- function(x, y = NULL, data = NULL, #' @keywords internal -.logrom_calc <- function(m1, - sd1, - n1, - m2, - sd2, - n2 = n1, - r = NULL, - adjust = TRUE, - paired = FALSE) { +.logrom_calc <- function( + m1, + sd1, + n1, + m2, + sd2, + n2 = n1, + r = NULL, + adjust = TRUE, + paired = FALSE +) { if (isTRUE(paired)) { y_i <- log(m1 / m2) v_i <- - sd1^2 / (n1 * m1^2) + + sd1^2 / + (n1 * m1^2) + sd2^2 / (n1 * m2^2) - 2 * r * sd1 * sd2 / (m1 * m2 * n1) } else { @@ -202,7 +228,6 @@ means_ratio <- function(x, y = NULL, data = NULL, v_i <- sd1^2 / (n1 * m1^2) + sd2^2 / (n2 * m2^2) } - if (isTRUE(adjust)) { J <- 0.5 * (sd1^2 / (n1 * m1^2) - sd2^2 / (n2 * m2^2)) y_i <- y_i + J @@ -211,7 +236,6 @@ means_ratio <- function(x, y = NULL, data = NULL, v_i <- v_i + Jvar } - list( log_rom = y_i, var_rom = v_i diff --git a/R/pooled.R b/R/pooled.R index 44776477b..a1ea11e1c 100644 --- a/R/pooled.R +++ b/R/pooled.R @@ -29,7 +29,9 @@ sd_pooled <- function(x, y = NULL, data = NULL, verbose = TRUE, ...) { x <- data[["x"]] y <- data[["y"]] if (is.null(y) || isTRUE(match.call()$paired) || isTRUE(data[["paired"]])) { - insight::format_error("This effect size is only applicable for two independent samples.") + insight::format_error( + "This effect size is only applicable for two independent samples." + ) } V <- cov_pooled( @@ -40,17 +42,23 @@ sd_pooled <- function(x, y = NULL, data = NULL, verbose = TRUE, ...) { } - #' @rdname sd_pooled #' @export -mad_pooled <- function(x, y = NULL, data = NULL, - constant = 1.4826, - verbose = TRUE, ...) { +mad_pooled <- function( + x, + y = NULL, + data = NULL, + constant = 1.4826, + verbose = TRUE, + ... +) { data <- .get_data_2_samples(x, y, data, verbose = verbose, ...) x <- data[["x"]] y <- data[["y"]] if (is.null(y) || isTRUE(match.call()$paired) || isTRUE(data[["paired"]])) { - insight::format_error("This effect size is only applicable for two independent samples.") + insight::format_error( + "This effect size is only applicable for two independent samples." + ) } n1 <- length(x) @@ -66,8 +74,7 @@ mad_pooled <- function(x, y = NULL, data = NULL, #' @rdname sd_pooled #' @export -cov_pooled <- function(x, y = NULL, data = NULL, - verbose = TRUE, ...) { +cov_pooled <- function(x, y = NULL, data = NULL, verbose = TRUE, ...) { data <- .get_data_multivariate(x, y, data = data, verbose = verbose) x <- data[["x"]] y <- data[["y"]] diff --git a/R/print.effectsize_table.R b/R/print.effectsize_table.R index 8af3354c4..bbd1aebe8 100644 --- a/R/print.effectsize_table.R +++ b/R/print.effectsize_table.R @@ -15,22 +15,43 @@ #' @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, ...) +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), ...) { +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), ...) { +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", ...) } @@ -39,7 +60,13 @@ print_html.effectsize_table <- function(x, digits = 2, use_symbols = getOption(" #' @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), ...) { +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 @@ -49,8 +76,10 @@ format.effectsize_table <- function(x, digits = 2, output = c("text", "markdown" 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_)))) { + if ( + !is.character(digits) && + !isTRUE(all.equal(bound, as.numeric(bound_))) + ) { bound_ <- paste0(bound_, "~") } @@ -58,7 +87,8 @@ format.effectsize_table <- function(x, digits = 2, output = c("text", "markdown" ci_footer <- sprintf( "One-sided CIs: %s bound fixed at [%s].", - side, bound_ + side, + bound_ ) footer <- c(footer, ci_footer) } @@ -81,7 +111,6 @@ format.effectsize_table <- function(x, digits = 2, output = c("text", "markdown" } attr(x, "table_footer") <- footer - ## Clean caption caption <- attr(x, "table_caption") if (output == "text" && !is.null(caption)) { @@ -89,7 +118,6 @@ format.effectsize_table <- function(x, digits = 2, output = c("text", "markdown" } attr(x, "table_caption") <- caption - ## Clean subtitle subtitle <- attr(x, "table_subtitle") if (output == "text" && !is.null(subtitle)) { @@ -97,7 +125,6 @@ format.effectsize_table <- function(x, digits = 2, output = c("text", "markdown" } attr(x, "table_subtitle") <- subtitle - ## Clean column names i <- is_effectsize_name(colnames(x)) labs <- get_effectsize_label(colnames(x), use_symbols = use_symbols) @@ -106,9 +133,12 @@ format.effectsize_table <- function(x, digits = 2, output = c("text", "markdown" attr(x, "ci") <- NULL attr(x, "ci_method") <- NULL - insight::format_table(x, - digits = digits, ci_digits = digits, - preserve_attributes = TRUE, ... + insight::format_table( + x, + digits = digits, + ci_digits = digits, + preserve_attributes = TRUE, + ... ) } @@ -121,7 +151,12 @@ format.effectsize_table <- function(x, digits = 2, output = c("text", "markdown" #' 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, ...) { +print.effectsize_difference <- function( + x, + digits = 2, + append_CLES = NULL, + ... +) { x_orig <- x print.effectsize_table(x, digits = digits, ...) @@ -150,7 +185,10 @@ print.effectsize_difference <- function(x, digits = 2, append_CLES = NULL, ...) insight::format_error("CLES not applicable for this effect size.") } - insight::print_color("\n\n## Common Language Effect Sizes:\n", .pcl["subtitle"]) + insight::print_color( + "\n\n## Common Language Effect Sizes:\n", + .pcl["subtitle"] + ) print(cles_tab, digits = digits, ...) } @@ -233,13 +271,11 @@ format.equivalence_test_effectsize <- function(x, digits = 2, ...) { } 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" @@ -254,6 +290,11 @@ format.equivalence_test_effectsize <- function(x, digits = 2, ...) { # Colors ------------------------------------------------------------------ -.pcl <- c(title = "blue", subtitle = "blue", footer = "cyan", interpret = "italic") +.pcl <- c( + title = "blue", + subtitle = "blue", + footer = "cyan", + interpret = "italic" +) # "red", "yellow", "green", "blue", "violet","cyan", "grey", "bold", "italic" diff --git a/R/print.rules.R b/R/print.rules.R index 89b2c8259..a8bf092e5 100644 --- a/R/print.rules.R +++ b/R/print.rules.R @@ -3,9 +3,21 @@ print.rules <- function(x, digits = "signif2", ...) { x_fmt <- format(x, digits = digits, ...) if (length(x$values) == length(x$labels)) { - cat(insight::export_table(x_fmt, align = "rl", format = NULL, sep = " ~ ", ...)) + cat(insight::export_table( + x_fmt, + align = "rl", + format = NULL, + sep = " ~ ", + ... + )) } else { - cat(insight::export_table(x_fmt, align = "rcl", format = NULL, sep = " ", ...)) + cat(insight::export_table( + x_fmt, + align = "rcl", + format = NULL, + sep = " ", + ... + )) } invisible(x) } @@ -35,7 +47,6 @@ print_html.rules <- function(x, digits = "signif2", ...) { } - #' @export format.rules <- function(x, digits = "signif2", output = "text", ...) { name <- attr(x, "rule_name") diff --git a/R/r2_semipartial.R b/R/r2_semipartial.R index b2231f07a..05700e455 100644 --- a/R/r2_semipartial.R +++ b/R/r2_semipartial.R @@ -87,16 +87,24 @@ #' parameters::dominance_analysis(m_full) #' #' @export -r2_semipartial <- function(model, type = c("terms", "parameters"), - ci = 0.95, alternative = "greater", - ...) { +r2_semipartial <- function( + model, + type = c("terms", "parameters"), + ci = 0.95, + alternative = "greater", + ... +) { UseMethod("r2_semipartial") } #' @export -r2_semipartial.lm <- function(model, type = c("terms", "parameters"), - ci = 0.95, alternative = "greater", - ...) { +r2_semipartial.lm <- function( + model, + type = c("terms", "parameters"), + ci = 0.95, + alternative = "greater", + ... +) { type <- match.arg(type) alternative <- .match.alt(alternative, FALSE) @@ -117,10 +125,18 @@ r2_semipartial.lm <- function(model, type = c("terms", "parameters"), idx_sub <- idx[Parameter != "(Intercept)"] } - tot_mod <- stats::lm(stats::reformulate("mm", response = "y", intercept = has_incpt)) + tot_mod <- stats::lm(stats::reformulate( + "mm", + response = "y", + intercept = has_incpt + )) sub_mods <- lapply(unique(idx_sub), function(.i) { - f <- stats::reformulate("mm[, .i != idx]", response = "y", intercept = has_incpt) + f <- stats::reformulate( + "mm[, .i != idx]", + response = "y", + intercept = has_incpt + ) stats::lm(f) }) @@ -186,7 +202,14 @@ r2_semipartial.lm <- function(model, type = c("terms", "parameters"), rhor <- sqrt(R2r) rhof <- sqrt(R2f) - (4 * rhof * rhor * (0.5 * (2 * rhor / rhof - rhor * rhof) * (1 - R2f - R2r - R2r / R2f) + (rhor / rhof)^3)) / N + (4 * + rhof * + rhor * + (0.5 * + (2 * rhor / rhof - rhor * rhof) * + (1 - R2f - R2r - R2r / R2f) + + (rhor / rhof)^3)) / + N } #' @keywords internal diff --git a/R/rank_ANOVA.R b/R/rank_ANOVA.R index f4ee4abb7..26ba3ab27 100644 --- a/R/rank_ANOVA.R +++ b/R/rank_ANOVA.R @@ -85,31 +85,56 @@ #' sport sciences, 1(21), 19-25. #' #' @export -rank_epsilon_squared <- function(x, groups, data = NULL, - ci = 0.95, alternative = "greater", - iterations = 200, - verbose = TRUE, ...) { +rank_epsilon_squared <- function( + x, + groups, + data = NULL, + ci = 0.95, + alternative = "greater", + iterations = 200, + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative, FALSE) if (.is_htest_of_type(x, "Kruskal-Wallis", "Kruskal-Wallis-test")) { - return(effectsize(x, type = "epsilon", ci = ci, iterations = iterations, alternative = alternative)) + return(effectsize( + x, + type = "epsilon", + ci = ci, + iterations = iterations, + alternative = alternative + )) } ## pep data - data <- .get_data_multi_group(x, groups, data, + data <- .get_data_multi_group( + x, + groups, + data, allow_ordered = TRUE, - verbose = verbose, ... + verbose = verbose, + ... ) ## compute out <- data.frame(rank_epsilon_squared = .repsilon(data)) ## CI - if (.test_ci(ci) && insight::check_if_installed("boot", "for estimating CIs", stop = FALSE)) { - out <- cbind(out, .boot_two_group_es( - data, .repsilon, iterations, - ci, alternative - )) + if ( + .test_ci(ci) && + insight::check_if_installed("boot", "for estimating CIs", stop = FALSE) + ) { + out <- cbind( + out, + .boot_two_group_es( + data, + .repsilon, + iterations, + ci, + alternative + ) + ) ci_method <- list(method = "percentile bootstrap", iterations = iterations) } else { ci_method <- alternative <- ci <- NULL @@ -125,30 +150,55 @@ rank_epsilon_squared <- function(x, groups, data = NULL, #' @export #' @rdname rank_epsilon_squared -rank_eta_squared <- function(x, groups, data = NULL, - ci = 0.95, alternative = "greater", - iterations = 200, - verbose = TRUE, ...) { +rank_eta_squared <- function( + x, + groups, + data = NULL, + ci = 0.95, + alternative = "greater", + iterations = 200, + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative, FALSE) if (.is_htest_of_type(x, "Kruskal-Wallis", "Kruskal-Wallis-test")) { - return(effectsize(x, type = "eta", ci = ci, iterations = iterations, alternative = alternative)) + return(effectsize( + x, + type = "eta", + ci = ci, + iterations = iterations, + alternative = alternative + )) } ## pep data - data <- .get_data_multi_group(x, groups, data, + data <- .get_data_multi_group( + x, + groups, + data, allow_ordered = TRUE, - verbose = verbose, ... + verbose = verbose, + ... ) out <- data.frame(rank_eta_squared = .reta(data)) ## CI - if (.test_ci(ci) && insight::check_if_installed("boot", "for estimating CIs", stop = FALSE)) { - out <- cbind(out, .boot_two_group_es( - data, .reta, iterations, - ci, alternative - )) + if ( + .test_ci(ci) && + insight::check_if_installed("boot", "for estimating CIs", stop = FALSE) + ) { + out <- cbind( + out, + .boot_two_group_es( + data, + .reta, + iterations, + ci, + alternative + ) + ) ci_method <- list(method = "percentile bootstrap", iterations = iterations) } else { ci_method <- alternative <- ci <- NULL @@ -163,28 +213,44 @@ rank_eta_squared <- function(x, groups, data = NULL, } - - - - #' @rdname rank_epsilon_squared #' @export -kendalls_w <- function(x, groups, blocks, data = NULL, - blocks_on_rows = TRUE, - ci = 0.95, alternative = "greater", - iterations = 200, - verbose = TRUE, ...) { +kendalls_w <- function( + x, + groups, + blocks, + data = NULL, + blocks_on_rows = TRUE, + ci = 0.95, + alternative = "greater", + iterations = 200, + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative, FALSE) if (.is_htest_of_type(x, "Friedman", "Friedman-test")) { - return(effectsize(x, ci = ci, iterations = iterations, verbose = verbose, alternative = alternative)) + return(effectsize( + x, + ci = ci, + iterations = iterations, + verbose = verbose, + alternative = alternative + )) } ## prep data - if (is.matrix(x) && !blocks_on_rows) x <- t(x) - data <- .get_data_nested_groups(x, groups, blocks, data, + if (is.matrix(x) && !blocks_on_rows) { + x <- t(x) + } + data <- .get_data_nested_groups( + x, + groups, + blocks, + data, allow_ordered = TRUE, - verbose = verbose, ... + verbose = verbose, + ... ) data <- stats::na.omit(data) # wide data - drop non complete cases @@ -193,7 +259,10 @@ kendalls_w <- function(x, groups, blocks, data = NULL, out <- data.frame(Kendalls_W = W) ## CI - if (.test_ci(ci) && insight::check_if_installed("boot", "for estimating CIs", stop = FALSE)) { + if ( + .test_ci(ci) && + insight::check_if_installed("boot", "for estimating CIs", stop = FALSE) + ) { out <- cbind(out, .kendalls_w_ci(data, ci, alternative, iterations)) ci_method <- list(method = "percentile bootstrap", iterations = iterations) } else { @@ -253,8 +322,17 @@ kendalls_w <- function(x, groups, blocks, data = NULL, sprintf( "%d block(s) contain ties%s.", sum(!no_ties), - ifelse(any(apply(as.data.frame(rankings)[!no_ties, ], 1, insight::n_unique) == 1), - ", some containing only 1 unique ranking", "" + ifelse( + any( + apply( + as.data.frame(rankings)[!no_ties, ], + 1, + insight::n_unique + ) == + 1 + ), + ", some containing only 1 unique ranking", + "" ) ) ) @@ -274,8 +352,7 @@ kendalls_w <- function(x, groups, blocks, data = NULL, ## CI ---- #' @keywords internal -.boot_two_group_es <- function(data, foo_es, iterations, - ci, alternative, lim) { +.boot_two_group_es <- function(data, foo_es, iterations, ci, alternative, lim) { ci.level <- .adjust_ci(ci, alternative) boot_fun <- function(.data, .i) { diff --git a/R/rank_diff.R b/R/rank_diff.R index 84179f055..d7a461253 100644 --- a/R/rank_diff.R +++ b/R/rank_diff.R @@ -118,11 +118,18 @@ #' #' #' @export -rank_biserial <- function(x, y = NULL, data = NULL, - mu = 0, paired = FALSE, - reference = NULL, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +rank_biserial <- function( + x, + y = NULL, + data = NULL, + mu = 0, + paired = FALSE, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { alternative <- .match.alt(alternative) if (.is_htest_of_type(x, "Wilcoxon", "Wilcoxon-test")) { @@ -130,11 +137,15 @@ rank_biserial <- function(x, y = NULL, data = NULL, } ## Prep data - out <- .get_data_2_samples(x, y, data, + out <- .get_data_2_samples( + x, + y, + data, paired = paired, reference = reference, allow_ordered = TRUE, - verbose = verbose, ... + verbose = verbose, + ... ) x <- out[["x"]] y <- out[["y"]] @@ -148,7 +159,13 @@ rank_biserial <- function(x, y = NULL, data = NULL, } ## Compute - r_rbs <- .r_rbs(x, y, mu = mu, paired = is_paired_or_onesample, verbose = verbose) + r_rbs <- .r_rbs( + x, + y, + mu = mu, + paired = is_paired_or_onesample, + verbose = verbose + ) out <- data.frame(r_rank_biserial = r_rbs) ## CI @@ -196,7 +213,12 @@ rank_biserial <- function(x, y = NULL, data = NULL, ci_method <- alternative <- NULL } - class(out) <- c("effectsize_difference", "effectsize_table", "see_effectsize_table", class(out)) + class(out) <- c( + "effectsize_difference", + "effectsize_table", + "see_effectsize_table", + class(out) + ) attr(out, "paired") <- paired attr(out, "mu") <- mu attr(out, "ci") <- ci @@ -208,13 +230,22 @@ rank_biserial <- function(x, y = NULL, data = NULL, #' @export #' @rdname rank_biserial -cliffs_delta <- function(x, y = NULL, data = NULL, - mu = 0, - reference = NULL, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +cliffs_delta <- function( + x, + y = NULL, + data = NULL, + mu = 0, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { cl <- match.call() - data <- .get_data_2_samples(x, y, data, + data <- .get_data_2_samples( + x, + y, + data, verbose = verbose, allow_ordered = TRUE, reference = reference, @@ -223,7 +254,9 @@ cliffs_delta <- function(x, y = NULL, data = NULL, x <- data$x y <- data$y if (is.null(y) || isTRUE(cl$paired) || isTRUE(data[["paired"]])) { - insight::format_error("This effect size is only applicable for two independent samples.") + insight::format_error( + "This effect size is only applicable for two independent samples." + ) } cl[[1]] <- quote(effectsize::rank_biserial) diff --git a/R/reexports.R b/R/reexports.R index 6eb765505..6581db62b 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -24,7 +24,6 @@ parameters::standardize_posteriors parameters::standardize_info - # Printing ---------------------------------------------------------------- #' @export diff --git a/R/repeated_measures_d.R b/R/repeated_measures_d.R index 2e311afc2..0a99832b8 100644 --- a/R/repeated_measures_d.R +++ b/R/repeated_measures_d.R @@ -153,23 +153,39 @@ #' cohens_d(rt ~ cond, data = rouder2016, ci = NULL) #' #' @export -repeated_measures_d <- function(x, y, - data = NULL, - mu = 0, method = c("rm", "av", "z", "b", "d", "r"), - adjust = TRUE, - reference = NULL, - ci = 0.95, alternative = "two.sided", - verbose = TRUE, ...) { +repeated_measures_d <- function( + x, + y, + data = NULL, + mu = 0, + method = c("rm", "av", "z", "b", "d", "r"), + adjust = TRUE, + reference = NULL, + ci = 0.95, + alternative = "two.sided", + verbose = TRUE, + ... +) { method <- match.arg(method) if (.is_htest_of_type(x, "t-test")) { - return(effectsize(x, type = paste0("rm_", method), verbose = verbose, adjust = adjust, ...)) + return(effectsize( + x, + type = paste0("rm_", method), + verbose = verbose, + adjust = adjust, + ... + )) } alternative <- .match.alt(alternative) - data <- .get_data_paired(x, y, - data = data, method = method, + data <- .get_data_paired( + x, + y, + data = data, + method = method, reference = reference, - verbose = verbose, ... + verbose = verbose, + ... ) if (method %in% c("d", "r")) { @@ -200,7 +216,6 @@ repeated_measures_d <- function(x, y, ci_method <- alternative <- NULL } - if (adjust) { J <- .J(values[["df"]]) @@ -211,15 +226,24 @@ repeated_measures_d <- function(x, y, } # rename column to method - colnames(out)[1] <- switch(method, + colnames(out)[1] <- switch( + method, d = "Cohens_d", b = "Beckers_d", paste0("d_", method) ) - class(out) <- c("effectsize_difference", "effectsize_table", "see_effectsize_table", class(out)) + class(out) <- c( + "effectsize_difference", + "effectsize_table", + "see_effectsize_table", + class(out) + ) .someattributes(out) <- .nlist( - mu, ci, ci_method, alternative, + mu, + ci, + ci_method, + alternative, approximate = FALSE ) out @@ -240,7 +264,8 @@ rm_d <- repeated_measures_d r <- stats::cor(x, y) f <- 2 * (1 - r) - if (method == "rm") { # nolint + if (method == "rm") { + # nolint s <- stats::sd(x - y) / sqrt(f) d <- (m - mu) / s @@ -273,12 +298,15 @@ rm_d <- repeated_measures_d .replication_d <- function(data, mu, method) { if (method == "r") { # for r - need to make sure there are replications! - cell_ns <- tapply(data[[1]], data[3:2], function(v) length(stats::na.omit(v))) + cell_ns <- tapply(data[[1]], data[3:2], function(v) { + length(stats::na.omit(v)) + }) all(cell_ns > 1L) } mod <- suppressWarnings( - stats::aov(y ~ condition + Error(id / condition), + stats::aov( + y ~ condition + Error(id / condition), data = data, contrasts = list(condition = stats::contr.treatment) ) diff --git a/R/utils.R b/R/utils.R index b5a2e247b..62b7f8da1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -28,13 +28,14 @@ #' @keywords internal .get_model_info <- function(model, model_info = NULL, ...) { - if (is.null(model_info)) model_info <- insight::model_info(model) + if (is.null(model_info)) { + model_info <- insight::model_info(model) + } model_info } - #' @keywords internal .safe_ranktransform <- function(x, verbose = TRUE, ...) { if (insight::n_unique(x) == 1) { diff --git a/R/utils_ci.R b/R/utils_ci.R index ff36d0d1b..f6c3f1013 100644 --- a/R/utils_ci.R +++ b/R/utils_ci.R @@ -86,16 +86,17 @@ # Validators -------------------------------------- - #' @keywords internal .test_ci <- function(ci) { if (is.null(ci)) { return(FALSE) } - if (!is.numeric(ci) || - length(ci) != 1L || - ci < 0 || - ci > 1) { + if ( + !is.numeric(ci) || + length(ci) != 1L || + ci < 0 || + ci > 1 + ) { insight::format_error("ci must be a single numeric value between (0, 1)") } TRUE diff --git a/R/utils_validate_input_data.R b/R/utils_validate_input_data.R index cd4fab0c4..61dc8339c 100644 --- a/R/utils_validate_input_data.R +++ b/R/utils_validate_input_data.R @@ -1,8 +1,14 @@ #' @keywords internal -.get_data_2_samples <- function(x, y = NULL, data = NULL, - paired = FALSE, reference = NULL, - allow_ordered = FALSE, - verbose = TRUE, ...) { +.get_data_2_samples <- function( + x, + y = NULL, + data = NULL, + paired = FALSE, + reference = NULL, + allow_ordered = FALSE, + verbose = TRUE, + ... +) { if (inherits(x, "formula")) { if (isTRUE(paired)) { # This is to be consistent with R>=4.4.0 @@ -42,12 +48,13 @@ y <- .resolve_char(y, data) } - # If x is ordered and allowed to be... if (allow_ordered && is.ordered(x)) { if (is.ordered(y)) { if (!isTRUE(all.equal(levels(y), levels(x)))) { - insight::format_error("x and y are ordered, but do not have the same levels.") + insight::format_error( + "x and y are ordered, but do not have the same levels." + ) } y <- as.numeric(y) } @@ -57,7 +64,9 @@ # x should be a numeric vector or a Pair: if (!is.numeric(x)) { - insight::format_error("Cannot compute effect size for a non-numeric vector.") + insight::format_error( + "Cannot compute effect size for a non-numeric vector." + ) } else if (inherits(x, "Pair")) { if (is.null(reference)) { y <- x[, 2] @@ -69,7 +78,6 @@ paired <- TRUE } - # y should be NULL, numeric, or a factor: if (!is.null(y)) { if (!is.numeric(y)) { @@ -118,9 +126,15 @@ } #' @keywords internal -.get_data_paired <- function(x, y = NULL, data = NULL, method = NULL, - reference = NULL, - verbose = TRUE, ...) { +.get_data_paired <- function( + x, + y = NULL, + data = NULL, + method = NULL, + reference = NULL, + verbose = TRUE, + ... +) { if (inherits(x, "formula")) { formula_error <- "Formula must have one of the following forms: @@ -150,7 +164,11 @@ if (verbose && any(tapply(mf[[1]], mf[3:2], length) > 1L, na.rm = TRUE)) { insight::format_alert( - paste0("The ", method, " standardized difference requires paired data,"), + paste0( + "The ", + method, + " standardized difference requires paired data," + ), "but data contains more than one observation per design cell.", "Aggregating data using `mean()`." ) @@ -189,7 +207,9 @@ # x should be a numeric vector or a Pair: if (!is.numeric(x) || !is.numeric(y)) { - insight::format_error("Cannot compute effect size for a non-numeric vector.") + insight::format_error( + "Cannot compute effect size for a non-numeric vector." + ) } o <- stats::complete.cases(x, y) @@ -228,9 +248,14 @@ } #' @keywords internal -.get_data_multi_group <- function(x, groups, data = NULL, - allow_ordered = FALSE, - verbose = TRUE, ...) { +.get_data_multi_group <- function( + x, + groups, + data = NULL, + allow_ordered = FALSE, + verbose = TRUE, + ... +) { if (inherits(x, "formula")) { if (length(x) != 3) { insight::format_error("Formula must have the form of 'outcome ~ group'.") @@ -259,7 +284,9 @@ x <- as.numeric(x) } if (!is.numeric(x)) { - insight::format_error("Cannot compute effect size for a non-numeric vector.") + insight::format_error( + "Cannot compute effect size for a non-numeric vector." + ) } # groups should be not numeric @@ -279,9 +306,16 @@ } #' @keywords internal -.get_data_nested_groups <- function(x, groups = NULL, blocks = NULL, data = NULL, - wide = TRUE, allow_ordered = FALSE, - verbose = TRUE, ...) { +.get_data_nested_groups <- function( + x, + groups = NULL, + blocks = NULL, + data = NULL, + wide = TRUE, + allow_ordered = FALSE, + verbose = TRUE, + ... +) { if (inherits(x, "formula")) { if (length(x) != 3L || x[[3L]][[1L]] != as.name("|")) { insight::format_error("Formula must have the 'x ~ groups | blocks'.") @@ -308,7 +342,6 @@ x <- data.frame(x, groups, blocks) } - if (inherits(x, c("matrix", "array"))) { x <- as.table(x) } @@ -323,11 +356,16 @@ x$x <- as.numeric(x$x) } if (!is.numeric(x$x)) { - insight::format_error("Cannot compute effect size for a non-numeric vector.") + insight::format_error( + "Cannot compute effect size for a non-numeric vector." + ) + } + if (!is.factor(x$groups)) { + x$groups <- factor(x$groups) + } + if (!is.factor(x$blocks)) { + x$blocks <- factor(x$blocks) } - if (!is.factor(x$groups)) x$groups <- factor(x$groups) - if (!is.factor(x$blocks)) x$blocks <- factor(x$blocks) - if (verbose && anyNA(x)) { insight::format_warning("Missing values detected. NAs dropped.") @@ -336,7 +374,8 @@ # By this point, the data is in long format if (wide) { - x <- datawizard::data_to_wide(x, + x <- datawizard::data_to_wide( + x, values_from = "x", id_cols = "blocks", names_from = "groups" @@ -347,14 +386,25 @@ } #' @keywords internal -.get_data_multivariate <- function(x, y = NULL, data = NULL, - verbose = TRUE, ...) { +.get_data_multivariate <- function( + x, + y = NULL, + data = NULL, + verbose = TRUE, + ... +) { if (inherits(x, "formula")) { if (length(x) != 3L || length(x[[3]]) != 1L) { - insight::format_error("Formula must have the form of 'DV1 + ... + DVk ~ group', with exactly one term on the RHS.") # nolint + insight::format_error( + "Formula must have the form of 'DV1 + ... + DVk ~ group', with exactly one term on the RHS." + ) # nolint } - data <- .resolve_formula(stats::reformulate(as.character(x)[3:2]), data, ...) + data <- .resolve_formula( + stats::reformulate(as.character(x)[3:2]), + data, + ... + ) if (x[[3]] == 1) { # Then it is one sampled @@ -385,7 +435,6 @@ insight::format_error("All DVs must be numeric.") } - # y should be null, a data frame or matrix if (!is.null(y)) { if (is.matrix(y)) { @@ -399,7 +448,9 @@ } if (!all(colnames(x) == colnames(y))) { - insight::format_error("x,y must have the same variables (in the same order).") + insight::format_error( + "x,y must have the same variables (in the same order)." + ) } } @@ -415,9 +466,14 @@ # Helpers ----------------------------------------------------------------- - #' @keywords internal -.resolve_formula <- function(formula, data, subset, na.action = stats::na.pass, ...) { +.resolve_formula <- function( + formula, + data, + subset, + na.action = stats::na.pass, + ... +) { cl <- match.call(expand.dots = FALSE) cl[[1]] <- quote(stats::model.frame) diff --git a/R/xtab_corr.R b/R/xtab_corr.R index ae7e464d3..a629af43a 100644 --- a/R/xtab_corr.R +++ b/R/xtab_corr.R @@ -108,77 +108,121 @@ #' #' #' @export -phi <- function(x, y = NULL, - adjust = TRUE, - ci = 0.95, alternative = "greater", - ...) { +phi <- function( + x, + y = NULL, + adjust = TRUE, + ci = 0.95, + alternative = "greater", + ... +) { alternative <- .match.alt(alternative, FALSE) if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "phi", adjust = adjust, ci = ci)) - } else if (!.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") && - !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab"))) { + } else if ( + !.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") && + !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) + ) { x <- suppressWarnings(stats::chisq.test(x, y)) x$data.name <- NULL } - effectsize(x, type = "phi", adjust = adjust, ci = ci, alternative = alternative) + effectsize( + x, + type = "phi", + adjust = adjust, + ci = ci, + alternative = alternative + ) } #' @rdname phi #' @export -cramers_v <- function(x, y = NULL, - adjust = TRUE, - ci = 0.95, alternative = "greater", - ...) { +cramers_v <- function( + x, + y = NULL, + adjust = TRUE, + ci = 0.95, + alternative = "greater", + ... +) { alternative <- .match.alt(alternative, FALSE) if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "cramers_v", adjust = adjust, ci = ci)) - } else if (!.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") && - !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab"))) { + } else if ( + !.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") && + !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) + ) { x <- suppressWarnings(stats::chisq.test(x, y)) x$data.name <- NULL } - effectsize(x, type = "cramers_v", adjust = adjust, ci = ci, alternative = alternative) + effectsize( + x, + type = "cramers_v", + adjust = adjust, + ci = ci, + alternative = alternative + ) } #' @rdname phi #' @export -tschuprows_t <- function(x, y = NULL, - adjust = TRUE, - ci = 0.95, alternative = "greater", - ...) { +tschuprows_t <- function( + x, + y = NULL, + adjust = TRUE, + ci = 0.95, + alternative = "greater", + ... +) { alternative <- .match.alt(alternative, FALSE) if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "tschuprows_t", ci = ci)) - } else if (!.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") && - !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab"))) { + } else if ( + !.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") && + !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) + ) { x <- suppressWarnings(stats::chisq.test(x, y)) x$data.name <- NULL } - effectsize(x, type = "tschuprows_t", adjust = adjust, ci = ci, alternative = alternative) + effectsize( + x, + type = "tschuprows_t", + adjust = adjust, + ci = ci, + alternative = alternative + ) } #' @rdname phi #' @export -cohens_w <- function(x, y = NULL, p = rep(1, length(x)), - ci = 0.95, alternative = "greater", - ...) { +cohens_w <- function( + x, + y = NULL, + p = rep(1, length(x)), + ci = 0.95, + alternative = "greater", + ... +) { alternative <- .match.alt(alternative, FALSE) if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "cohens_w", ci = ci)) - } else if (!.is_htest_of_type( - x, "(Pearson's Chi-squared|Chi-squared test for given probabilities)", - "Chi-squared-test" - ) && - !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) && - !inherits(x, c("datawizard_tables", "datawizard_table"))) { + } else if ( + !.is_htest_of_type( + x, + "(Pearson's Chi-squared|Chi-squared test for given probabilities)", + "Chi-squared-test" + ) && + !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) && + !inherits(x, c("datawizard_tables", "datawizard_table")) + ) { x <- suppressWarnings(stats::chisq.test(x, y, p = p, rescale.p = TRUE)) x$data.name <- NULL } @@ -189,21 +233,36 @@ cohens_w <- function(x, y = NULL, p = rep(1, length(x)), #' @rdname phi #' @export -fei <- function(x, p = rep(1, length(x)), - ci = 0.95, alternative = "greater", - ...) { +fei <- function( + x, + p = rep(1, length(x)), + ci = 0.95, + alternative = "greater", + ... +) { alternative <- .match.alt(alternative, FALSE) if (inherits(x, "BFBayesFactor")) { insight::format_error("Fei is only applicable to goodness of fit tests.") - } else if (!.is_htest_of_type(x, "Chi-squared test for given probabilities", "Chi-squared-test") && - !inherits(x, c("datawizard_tables", "datawizard_table"))) { - x <- suppressWarnings(stats::chisq.test(x, y = NULL, p = p, rescale.p = TRUE)) + } else if ( + !.is_htest_of_type( + x, + "Chi-squared test for given probabilities", + "Chi-squared-test" + ) && + !inherits(x, c("datawizard_tables", "datawizard_table")) + ) { + x <- suppressWarnings(stats::chisq.test( + x, + y = NULL, + p = p, + rescale.p = TRUE + )) x$data.name <- NULL table_dim <- dim(x$observed) - is_1d_table <- is.null(table_dim) || # vector - length(table_dim) == 1 || # 1D table + is_1d_table <- is.null(table_dim) || # vector + length(table_dim) == 1 || # 1D table (length(table_dim) == 2 && any(table_dim == 1)) if (!is_1d_table) { insight::format_error("Fei is only applicable to goodness of fit tests.") @@ -215,19 +274,27 @@ fei <- function(x, p = rep(1, length(x)), #' @rdname phi #' @export -pearsons_c <- function(x, y = NULL, p = rep(1, length(x)), - ci = 0.95, alternative = "greater", - ...) { +pearsons_c <- function( + x, + y = NULL, + p = rep(1, length(x)), + ci = 0.95, + alternative = "greater", + ... +) { alternative <- .match.alt(alternative, FALSE) if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "pearsons_c", ci = ci)) - } else if (!.is_htest_of_type( - x, "(Pearson's Chi-squared|Chi-squared test for given probabilities)", - "Chi-squared-test" - ) && - !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) && - !inherits(x, c("datawizard_tables", "datawizard_table"))) { + } else if ( + !.is_htest_of_type( + x, + "(Pearson's Chi-squared|Chi-squared test for given probabilities)", + "Chi-squared-test" + ) && + !inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) && + !inherits(x, c("datawizard_tables", "datawizard_table")) + ) { x <- suppressWarnings(stats::chisq.test(x, y, p = p, rescale.p = TRUE)) x$data.name <- NULL } @@ -235,5 +302,4 @@ pearsons_c <- function(x, y = NULL, p = rep(1, length(x)), effectsize(x, type = "pearsons_c", ci = ci, alternative = alternative) } - # styler: on diff --git a/R/xtab_diff.R b/R/xtab_diff.R index 226f56ab8..c1b7c5372 100644 --- a/R/xtab_diff.R +++ b/R/xtab_diff.R @@ -58,12 +58,31 @@ #' nnt(RCT_table) #' #' @export -oddsratio <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", log = FALSE, ...) { +oddsratio <- function( + x, + y = NULL, + ci = 0.95, + alternative = "two.sided", + log = FALSE, + ... +) { alternative <- .match.alt(alternative) - if (.is_htest_of_type(x, "(Pearson's Chi-squared|Fisher's Exact)", "Chi-squared-test or Fisher's Exact test") || - inherits(x, c("datawizard_crosstabs", "datawizard_crosstab"))) { - return(effectsize(x, type = "or", log = log, ci = ci, alternative = alternative)) + if ( + .is_htest_of_type( + x, + "(Pearson's Chi-squared|Fisher's Exact)", + "Chi-squared-test or Fisher's Exact test" + ) || + inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) + ) { + return(effectsize( + x, + type = "or", + log = log, + ci = ci, + alternative = alternative + )) } else if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "or", log = log, ci = ci)) } @@ -72,11 +91,15 @@ oddsratio <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", log = F Obs <- res$observed if (any(c(colSums(Obs), rowSums(Obs)) == 0L)) { - insight::format_error("Cannot have empty rows/columns in the contingency tables.") + insight::format_error( + "Cannot have empty rows/columns in the contingency tables." + ) } if (nrow(Obs) != 2 || ncol(Obs) != 2) { - insight::format_error("Odds ratio only available for 2-by-2 contingency tables") + insight::format_error( + "Odds ratio only available for 2-by-2 contingency tables" + ) } OR <- (Obs[1, 1] / Obs[2, 1]) / @@ -121,14 +144,18 @@ oddsratio <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", log = F #' @export riskratio <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { if ("log" %in% ...names() && isTRUE(list(...)$log)) { - insight::format_warning("'log' argument has been deprecated.", - "Returning RR instead of log(RR)") + insight::format_warning( + "'log' argument has been deprecated.", + "Returning RR instead of log(RR)" + ) } alternative <- .match.alt(alternative) - if (.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") || - inherits(x, c("datawizard_crosstabs", "datawizard_crosstab"))) { + if ( + .is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") || + inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) + ) { return(effectsize(x, type = "rr", ci = ci, alternative = alternative)) } else if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "rr", ci = ci, ...)) @@ -138,11 +165,15 @@ riskratio <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { Obs <- res$observed if (any(c(colSums(Obs), rowSums(Obs)) == 0L)) { - insight::format_error("Cannot have empty rows/columns in the contingency tables.") + insight::format_error( + "Cannot have empty rows/columns in the contingency tables." + ) } if (nrow(Obs) != 2 || ncol(Obs) != 2) { - insight::format_error("Risk ratio only available for 2-by-2 contingency tables") + insight::format_error( + "Risk ratio only available for 2-by-2 contingency tables" + ) } n1 <- sum(Obs[, 1]) @@ -185,8 +216,10 @@ riskratio <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { cohens_h <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { alternative <- .match.alt(alternative) - if (.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") || - inherits(x, c("datawizard_crosstabs", "datawizard_crosstab"))) { + if ( + .is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") || + inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) + ) { return(effectsize(x, type = "cohens_h", ci = ci, alternative = alternative)) } else if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "cohens_h", ci = ci, ...)) @@ -196,11 +229,15 @@ cohens_h <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { Obs <- res$observed if (any(c(colSums(Obs), rowSums(Obs)) == 0L)) { - insight::format_error("Cannot have empty rows/columns in the contingency tables.") + insight::format_error( + "Cannot have empty rows/columns in the contingency tables." + ) } if (nrow(Obs) != 2 || ncol(Obs) != 2) { - insight::format_error("Cohen's h only available for 2-by-2 contingency tables") + insight::format_error( + "Cohen's h only available for 2-by-2 contingency tables" + ) } n1 <- sum(Obs[, 1]) @@ -242,8 +279,10 @@ cohens_h <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { arr <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { alternative <- .match.alt(alternative) - if (.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") || - inherits(x, c("datawizard_crosstabs", "datawizard_crosstab"))) { + if ( + .is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") || + inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) + ) { return(effectsize(x, type = "arr", ci = ci, alternative = alternative)) } else if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "arr", ci = ci, ...)) @@ -253,11 +292,15 @@ arr <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { Obs <- res$observed if (any(c(colSums(Obs), rowSums(Obs)) == 0L)) { - insight::format_error("Cannot have empty rows/columns in the contingency tables.") + insight::format_error( + "Cannot have empty rows/columns in the contingency tables." + ) } if (nrow(Obs) != 2 || ncol(Obs) != 2) { - insight::format_error("This effect size is only available for 2-by-2 contingency tables") + insight::format_error( + "This effect size is only available for 2-by-2 contingency tables" + ) } n1 <- sum(Obs[, 1]) @@ -302,8 +345,10 @@ nnt <- function(x, y = NULL, ci = 0.95, alternative = "two.sided", ...) { flip_alt <- c(less = "greater", greater = "less", two.sided = "two.sided") alternative2 <- unname(flip_alt[alternative]) - if (.is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") || - inherits(x, c("datawizard_crosstabs", "datawizard_crosstab"))) { + if ( + .is_htest_of_type(x, "Pearson's Chi-squared", "Chi-squared-test") || + inherits(x, c("datawizard_crosstabs", "datawizard_crosstab")) + ) { return(effectsize(x, type = "nnt", ci = ci, alternative = alternative)) } else if (.is_BF_of_type(x, "BFcontingencyTable", "Chi-squared")) { return(effectsize(x, type = "nnt", ci = ci, ...)) diff --git a/R/zzz.R b/R/zzz.R index 12f68f150..9ef2010d1 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -8,7 +8,9 @@ ) toset <- !names(op.es) %in% names(op) - if (any(toset)) options(op.es[toset]) + if (any(toset)) { + options(op.es[toset]) + } invisible(NULL) } diff --git a/WIP/convert_stat_H.R b/WIP/convert_stat_H.R index 8f31e0dfd..329c946f4 100644 --- a/WIP/convert_stat_H.R +++ b/WIP/convert_stat_H.R @@ -15,4 +15,4 @@ h_to_epsilon <- function(H, N, k) { (H - k + 1) / (N - k) } -# TODO use these internally \ No newline at end of file +# TODO use these internally diff --git a/air.toml b/air.toml new file mode 100644 index 000000000..09a4d417b --- /dev/null +++ b/air.toml @@ -0,0 +1,9 @@ +[format] +line-width = 80 +indent-width = 2 +indent-style = "space" +line-ending = "lf" +persistent-line-breaks = true +exclude = ["data-raw/**/*.R", "papers/**/*.R"] +default-exclude = true +skip = ["tribble"] diff --git a/dev/revdepcheck.R b/dev/revdepcheck.R index 5b787a5cf..552936bda 100644 --- a/dev/revdepcheck.R +++ b/dev/revdepcheck.R @@ -2,4 +2,4 @@ library(revdepcheck) revdep_check(num_workers = 4) revdep_report() -revdep_reset() \ No newline at end of file +revdep_reset() diff --git a/tests/testthat/test-cohens_d.R b/tests/testthat/test-cohens_d.R index ae1a763de..3dce0b07b 100644 --- a/tests/testthat/test-cohens_d.R +++ b/tests/testthat/test-cohens_d.R @@ -4,27 +4,34 @@ test_that("cohens_d errors and warnings", { rez_d <- cohens_d(iris$Sepal.Length, iris$Sepal.Width) expect_equal(sign(rez_t$statistic), sign(rez_d$Cohens_d), ignore_attr = TRUE) - # Alternative ------------------------------------------------------------- d1 <- cohens_d(iris$Sepal.Length, iris$Sepal.Width, ci = 0.80) - d2 <- cohens_d(iris$Sepal.Length, iris$Sepal.Width, ci = 0.90, alternative = "l") - d3 <- cohens_d(iris$Sepal.Length, iris$Sepal.Width, ci = 0.90, alternative = "g") + d2 <- cohens_d( + iris$Sepal.Length, + iris$Sepal.Width, + ci = 0.90, + alternative = "l" + ) + d3 <- cohens_d( + iris$Sepal.Length, + iris$Sepal.Width, + ci = 0.90, + alternative = "g" + ) expect_equal(d1$CI_high, d2$CI_high) expect_equal(d1$CI_low, d3$CI_low) }) test_that("cohens_d - mu", { - expect_equal(cohens_d(mtcars$mpg - 5), + expect_equal( + cohens_d(mtcars$mpg - 5), cohens_d(mtcars$mpg, mu = 5), ignore_attr = TRUE ) x <- 1:9 y <- c(1, 1:9) - expect_equal(cohens_d(x - 3, y), - cohens_d(x, y, mu = 3), - ignore_attr = TRUE - ) + expect_equal(cohens_d(x - 3, y), cohens_d(x, y, mu = 3), ignore_attr = TRUE) d <- cohens_d(x, y, mu = 3.125) expect_equal(d[[1]], -0.969, tolerance = 0.01) @@ -85,7 +92,6 @@ test_that("fixed values", { x2 <- bayestestR::distribution_normal(1e4, mean = 1, sd = 1) expect_equal(cohens_d(x1, x2)$Cohens_d, -1, tolerance = 1e-3) - x1 <- bayestestR::distribution_normal(1e4, mean = 0, sd = 1) x2 <- bayestestR::distribution_normal(1e4, mean = 1.5, sd = 2) diff --git a/tests/testthat/test-cohens_g.R b/tests/testthat/test-cohens_g.R index 3ec794305..ec28d251a 100644 --- a/tests/testthat/test-cohens_g.R +++ b/tests/testthat/test-cohens_g.R @@ -1,7 +1,8 @@ test_that("Cohen's g", { # From mcnemar.test Performance <- - matrix(c(794, 86, 150, 570), + matrix( + c(794, 86, 150, 570), nrow = 2, dimnames = list( "1st Survey" = c("Approve", "Disapprove"), @@ -13,22 +14,31 @@ test_that("Cohen's g", { expect_equal(g$CI_low, 0.072, tolerance = 0.01) expect_equal(g$CI_high, 0.194, tolerance = 0.01) - - AndersonRainBarrel <- matrix(c( - 9L, 17L, - 5L, 15L - ), nrow = 2) + AndersonRainBarrel <- matrix( + c( + 9L, + 17L, + 5L, + 15L + ), + nrow = 2 + ) g <- cohens_g(AndersonRainBarrel) expect_equal(g$Cohens_g, 0.273, tolerance = 0.01) expect_equal(g$CI_low, 0.066, tolerance = 0.01) expect_equal(g$CI_high, 0.399, tolerance = 0.01) - M <- matrix( c( - 794, 86, 150, - 570, 794, 86, - 150, 570, 15 + 794, + 86, + 150, + 570, + 794, + 86, + 150, + 570, + 15 ), nrow = 3 ) diff --git a/tests/testthat/test-common_language.R b/tests/testthat/test-common_language.R index 9ee6f3220..a2a613440 100644 --- a/tests/testthat/test-common_language.R +++ b/tests/testthat/test-common_language.R @@ -70,21 +70,33 @@ test_that("CLES | par vs non-par", { x <<- rnorm(500) y <<- rnorm(500, mean = 0.2) - expect_equal(p_superiority(x, y), p_superiority(x, y, parametric = FALSE), - tolerance = 0.1, ignore_attr = TRUE + expect_equal( + p_superiority(x, y), + p_superiority(x, y, parametric = FALSE), + tolerance = 0.1, + ignore_attr = TRUE ) - expect_equal(cohens_u2(x, y), cohens_u2(x, y, parametric = FALSE), - tolerance = 0.1, ignore_attr = TRUE + expect_equal( + cohens_u2(x, y), + cohens_u2(x, y, parametric = FALSE), + tolerance = 0.1, + ignore_attr = TRUE ) skip_on_cran() - expect_equal(cohens_u3(x, y), cohens_u3(x, y, parametric = FALSE), - tolerance = 0.1, ignore_attr = TRUE + expect_equal( + cohens_u3(x, y), + cohens_u3(x, y, parametric = FALSE), + tolerance = 0.1, + ignore_attr = TRUE ) - expect_equal(p_overlap(x, y), p_overlap(x, y, parametric = FALSE), - tolerance = 0.1, ignore_attr = TRUE + expect_equal( + p_overlap(x, y), + p_overlap(x, y, parametric = FALSE), + tolerance = 0.1, + ignore_attr = TRUE ) }) diff --git a/tests/testthat/test-convert_between.R b/tests/testthat/test-convert_between.R index e96ce76fa..43f48170c 100644 --- a/tests/testthat/test-convert_between.R +++ b/tests/testthat/test-convert_between.R @@ -1,4 +1,3 @@ - # OR, d, r ------------------------------ test_that("oddsratio_to_d", { @@ -22,7 +21,6 @@ test_that("oddsratio_to_d (exact)", { expect_equal(oddsratio_to_r(1), 0, tolerance = 0.0001) expect_equal(oddsratio_to_r(OR, p0), d_to_r(d), tolerance = 0.0001) - # From Chen et al 2010 chen_tab_1 <- as.matrix( read.table( @@ -43,7 +41,12 @@ test_that("oddsratio_to_d (exact)", { for (i in seq_len(nrow(chen_tab_1))) { d_recovered <- oddsratio_to_d(chen_tab_1[i, 2:4], p0 = chen_tab_1[i, 1]) - expect_equal(d_recovered, c(0.2, 0.5, 0.8), tolerance = 0.01, ignore_attr = TRUE) + expect_equal( + d_recovered, + c(0.2, 0.5, 0.8), + tolerance = 0.01, + ignore_attr = TRUE + ) } }) @@ -52,8 +55,16 @@ test_that("d_to_r", { expect_equal(d_to_r(1.1547), 0.5, tolerance = 0.01) expect_equal(r_to_d(0.5), 1.1547, tolerance = 0.01) - expect_equal(oddsratio_to_r(d_to_oddsratio(r_to_d(0.5))), 0.5, tolerance = 0.001) - expect_equal(oddsratio_to_d(r_to_oddsratio(d_to_r(1), log = TRUE), log = TRUE), 1, tolerance = 0.001) + expect_equal( + oddsratio_to_r(d_to_oddsratio(r_to_d(0.5))), + 0.5, + tolerance = 0.001 + ) + expect_equal( + oddsratio_to_d(r_to_oddsratio(d_to_r(1), log = TRUE), log = TRUE), + 1, + tolerance = 0.001 + ) r <- cor(mtcars$hp, -mtcars$am) d <- cohens_d(hp ~ am, data = mtcars, ci = NULL)[[1]] @@ -106,36 +117,55 @@ test_that("OR, RR, ARR, NNT | numeric", { expect_equal(riskratio_to_oddsratio(RR, p0 = p0), OR, tolerance = 1e-4) expect_equal(oddsratio_to_riskratio(OR, p0 = p0), RR, tolerance = 1e-4) - expect_equal(oddsratio_to_riskratio(1 / OR, p0 = p1), 1 / RR, tolerance = 1e-4) + expect_equal( + oddsratio_to_riskratio(1 / OR, p0 = p1), + 1 / RR, + tolerance = 1e-4 + ) expect_equal(riskratio_to_arr(RR, p0 = p0), ARR, tolerance = 1e-4) expect_equal(oddsratio_to_arr(OR, p0 = p0), ARR, tolerance = 1e-4) expect_equal(arr_to_oddsratio(ARR, p0 = p0), OR, tolerance = 1e-4) expect_equal(arr_to_riskratio(ARR, p0 = p0), RR, tolerance = 1e-4) - expect_equal(riskratio_to_oddsratio(RR, p0 = p0, log = TRUE), log(OR), tolerance = 1e-4) - expect_equal(oddsratio_to_riskratio(log(OR), p0 = p0, log = TRUE), RR, tolerance = 1e-4) - expect_equal(arr_to_oddsratio(ARR, p0 = p0, log = TRUE), log(OR), tolerance = 1e-4) - expect_equal(oddsratio_to_arr(log(OR), p0 = p0, log = TRUE), ARR, tolerance = 1e-4) + expect_equal( + riskratio_to_oddsratio(RR, p0 = p0, log = TRUE), + log(OR), + tolerance = 1e-4 + ) + expect_equal( + oddsratio_to_riskratio(log(OR), p0 = p0, log = TRUE), + RR, + tolerance = 1e-4 + ) + expect_equal( + arr_to_oddsratio(ARR, p0 = p0, log = TRUE), + log(OR), + tolerance = 1e-4 + ) + expect_equal( + oddsratio_to_arr(log(OR), p0 = p0, log = TRUE), + ARR, + tolerance = 1e-4 + ) }) - test_that("OR <=> RR | models", { skip_on_cran() # -- GLMs -- data(mtcars) - m1 <<- glm(am ~ factor(cyl), - data = mtcars, - family = binomial("logit") - ) + m1 <<- glm(am ~ factor(cyl), data = mtcars, family = binomial("logit")) expect_warning(RR <- oddsratio_to_riskratio(m1, ci = NULL), "p0") # nolint expect_false("(Intercept)" %in% RR$Parameter) expect_true("(p0)" %in% RR$Parameter) - expect_warning(RR <- oddsratio_to_riskratio(m1, ci_method = "wald", p0 = 0.7272727), NA) # nolint + expect_warning( + RR <- oddsratio_to_riskratio(m1, ci_method = "wald", p0 = 0.7272727), + NA + ) # nolint expect_false("(Intercept)" %in% RR$Parameter) expect_true("(p0)" %in% RR$Parameter) # these values confirmed from emmeans @@ -152,10 +182,7 @@ test_that("OR <=> RR | models", { # -- GLMs2 -- data(mtcars) - m2 <<- glm(am ~ factor(cyl), - data = mtcars, - family = binomial("log") - ) + m2 <<- glm(am ~ factor(cyl), data = mtcars, family = binomial("log")) ORt <- parameters::model_parameters(m1, exp = TRUE) @@ -163,7 +190,10 @@ test_that("OR <=> RR | models", { expect_false("(Intercept)" %in% OR$Parameter) expect_true("(p0)" %in% OR$Parameter) - expect_warning(OR <- riskratio_to_oddsratio(m2, ci_method = "wald", p0 = 0.7272727), NA) # nolint + expect_warning( + OR <- riskratio_to_oddsratio(m2, ci_method = "wald", p0 = 0.7272727), + NA + ) # nolint expect_false("(Intercept)" %in% OR$Parameter) expect_true("(p0)" %in% OR$Parameter) # these values confirmed from marginaleffects @@ -179,7 +209,8 @@ test_that("OR <=> RR | models", { # -- GLMMs -- skip_if_not_installed("lme4") - m <<- lme4::glmer(am ~ factor(cyl) + (1 | gear), + m <<- lme4::glmer( + am ~ factor(cyl) + (1 | gear), data = mtcars, family = binomial() ) @@ -188,7 +219,10 @@ test_that("OR <=> RR | models", { expect_false("(Intercept)" %in% RR$Parameter) expect_true("(p0)" %in% RR$Parameter) - expect_warning(RR <- oddsratio_to_riskratio(m, ci_method = "wald", p0 = 0.7047536), NA) # nolint + expect_warning( + RR <- oddsratio_to_riskratio(m, ci_method = "wald", p0 = 0.7047536), + NA + ) # nolint expect_false("(Intercept)" %in% RR$Parameter) expect_true("(p0)" %in% RR$Parameter) # these values confirmed from emmeans @@ -222,8 +256,7 @@ test_that("=> probs", { expect_equal(riskratio_to_probs(RR, p0 = p0), p1) expect_equal(oddsratio_to_probs(OR, p0 = p0), p1) - expect_equal(nnt_to_probs(NNT, p0 = p0, odds = TRUE), - probs_to_odds(p1)) + expect_equal(nnt_to_probs(NNT, p0 = p0, odds = TRUE), probs_to_odds(p1)) expect_equal(arr_to_probs(-ARR, p0 = p1), p0) expect_equal(nnt_to_probs(-NNT, p0 = p1), p0) @@ -250,4 +283,3 @@ test_that("between anova", { expect_equal(f2_to_eta2(1 / 3), 0.25) expect_equal(f_to_eta2(1 / sqrt(3)), f2_to_eta2(1 / 3), tolerance = 1e-4) }) - diff --git a/tests/testthat/test-convert_between_CLES.R b/tests/testthat/test-convert_between_CLES.R index f11cbddd6..a3733e81d 100644 --- a/tests/testthat/test-convert_between_CLES.R +++ b/tests/testthat/test-convert_between_CLES.R @@ -8,7 +8,6 @@ test_that("d/rbs_to_cles | numeric", { expect_equal(d_to_u3(0), 0.5) expect_equal(d_to_u2(0), 0.5) - # +ive ----------------------- expect_true(d_to_overlap(1) < 1) expect_true(d_to_u1(1) > 0) @@ -18,7 +17,6 @@ test_that("d/rbs_to_cles | numeric", { expect_true(d_to_u3(1) > 0.5) expect_true(d_to_u2(1) > 0.5) - # -ive ----------------------- expect_true(d_to_overlap(-1) < 1) expect_true(d_to_u1(-1) > 0) @@ -64,8 +62,6 @@ test_that("d_to_cles | from Cohens d | one sided | negative d", { expect_output(print(p1), "lower") expect_output(print(p2), "upper") - - # U1 ----------- u10 <- d_to_u1(d0) u11 <- d_to_u1(d1) @@ -75,7 +71,6 @@ test_that("d_to_cles | from Cohens d | one sided | negative d", { expect_output(print(p1), "lower") expect_output(print(p2), "upper") - # U2 ----------- u20 <- d_to_u2(d0) u21 <- d_to_u2(d1) diff --git a/tests/testthat/test-convert_statistic.R b/tests/testthat/test-convert_statistic.R index 2f78c11fa..ca1580ae2 100644 --- a/tests/testthat/test-convert_statistic.R +++ b/tests/testthat/test-convert_statistic.R @@ -14,7 +14,6 @@ test_that("xtab", { ) expect_equal(res, cramers_v(xtab), ignore_attr = TRUE) - res <- chisq_to_cohens_w( chisq$statistic, n = sum(xtab), @@ -29,19 +28,49 @@ test_that("r", { res2 <- t_to_r(t = res1$statistic, res1$parameter) expect_equal(res2$r, res1$estimate, tolerance = 0.01, ignore_attr = TRUE) - expect_equal(res2$CI_low, res1$conf.int[1], tolerance = 0.02, ignore_attr = TRUE) - expect_equal(res2$CI_high, res1$conf.int[2], tolerance = 0.01, ignore_attr = TRUE) + expect_equal( + res2$CI_low, + res1$conf.int[1], + tolerance = 0.02, + ignore_attr = TRUE + ) + expect_equal( + res2$CI_high, + res1$conf.int[2], + tolerance = 0.01, + ignore_attr = TRUE + ) res3 <- F_to_r(res1$statistic^2, 1, res1$parameter) expect_equal(res3$r, -res1$estimate, tolerance = 0.01, ignore_attr = TRUE) - expect_equal(res3$CI_low, -res1$conf.int[2], tolerance = 0.02, ignore_attr = TRUE) - expect_equal(res3$CI_high, -res1$conf.int[1], tolerance = 0.02, ignore_attr = TRUE) + expect_equal( + res3$CI_low, + -res1$conf.int[2], + tolerance = 0.02, + ignore_attr = TRUE + ) + expect_equal( + res3$CI_high, + -res1$conf.int[1], + tolerance = 0.02, + ignore_attr = TRUE + ) expect_error(F_to_r(3, 2, 3), "df") res4 <- z_to_r(res1$statistic, res1$parameter) expect_equal(res4$r, res1$estimate, tolerance = 0.01, ignore_attr = TRUE) - expect_equal(res4$CI_low, res1$conf.int[1], tolerance = 0.02, ignore_attr = TRUE) - expect_equal(res4$CI_high, res1$conf.int[2], tolerance = 0.02, ignore_attr = TRUE) + expect_equal( + res4$CI_low, + res1$conf.int[1], + tolerance = 0.02, + ignore_attr = TRUE + ) + expect_equal( + res4$CI_high, + res1$conf.int[2], + tolerance = 0.02, + ignore_attr = TRUE + ) }) test_that("d", { diff --git a/tests/testthat/test-effectsize.R b/tests/testthat/test-effectsize.R index e409f9807..ad2cd85a5 100644 --- a/tests/testthat/test-effectsize.R +++ b/tests/testthat/test-effectsize.R @@ -1,22 +1,45 @@ - # htest ------------------------------------------------------------------- test_that("t-test", { x <<- 1:10 y <<- c(1, 1:9) model <- t.test(x, y) - expect_equal(effectsize(model), d <- cohens_d(x, y, pooled_sd = FALSE), ignore_attr = TRUE) + expect_equal( + effectsize(model), + d <- cohens_d(x, y, pooled_sd = FALSE), + ignore_attr = TRUE + ) expect_equal(cohens_d(model), d, ignore_attr = TRUE) - expect_equal(effectsize(model, type = "g"), hedges_g(x, y, pooled_sd = FALSE), ignore_attr = TRUE) + expect_equal( + effectsize(model, type = "g"), + hedges_g(x, y, pooled_sd = FALSE), + ignore_attr = TRUE + ) expect_error(effectsize(model, type = "u1"), "applicable") model <- t.test(x, y, var.equal = TRUE) - expect_equal(effectsize(model, type = "u1"), cohens_u1(x, y), ignore_attr = TRUE) - expect_equal(effectsize(model, type = "u2"), cohens_u2(x, y), ignore_attr = TRUE) - expect_equal(effectsize(model, type = "u3"), cohens_u3(x, y), ignore_attr = TRUE) + expect_equal( + effectsize(model, type = "u1"), + cohens_u1(x, y), + ignore_attr = TRUE + ) + expect_equal( + effectsize(model, type = "u2"), + cohens_u2(x, y), + ignore_attr = TRUE + ) + expect_equal( + effectsize(model, type = "u3"), + cohens_u3(x, y), + ignore_attr = TRUE + ) model <- t.test(x, y, alternative = "less", conf.level = 0.8) - expect_equal(effectsize(model), cohens_d(x, y, pooled_sd = FALSE, alternative = "less", ci = 0.8), ignore_attr = TRUE) + expect_equal( + effectsize(model), + cohens_d(x, y, pooled_sd = FALSE, alternative = "less", ci = 0.8), + ignore_attr = TRUE + ) model <- t.test(x, y, var.equal = TRUE) expect_equal(effectsize(model), cohens_d(x, y), ignore_attr = TRUE) @@ -30,7 +53,8 @@ test_that("t-test", { ## Auto convert y to factor Ts <- t.test(mtcars$mpg ~ mtcars$vs) - expect_equal(effectsize(Ts, verbose = FALSE), + expect_equal( + effectsize(Ts, verbose = FALSE), cohens_d(mtcars$mpg, factor(mtcars$vs), pooled_sd = FALSE), ignore_attr = TRUE ) @@ -38,19 +62,17 @@ test_that("t-test", { # one sample z <<- mtcars$wt model <- t.test(z, mu = 3, var.equal = TRUE) - expect_equal(effectsize(model), - cohens_d(z, mu = 3), - ignore_attr = TRUE - ) + expect_equal(effectsize(model), cohens_d(z, mu = 3), ignore_attr = TRUE) ## Paired sample model <- t.test(x, y, paired = TRUE) - expect_equal(effectsize(model, verbose = FALSE), cohens_d(x, y, paired = TRUE, verbose = FALSE), ignore_attr = TRUE) - - sleep2 <<- reshape(sleep, - direction = "wide", - idvar = "ID", timevar = "group" + expect_equal( + effectsize(model, verbose = FALSE), + cohens_d(x, y, paired = TRUE, verbose = FALSE), + ignore_attr = TRUE ) + + sleep2 <<- reshape(sleep, direction = "wide", idvar = "ID", timevar = "group") tt <- t.test(sleep2$extra.1, sleep2$extra.2, paired = TRUE) es1 <- effectsize(tt, type = "rm_b") @@ -59,7 +81,6 @@ test_that("t-test", { expect_equal(es1, es, ignore_attr = TRUE) expect_equal(es2, es, ignore_attr = TRUE) - ## Missing y <<- rnorm(12) g <<- c(rep(letters[1:2], each = 5), NA, NA) @@ -94,12 +115,20 @@ test_that("Wilcox | CLES", { y <<- c(1, 1:3) Wt <- suppressWarnings(wilcox.test(x, y)) - expect_equal(e <- p_superiority(Wt), p_superiority(x, y, parametric = FALSE), ignore_attr = TRUE) + expect_equal( + e <- p_superiority(Wt), + p_superiority(x, y, parametric = FALSE), + ignore_attr = TRUE + ) expect_equal(effectsize(Wt, type = "p_superiority"), e) expect_error(effectsize(Wt, type = "u1"), "parametric") - expect_equal(e <- cohens_u3(Wt), cohens_u3(x, y, parametric = FALSE), ignore_attr = TRUE) + expect_equal( + e <- cohens_u3(Wt), + cohens_u3(x, y, parametric = FALSE), + ignore_attr = TRUE + ) expect_equal(effectsize(Wt, type = "u3"), e) }) @@ -127,16 +156,28 @@ test_that("Chisq-test", { contingency_table22 <- contingency_table[1:2, 1:2] Xsq4 <- chisq.test(contingency_table22) - expect_equal(effectsize(Xsq4, type = "phi", adjust = FALSE), ph <- phi(contingency_table22, adjust = FALSE)) + expect_equal( + effectsize(Xsq4, type = "phi", adjust = FALSE), + ph <- phi(contingency_table22, adjust = FALSE) + ) expect_equal(phi(Xsq4, adjust = FALSE), ph) - expect_equal(effectsize(Xsq4, type = "oddsratio"), or <- oddsratio(contingency_table22)) + expect_equal( + effectsize(Xsq4, type = "oddsratio"), + or <- oddsratio(contingency_table22) + ) expect_equal(oddsratio(Xsq4), or) - expect_equal(effectsize(Xsq4, type = "riskratio"), rr <- riskratio(contingency_table22)) + expect_equal( + effectsize(Xsq4, type = "riskratio"), + rr <- riskratio(contingency_table22) + ) expect_equal(riskratio(Xsq4), rr) - expect_equal(effectsize(Xsq4, type = "pearsons_c"), pc <- pearsons_c(contingency_table22)) + expect_equal( + effectsize(Xsq4, type = "pearsons_c"), + pc <- pearsons_c(contingency_table22) + ) expect_equal(pearsons_c(Xsq4), pc) expect_equal(effectsize(Xsq4, type = "h"), h <- cohens_h(contingency_table22)) @@ -149,7 +190,10 @@ test_that("Chisq-test", { x <- chisq.test(x = observed.dfc, p = expected.dfc) expect_error(effectsize(x, type = "v"), "goodness") expect_equal(effectsize(x), effectsize(x, type = "fei")) - expect_equal(effectsize(x, type = "fei"), Fei <- fei(observed.dfc, p = expected.dfc)) + expect_equal( + effectsize(x, type = "fei"), + Fei <- fei(observed.dfc, p = expected.dfc) + ) expect_equal(fei(x), Fei) }) @@ -174,21 +218,32 @@ test_that("one way", { onew <- oneway.test(mpg ~ cyl, mtcars) expect_message(effectsize(onew), "var") - onew <- oneway.test(mpg ~ cyl, mtcars, var.equal = TRUE) m <- aov(mpg ~ cyl, mtcars) - expect_equal(eta_squared(m, partial = FALSE)[, -1], effectsize(onew), - tolerance = 0.03, ignore_attr = TRUE + expect_equal( + eta_squared(m, partial = FALSE)[, -1], + effectsize(onew), + tolerance = 0.03, + ignore_attr = TRUE ) - expect_equal(eta_squared(m, partial = FALSE)[, -1], eta_squared(onew, verbose = FALSE), - tolerance = 0.03, ignore_attr = TRUE + expect_equal( + eta_squared(m, partial = FALSE)[, -1], + eta_squared(onew, verbose = FALSE), + tolerance = 0.03, + ignore_attr = TRUE ) - expect_equal(omega_squared(m, partial = FALSE)[, -1], effectsize(onew, type = "omega"), - tolerance = 0.03, ignore_attr = TRUE + expect_equal( + omega_squared(m, partial = FALSE)[, -1], + effectsize(onew, type = "omega"), + tolerance = 0.03, + ignore_attr = TRUE ) - expect_equal(cohens_f(m, partial = FALSE)[, -1], effectsize(onew, type = "f"), - tolerance = 0.03, ignore_attr = TRUE + expect_equal( + cohens_f(m, partial = FALSE)[, -1], + effectsize(onew, type = "f"), + tolerance = 0.03, + ignore_attr = TRUE ) }) @@ -199,52 +254,109 @@ test_that("McNemar", { ) model <- mcnemar.test(Performance) - expect_equal(effectsize(model), g <- cohens_g(Performance), ignore_attr = TRUE) + expect_equal( + effectsize(model), + g <- cohens_g(Performance), + ignore_attr = TRUE + ) expect_equal(cohens_g(model), g, ignore_attr = TRUE) model <- mcnemar.test(mtcars$cyl, mtcars$gear) - expect_equal(effectsize(model), cohens_g(mtcars$cyl, mtcars$gear), ignore_attr = TRUE) + expect_equal( + effectsize(model), + cohens_g(mtcars$cyl, mtcars$gear), + ignore_attr = TRUE + ) }) test_that("htest | rank", { suppressWarnings(ww <- wilcox.test(mtcars$hp, mtcars$mpg + 80)) - expect_equal(effectsize(ww), rbs <- rank_biserial(mtcars$hp, mtcars$mpg + 80), ignore_attr = TRUE) + expect_equal( + effectsize(ww), + rbs <- rank_biserial(mtcars$hp, mtcars$mpg + 80), + ignore_attr = TRUE + ) expect_equal(rank_biserial(ww), rbs, ignore_attr = TRUE) - expect_equal(effectsize(ww, type = "u2", ci = NULL)[[1]], + expect_equal( + effectsize(ww, type = "u2", ci = NULL)[[1]], cohens_u2(mtcars$hp, mtcars$mpg + 80, parametric = FALSE, ci = NULL)[[1]], tolerance = 0.001 ) - expect_equal(effectsize(ww, type = "overlap")[[1]], + expect_equal( + effectsize(ww, type = "overlap")[[1]], p_overlap(mtcars$hp, mtcars$mpg + 80, parametric = FALSE, ci = NULL)[[1]], tolerance = 0.001 ) - RoundingTimes <- matrix( c( - 5.40, 5.50, 5.55, - 5.85, 5.70, 5.75, - 5.20, 5.60, 5.50, - 5.55, 5.50, 5.40, - 5.90, 5.85, 5.70, - 5.45, 5.55, 5.60, - 5.40, 5.40, 5.35, - 5.45, 5.50, 5.35, - 5.25, 5.15, 5.00, - 5.85, 5.80, 5.70, - 5.25, 5.20, 5.10, - 5.65, 5.55, 5.45, - 5.60, 5.35, 5.45, - 5.05, 5.00, 4.95, - 5.50, 5.50, 5.40, - 5.45, 5.55, 5.50, - 5.55, 5.55, 5.35, - 5.45, 5.50, 5.55, - 5.50, 5.45, 5.25, - 5.65, 5.60, 5.40, - 5.70, 5.65, 5.55, - 6.30, 6.30, 6.25 + 5.40, + 5.50, + 5.55, + 5.85, + 5.70, + 5.75, + 5.20, + 5.60, + 5.50, + 5.55, + 5.50, + 5.40, + 5.90, + 5.85, + 5.70, + 5.45, + 5.55, + 5.60, + 5.40, + 5.40, + 5.35, + 5.45, + 5.50, + 5.35, + 5.25, + 5.15, + 5.00, + 5.85, + 5.80, + 5.70, + 5.25, + 5.20, + 5.10, + 5.65, + 5.55, + 5.45, + 5.60, + 5.35, + 5.45, + 5.05, + 5.00, + 4.95, + 5.50, + 5.50, + 5.40, + 5.45, + 5.55, + 5.50, + 5.55, + 5.55, + 5.35, + 5.45, + 5.50, + 5.55, + 5.50, + 5.45, + 5.25, + 5.65, + 5.60, + 5.40, + 5.70, + 5.65, + 5.55, + 6.30, + 6.30, + 6.25 ), nrow = 22, byrow = TRUE, @@ -255,14 +367,26 @@ test_that("htest | rank", { ) ft <- friedman.test(RoundingTimes) W <- kendalls_w(RoundingTimes, verbose = FALSE, ci = NULL) - expect_equal(effectsize(ft, verbose = FALSE, ci = NULL), W, ignore_attr = TRUE) - expect_equal(kendalls_w(ft, verbose = FALSE, ci = NULL), W, ignore_attr = TRUE) + expect_equal( + effectsize(ft, verbose = FALSE, ci = NULL), + W, + ignore_attr = TRUE + ) + expect_equal( + kendalls_w(ft, verbose = FALSE, ci = NULL), + W, + ignore_attr = TRUE + ) X <<- c(2.9, 3.0, 2.5, 2.6, 3.2) # normal subjects Y <<- c(3.8, 2.7, 4.0, 2.4) # with obstructive airway disease Z <<- c(2.8, 3.4, 3.7, 2.2, 2.0) # with asbestosis kt <- kruskal.test(list(X, Y, Z)) - expect_equal(effectsize(kt)[[1]], E <- rank_epsilon_squared(list(X, Y, Z))[[1]], ignore_attr = TRUE) + expect_equal( + effectsize(kt)[[1]], + E <- rank_epsilon_squared(list(X, Y, Z))[[1]], + ignore_attr = TRUE + ) expect_equal(rank_epsilon_squared(kt)[[1]], E, ignore_attr = TRUE) }) @@ -338,17 +462,28 @@ test_that("BayesFactor", { skip_on_cran() set.seed(6) data(raceDolls, package = "BayesFactor") - bf1 <- BayesFactor::contingencyTableBF(raceDolls, sampleType = "poisson", fixedMargin = "cols") + bf1 <- BayesFactor::contingencyTableBF( + raceDolls, + sampleType = "poisson", + fixedMargin = "cols" + ) expect_equal(effectsize(bf1)[[1]], 0.143, tolerance = 0.01) expect_equal(effectsize(bf1, type = "OR")[[1]], 1 / 0.503, tolerance = 0.03) - bf2 <- BayesFactor::ttestBF(mtcars$mpg[mtcars$am == 1], mtcars$mpg[mtcars$am == 0]) + bf2 <- BayesFactor::ttestBF( + mtcars$mpg[mtcars$am == 1], + mtcars$mpg[mtcars$am == 0] + ) expect_equal(effectsize(bf2)[[1]], 1.30, tolerance = 0.03) expect_equal(effectsize(bf2, type = "u1")[[1]], 0.65, tolerance = 0.05) expect_equal(effectsize(bf2, type = "u2")[[1]], 0.74, tolerance = 0.05) expect_equal(effectsize(bf2, type = "u3")[[1]], 0.9, tolerance = 0.05) expect_equal(effectsize(bf2, type = "overlap")[[1]], 0.52, tolerance = 0.05) - expect_equal(effectsize(bf2, type = "p_superiority")[[1]], 0.8, tolerance = 0.05) + expect_equal( + effectsize(bf2, type = "p_superiority")[[1]], + 0.8, + tolerance = 0.05 + ) bf3 <- BayesFactor::correlationBF(iris$Sepal.Length, iris$Sepal.Width) expect_equal(effectsize(bf3)[[1]], -0.116, tolerance = 0.03) @@ -384,10 +519,15 @@ test_that("effectsize | datawizard crosstabs", { pearsons_c(mtcars$cyl, mtcars$am) ) - - xtabs2 <- datawizard::data_tabulate(mtcars, select = c("cyl", "gear"), by = "am") - xtabs3 <- datawizard::data_tabulate(datawizard::data_group(mtcars, select = c("carb")), - select = c("cyl", "gear"), by = "am" + xtabs2 <- datawizard::data_tabulate( + mtcars, + select = c("cyl", "gear"), + by = "am" + ) + xtabs3 <- datawizard::data_tabulate( + datawizard::data_group(mtcars, select = c("carb")), + select = c("cyl", "gear"), + by = "am" ) expect_error(effectsize(xtabs2), regexp = "Multilpe tables") expect_error(effectsize(xtabs3), regexp = "Multilpe tables") @@ -417,10 +557,11 @@ test_that("effectsize | datawizard tables", { pearsons_c(table(mtcars$cyl)) ) - xtabs2 <- datawizard::data_tabulate(mtcars, select = c("cyl", "gear")) - xtabs3 <- datawizard::data_tabulate(datawizard::data_group(mtcars, select = c("carb")), - select = c("cyl", "gear")) + xtabs3 <- datawizard::data_tabulate( + datawizard::data_group(mtcars, select = c("carb")), + select = c("cyl", "gear") + ) expect_error(effectsize(xtabs2), regexp = "Multilpe tables") expect_error(effectsize(xtabs3), regexp = "Multilpe tables") }) @@ -437,7 +578,8 @@ test_that("effectsize | easycorrelation", { test_that("effectsize | other", { m <- lm(mpg ~ ., mtcars) - expect_equal(effectsize(m), + expect_equal( + effectsize(m), parameters::standardize_parameters(m), ignore_attr = TRUE ) diff --git a/tests/testthat/test-equivalence_test.R b/tests/testthat/test-equivalence_test.R index e141a01a8..0afebb9ca 100644 --- a/tests/testthat/test-equivalence_test.R +++ b/tests/testthat/test-equivalence_test.R @@ -5,7 +5,6 @@ test_that("equivalence_test", { ci = 0.9 ) # TOST approach - expect_equal( equivalence_test(ds, range = 0.2)$ROPE_Equivalence, c("Accepted", "Undecided", "Rejected", "Rejected", "Accepted") diff --git a/tests/testthat/test-eta_squared.R b/tests/testthat/test-eta_squared.R index fbf897696..104176af1 100644 --- a/tests/testthat/test-eta_squared.R +++ b/tests/testthat/test-eta_squared.R @@ -37,57 +37,65 @@ test_that("aov", { fit <- aov(Sepal.Length ~ Species * Sepal.Big, df) # eta - expect_equal(eta_squared(fit, partial = FALSE)$Eta2, + expect_equal( + eta_squared(fit, partial = FALSE)$Eta2, c(0.618, 0.046, 0.000), tolerance = 0.01 ) - expect_equal(eta_squared(fit, partial = TRUE)$Eta2_partial, + expect_equal( + eta_squared(fit, partial = TRUE)$Eta2_partial, c(0.649, 0.121, 0.001), tolerance = 0.01 ) # omega - expect_equal(omega_squared(fit, partial = FALSE)$Omega2, + expect_equal( + omega_squared(fit, partial = FALSE)$Omega2, c(0.612, 0.043, 0), tolerance = 0.01 ) - expect_equal(omega_squared(fit, partial = TRUE)$Omega2_partial, + expect_equal( + omega_squared(fit, partial = TRUE)$Omega2_partial, c(0.638, 0.112, 0), tolerance = 0.01 ) # epsilon - expect_equal(epsilon_squared(fit, partial = FALSE)$Epsilon2, + expect_equal( + epsilon_squared(fit, partial = FALSE)$Epsilon2, c(0.614, 0.044, 0), tolerance = 0.001 ) - expect_equal(epsilon_squared(fit, partial = TRUE)$Epsilon2_partial, + expect_equal( + epsilon_squared(fit, partial = TRUE)$Epsilon2_partial, c(0.644, 0.115, 0), tolerance = 0.01 ) # Cohen's f/f2 - expect_equal(cohens_f_squared(fit, partial = FALSE)$Cohens_f2, + expect_equal( + cohens_f_squared(fit, partial = FALSE)$Cohens_f2, c(1.623, 0.049, 0.000), tolerance = 0.001 ) - expect_equal(cohens_f_squared(fit, partial = TRUE)$Cohens_f2_partial, + expect_equal( + cohens_f_squared(fit, partial = TRUE)$Cohens_f2_partial, c(1.850, 0.139, 0.001), tolerance = 0.001 ) - expect_equal(cohens_f(fit, partial = FALSE)$Cohens_f, + expect_equal( + cohens_f(fit, partial = FALSE)$Cohens_f, c(1.273, 0.220, 0.021), tolerance = 0.01 ) - expect_equal(cohens_f(fit, partial = TRUE)$Cohens_f_partial, + expect_equal( + cohens_f(fit, partial = TRUE)$Cohens_f_partial, c(1.360, 0.373, 0.036), tolerance = 0.001 ) expect_equal(cohens_f(fit, squared = TRUE), cohens_f_squared(fit)) expect_equal(cohens_f_squared(fit, squared = FALSE), cohens_f(fit)) - - #### One way-between expect_message(eta_squared(aov(mpg ~ factor(gear), mtcars))) expect_message(eta_squared(aov(mpg ~ factor(gear) + am, mtcars)), regexp = NA) @@ -117,7 +125,8 @@ test_that("aovlist", { res <- eta_squared(model, partial = TRUE) expect_true(all(c("Group", "Parameter") %in% colnames(res))) expect_equal(res$Eta2_partial, c(0.4472423, 0.1217329), tolerance = 0.001) - expect_equal(eta_squared(model, partial = FALSE)$Eta2, + expect_equal( + eta_squared(model, partial = FALSE)$Eta2, c(0.27671136, 0.04641607), tolerance = 0.001 ) @@ -125,7 +134,8 @@ test_that("aovlist", { res <- omega_squared(model, partial = TRUE) expect_true(all(c("Group", "Parameter") %in% colnames(res))) expect_equal(res$Omega2_partial, c(0, 0.04141846), tolerance = 0.001) - expect_equal(omega_squared(model, partial = FALSE)$Omega2, + expect_equal( + omega_squared(model, partial = FALSE)$Omega2, c(0, 0.03287821), tolerance = 0.001 ) @@ -133,29 +143,31 @@ test_that("aovlist", { res <- epsilon_squared(model, partial = TRUE) expect_true(all(c("Group", "Parameter") %in% colnames(res))) expect_equal(res$Epsilon2_partial, c(0, 0.1157174), tolerance = 0.001) - expect_equal(epsilon_squared(model, partial = FALSE)$Epsilon2, + expect_equal( + epsilon_squared(model, partial = FALSE)$Epsilon2, c(0, 0.04412238), tolerance = 0.001 ) - expect_equal( eta_squared(parameters::model_parameters(model)), eta_squared(model) ) - skip_if_not_installed("afex") # non-partial Eta2 should be the same for aov and aovlist data(obk.long, package = "afex") suppressMessages({ - model <- afex::aov_car(value ~ treatment * gender + Error(id / (phase * hour)), - data = obk.long, observed = "gender", + model <- afex::aov_car( + value ~ treatment * gender + Error(id / (phase * hour)), + data = obk.long, + observed = "gender", include_aov = TRUE ) }) - model2 <- aov(value ~ treatment * gender * phase * hour, + model2 <- aov( + value ~ treatment * gender * phase * hour, data = model$data$long, contrasts = list( treatment = contr.sum, @@ -245,8 +257,10 @@ test_that("generalized | between", { data(obk.long, package = "afex") suppressMessages(suppressWarnings( - m <- afex::aov_car(value ~ treatment * gender + Error(id), - data = obk.long, observed = "gender", + m <- afex::aov_car( + value ~ treatment * gender + Error(id), + data = obk.long, + observed = "gender", include_aov = TRUE ) )) @@ -258,7 +272,6 @@ test_that("generalized | between", { eta_squared(Aov, generalized = TRUE, verbose = FALSE)$Eta2_generalized ) - expect_equal( anova(m, es = "ges", observed = "gender")$ges, eta_squared(Aov, generalized = "gender", verbose = FALSE)$Eta2_generalized @@ -267,7 +280,9 @@ test_that("generalized | between", { # in a completely between design, with all measured, # all are equal to total expect_equal( - eta_squared(Aov, generalized = c("gender", "treatment"), verbose = FALSE)[[2]], + eta_squared(Aov, generalized = c("gender", "treatment"), verbose = FALSE)[[ + 2 + ]], eta_squared(Aov, partial = FALSE, verbose = FALSE)[[2]] ) }) @@ -279,47 +294,66 @@ test_that("generalized | within-mixed", { # estimate mixed ANOVA on the full design: suppressMessages( - m <- afex::aov_car(value ~ treatment * gender + Error(id / (phase * hour)), - data = obk.long, observed = "gender", + m <- afex::aov_car( + value ~ treatment * gender + Error(id / (phase * hour)), + data = obk.long, + observed = "gender", include_aov = TRUE ) ) - ef <- eta_squared(m$aov, generalized = "gender") af <- anova(m, es = "ges", observed = "gender") - expect_equal(ef$Eta2_generalized, + expect_equal( + ef$Eta2_generalized, c( - 0.211, 0.083, 0.186, 0.193, 0.099, - 0.002, 0.015, 0.132, 0.001, 0.004, - 0.011, 0.016, 0.008, 0.01, 0.02 + 0.211, + 0.083, + 0.186, + 0.193, + 0.099, + 0.002, + 0.015, + 0.132, + 0.001, + 0.004, + 0.011, + 0.016, + 0.008, + 0.01, + 0.02 ), tolerance = 0.05 ) - expect_equal(ef$Eta2_generalized, - af$ges, - tolerance = 0.1 - ) - + expect_equal(ef$Eta2_generalized, af$ges, tolerance = 0.1) ef <- eta_squared(m$aov, generalized = TRUE) af <- anova(m, es = "ges", observed = NULL) - expect_equal(ef$Eta2_generalized, + expect_equal( + ef$Eta2_generalized, c( - 0.286, 0.111, 0.218, 0.264, 0.142, - 0.004, 0.021, 0.185, 0.002, 0.005, - 0.016, 0.023, 0.013, 0.014, 0.029 + 0.286, + 0.111, + 0.218, + 0.264, + 0.142, + 0.004, + 0.021, + 0.185, + 0.002, + 0.005, + 0.016, + 0.023, + 0.013, + 0.014, + 0.029 ), tolerance = 0.05 ) - expect_equal(ef$Eta2_generalized, - af$ges, - tolerance = 0.1 - ) + expect_equal(ef$Eta2_generalized, af$ges, tolerance = 0.1) }) - # rm-omega ---------------------------------------------------------------- test_that("omega", { skip_if_not_installed("afex") @@ -327,24 +361,24 @@ test_that("omega", { data(obk.long, package = "afex") suppressMessages(suppressWarnings( - m <- afex::aov_car(value ~ treatment * gender + Error(id / (phase)), - data = obk.long, observed = "gender", + m <- afex::aov_car( + value ~ treatment * gender + Error(id / (phase)), + data = obk.long, + observed = "gender", include_aov = TRUE ) )) - ef <- omega_squared(m, partial = TRUE, alternative = "two") - expect_equal(ef$Omega2_partial, + expect_equal( + ef$Omega2_partial, c(0.3115, 0.1814, 0.2221, 0.2637, 0.1512, 0, 0), tolerance = 0.01 ) - expect_equal(ef$CI_low, - c(0, 0, 0, 0, 0, 0, 0), - tolerance = 0.01 - ) + expect_equal(ef$CI_low, c(0, 0, 0, 0, 0, 0, 0), tolerance = 0.01) - expect_equal(ef$CI_high, + expect_equal( + ef$CI_high, c(0.626, 0.553, 0.557, 0.518, 0.355, 0, 0), tolerance = 0.01 ) @@ -362,7 +396,10 @@ test_that("failed CIs", { expect_equal(eta[1, "Eta2_partial"], 1) expect_warning(eta_squared(model, partial = FALSE), regexp = "CIs") - expect_warning(eta <- eta_squared(model, partial = FALSE, verbose = FALSE), regexp = NA) + expect_warning( + eta <- eta_squared(model, partial = FALSE, verbose = FALSE), + regexp = NA + ) expect_identical(nrow(eta), 2L) expect_equal(eta[1, "Eta2"], 0.34, tolerance = 0.01) }) @@ -389,7 +426,6 @@ test_that("include_intercept | car", { expect_identical(nrow(res1), nrow(res0) + 1L) expect_equal(res1[[1]][1], "(Intercept)") - res0 <- omega_squared(AOV, verbose = FALSE) res1 <- omega_squared(AOV, include_intercept = TRUE, verbose = FALSE) expect_identical(nrow(res0), 3L) @@ -397,7 +433,12 @@ test_that("include_intercept | car", { expect_identical(res1[[1]][1], "(Intercept)") # generalized - res1 <- eta_squared(AOV, generalized = "cyl", include_intercept = TRUE, verbose = FALSE) + res1 <- eta_squared( + AOV, + generalized = "cyl", + include_intercept = TRUE, + verbose = FALSE + ) expect_equal(res1[[1]][1], "(Intercept)") expect_equal(res1[[2]][1], 0.784483, tolerance = 0.01) }) @@ -408,7 +449,8 @@ test_that("include_intercept | afex", { data(obk.long, package = "afex") suppressWarnings(suppressMessages( - a <- afex::aov_car(value ~ treatment * gender + Error(id), + a <- afex::aov_car( + value ~ treatment * gender + Error(id), include_aov = TRUE, data = obk.long ) @@ -419,14 +461,18 @@ test_that("include_intercept | afex", { expect_identical(nrow(resE0), 3L) expect_identical(nrow(resE0), nrow(resA0)) - resE1 <- eta_squared(a, include_intercept = TRUE, verbose = FALSE) resA1 <- anova(a, es = "pes", intercept = TRUE) expect_identical(nrow(resE1), nrow(resE0) + 1L) expect_identical(nrow(resE1), nrow(resA1)) skip_if_not_installed("car") - resE1 <- eta_squared(car::Anova(a$aov, type = 3), include_intercept = TRUE, generalized = "gender", verbose = FALSE) + resE1 <- eta_squared( + car::Anova(a$aov, type = 3), + include_intercept = TRUE, + generalized = "gender", + verbose = FALSE + ) resA1 <- anova(a, es = "ges", intercept = TRUE, observed = "gender") expect_equal(resE1[[2]][1], 0.9386555, tolerance = 0.01) expect_equal(resE1[[2]][1], resA1[[5]][1], tolerance = 0.01) @@ -440,11 +486,16 @@ test_that("afex | within-mixed", { data(obk.long, package = "afex") - suppressMessages(mod <- afex::aov_ez("id", "value", obk.long, - between = c("treatment", "gender"), - within = c("phase", "hour"), - observed = "gender" - )) + suppressMessages( + mod <- afex::aov_ez( + "id", + "value", + obk.long, + between = c("treatment", "gender"), + within = c("phase", "hour"), + observed = "gender" + ) + ) x <- eta_squared(mod, generalized = TRUE) a <- anova(mod, observed = "gender") @@ -454,7 +505,6 @@ test_that("afex | within-mixed", { a <- anova(mod, es = "pes") expect_equal(a$pes, x$Eta2_partial) - x <- eta_squared(mod, include_intercept = TRUE) a <- anova(mod, es = "pes", intercept = TRUE) expect_equal(a$pes, x$Eta2_partial) @@ -462,31 +512,99 @@ test_that("afex | within-mixed", { # see issue #389 data <- data.frame( subject = c( - 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, - 2L, 1L, 2L, 1L, 2L, 1L, 2L + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L ), y = c( - 0.0586978983148275, -0.159870038198774, 0.0125690871484012, - -0.0152529928817782, 0.092433880558952, 0.0359796249184537, - -0.00786545388312909, 0.0340005375703463, 0.165294695432772, - 0.0201040753050847, 0.0741924965491503, -0.0345053066539826, - 0.0108194665250311, -0.163941830205729, 0.310344189786906, + 0.0586978983148275, + -0.159870038198774, + 0.0125690871484012, + -0.0152529928817782, + 0.092433880558952, + 0.0359796249184537, + -0.00786545388312909, + 0.0340005375703463, + 0.165294695432772, + 0.0201040753050847, + 0.0741924965491503, + -0.0345053066539826, + 0.0108194665250311, + -0.163941830205729, + 0.310344189786906, -0.106627229564326 ), A = c( - "A1", "A1", "A1", "A1", "A1", "A1", "A1", "A1", "A2", - "A2", "A2", "A2", "A2", "A2", "A2", "A2" + "A1", + "A1", + "A1", + "A1", + "A1", + "A1", + "A1", + "A1", + "A2", + "A2", + "A2", + "A2", + "A2", + "A2", + "A2", + "A2" ), B = c( - "B1", "B1", "B1", "B1", "B2", "B2", "B2", "B2", "B1", - "B1", "B1", "B1", "B2", "B2", "B2", "B2" + "B1", + "B1", + "B1", + "B1", + "B2", + "B2", + "B2", + "B2", + "B1", + "B1", + "B1", + "B1", + "B2", + "B2", + "B2", + "B2" ), C = c( - "C1", "C1", "C2", "C2", "C1", "C1", "C2", "C2", "C1", - "C1", "C2", "C2", "C1", "C1", "C2", "C2" + "C1", + "C1", + "C2", + "C2", + "C1", + "C1", + "C2", + "C2", + "C1", + "C1", + "C2", + "C2", + "C1", + "C1", + "C2", + "C2" ) ) - suppressMessages(mod <- afex::aov_ez("subject", "y", data, within = c("A", "B", "C"))) + suppressMessages( + mod <- afex::aov_ez("subject", "y", data, within = c("A", "B", "C")) + ) tab <- as.data.frame(anova(mod, es = "pes")) res <- eta_squared(mod) @@ -504,10 +622,13 @@ test_that("afex | mixed()", { data(md_15.1, package = "afex") # random intercept plus random slope - suppressMessages(t15.4a <- afex::mixed(iq ~ timecat + (1 + time | id), - data = md_15.1, - method = "S" - )) + suppressMessages( + t15.4a <- afex::mixed( + iq ~ timecat + (1 + time | id), + data = md_15.1, + method = "S" + ) + ) expect_equal( eta_squared(t15.4a), eta_squared(t15.4a$full_model) @@ -517,10 +638,15 @@ test_that("afex | mixed()", { data("stroop", package = "afex") stroop <- subset(stroop, study == 1 & acc == 1 & trialnum < 20) suppressMessages({ - m1 <- afex::mixed(rt ~ condition + (condition | pno), data = stroop, method = "KR") + m1 <- afex::mixed( + rt ~ condition + (condition | pno), + data = stroop, + method = "KR" + ) }) suppressMessages({ - m2 <- afex::mixed(rt ~ condition + (condition | pno), + m2 <- afex::mixed( + rt ~ condition + (condition | pno), data = stroop, test_intercept = TRUE, method = "KR" @@ -574,13 +700,13 @@ test_that("car MVM", { id = 1:8 ) - ds_long <- datawizard::reshape_longer(ds, + ds_long <- datawizard::reshape_longer( + ds, select = 1:4, names_to = "ind_var", values_to = "score" ) - fit <- lm(cbind(I, II, III, IV) ~ 1, data = ds) in_rep <- data.frame(ind_var = gl(4L, 1L)) suppressMessages({ @@ -589,7 +715,10 @@ test_that("car MVM", { eta_car <- effectsize::eta_squared(A_car, ci = NULL)[[2]] - eta_afex <- afex::aov_ez("id", "score", ds_long, + eta_afex <- afex::aov_ez( + "id", + "score", + ds_long, within = "ind_var", anova_table = list(es = "pes") )$anova_table$pes @@ -600,7 +729,10 @@ test_that("car MVM", { data(obk.long, package = "afex") suppressMessages({ - mod <- afex::aov_ez("id", "value", obk.long, + mod <- afex::aov_ez( + "id", + "value", + obk.long, between = c("treatment", "gender"), within = c("phase", "hour"), observed = "gender" @@ -634,8 +766,10 @@ test_that("Anova.mlm Manova", { Anova <- car::Anova(mod, idesign = ~g, idata = data.frame(g = factor(1:3))) mtcars$id <- factor(seq(nrow(mtcars))) - mtcars_long <- datawizard::reshape_longer(mtcars, - select = c("mpg", "qsec", "disp"), names_to = "g" + mtcars_long <- datawizard::reshape_longer( + mtcars, + select = c("mpg", "qsec", "disp"), + names_to = "g" ) a1 <- aov(value ~ am_f * cyl_f * g + Error(id / g), data = mtcars_long) diff --git a/tests/testthat/test-eta_squared_posterior.R b/tests/testthat/test-eta_squared_posterior.R index 2dc79262f..4bfc81327 100644 --- a/tests/testthat/test-eta_squared_posterior.R +++ b/tests/testthat/test-eta_squared_posterior.R @@ -8,20 +8,22 @@ test_that("eta_squared_posterior", { data("mtcars") mtcars$cyl <- factor(mtcars$cyl) - fit_bayes <- rstanarm::stan_glm(mpg ~ cyl * wt + qsec, + fit_bayes <- rstanarm::stan_glm( + mpg ~ cyl * wt + qsec, data = mtcars, family = gaussian(), refresh = 0 ) - # PARTIAL, type = 3 ------------------------------------------------------- mod <- lm(mpg ~ cyl * wt + qsec, data = mtcars) a <- car::Anova(mod, type = 3) es_tab <- eta_squared(a, partial = TRUE, verbose = FALSE) - es_post <- eta_squared_posterior(fit_bayes, - ss_function = car::Anova, type = 3, + es_post <- eta_squared_posterior( + fit_bayes, + ss_function = car::Anova, + type = 3, verbose = FALSE ) expect_equal(colnames(es_post), es_tab$Parameter) @@ -30,14 +32,14 @@ test_that("eta_squared_posterior", { es_tab_bayes <- bayestestR::describe_posterior(es_post) expect_equal(order(es_tab_bayes$Median), order(es_tab$Eta2)) - - # non-PARTIAL, type = 3 --------------------------------------------------- es_tab <- eta_squared(a, partial = FALSE, verbose = FALSE) - es_post <- eta_squared_posterior(fit_bayes, + es_post <- eta_squared_posterior( + fit_bayes, partial = FALSE, - ss_function = car::Anova, type = 3, + ss_function = car::Anova, + type = 3, verbose = FALSE ) expect_equal(colnames(es_post), es_tab$Parameter) diff --git a/tests/testthat/test-format_standardize.R b/tests/testthat/test-format_standardize.R index 3ecebae8f..35b402b6b 100644 --- a/tests/testthat/test-format_standardize.R +++ b/tests/testthat/test-format_standardize.R @@ -4,29 +4,42 @@ test_that("format_standardize", { structure(3:1, .Label = c("+1 SD", "Mean", "-1 SD"), class = "factor") ) - skip_if_not_installed("bayestestR") ref <- bayestestR::distribution_normal(1000) expect_equal( format_standardize(c(-1, 0, 1, 2), reference = ref, digits = 0), - structure(4:1, + structure( + 4:1, .Label = c("+2 SD", "+1 SD", "Mean", "-1 SD"), class = "factor" ) ) expect_equal( - format_standardize(c(-1, 0, 1, 2), reference = ref, robust = TRUE, digits = 0), - structure(4:1, + format_standardize( + c(-1, 0, 1, 2), + reference = ref, + robust = TRUE, + digits = 0 + ), + structure( + 4:1, .Label = c("+2 MAD", "+1 MAD", "Median", "-1 MAD"), class = "factor" ) ) expect_equal( - format_standardize(c(-1, 0, 1, 2), reference = ref, robust = TRUE, digits = 2, protect_integers = FALSE), - structure(4:1, + format_standardize( + c(-1, 0, 1, 2), + reference = ref, + robust = TRUE, + digits = 2, + protect_integers = FALSE + ), + structure( + 4:1, .Label = c("+2.00 MAD", "+1.00 MAD", "Median", "-1.00 MAD"), class = "factor" ) diff --git a/tests/testthat/test-htest_data.R b/tests/testthat/test-htest_data.R index 4ff0bc187..67928889f 100644 --- a/tests/testthat/test-htest_data.R +++ b/tests/testthat/test-htest_data.R @@ -21,9 +21,14 @@ test_that("basic examples", { expect_no_warning(effectsize(x, data = mtcars)) # friedman.test - wb <- aggregate(warpbreaks$breaks, by = list( - w = warpbreaks$wool, t = warpbreaks$tension - ), FUN = mean) + wb <- aggregate( + warpbreaks$breaks, + by = list( + w = warpbreaks$wool, + t = warpbreaks$tension + ), + FUN = mean + ) x <- friedman.test(x ~ w | t, data = wb) expect_error(effectsize(x), "Unable to retrieve data") expect_no_warning(effectsize(x, data = wb)) @@ -108,7 +113,8 @@ test_that("subset and na.action", { some_data <- mtcars some_data$mpg[1] <- NA - tt <- t.test(mpg ~ am, + tt <- t.test( + mpg ~ am, data = some_data, alternative = "less", mu = 1, @@ -117,7 +123,8 @@ test_that("subset and na.action", { na.action = na.omit ) - d1 <- effectsize(tt, + d1 <- effectsize( + tt, data = some_data, alternative = "less", mu = 1, @@ -126,7 +133,8 @@ test_that("subset and na.action", { na.action = na.omit ) - d2 <- cohens_d(mpg ~ am, + d2 <- cohens_d( + mpg ~ am, data = some_data, alternative = "less", mu = 1, @@ -138,10 +146,7 @@ test_that("subset and na.action", { expect_equal(d1, d2, ignore_attr = TRUE) # Paired t.test with formula - sleep2 <- reshape(sleep, - direction = "wide", - idvar = "ID", timevar = "group" - ) + sleep2 <- reshape(sleep, direction = "wide", idvar = "ID", timevar = "group") sleep2$ID <- as.numeric(sleep2$ID) sleep2$extra.2[1] <- NA @@ -210,9 +215,14 @@ test_that("subset and na.action", { expect_equal(d1, d2, ignore_attr = TRUE) # friedman.test - wb <- aggregate(warpbreaks$breaks, by = list( - w = warpbreaks$wool, t = warpbreaks$tension - ), FUN = mean) + wb <- aggregate( + warpbreaks$breaks, + by = list( + w = warpbreaks$wool, + t = warpbreaks$tension + ), + FUN = mean + ) new_row <- data.frame(w = "B", t = "H", x = 99, stringsAsFactors = FALSE) wb <- rbind(wb, wb[6, ], new_row) wb$x[7] <- NA diff --git a/tests/testthat/test-interpret.R b/tests/testthat/test-interpret.R index 2eff82a83..a4cfd1eec 100644 --- a/tests/testthat/test-interpret.R +++ b/tests/testthat/test-interpret.R @@ -1,6 +1,9 @@ # interpret generic ---- test_that("interpret generic", { - rules_grid <- rules(c(0.01, 0.05), c("very significant", "significant", "not significant")) + rules_grid <- rules( + c(0.01, 0.05), + c("very significant", "significant", "not significant") + ) expect_identical(interpret(0.001, rules_grid)[1], "very significant") expect_identical(interpret(0.021, rules_grid)[1], "significant") expect_identical(interpret(0.08, rules_grid)[1], "not significant") @@ -14,7 +17,6 @@ test_that("interpret generic", { expect_error(rules(1), NA) expect_error(rules("a"), "must be numeric") - r1 <- rules(c(0, 1), labels = c("some", "few", "many")) r2 <- rules(c(0, 1), labels = c("some", "few", "many"), right = FALSE) @@ -51,39 +53,56 @@ test_that("interpret_r", { expect_identical(interpret_r(0.21, "cohen1988")[1], "small") expect_identical(interpret_r(0.21, "lovakov2021")[1], "small") expect_identical(interpret_r(0.7, "evans1996")[1], "strong") - expect_identical(interpret_r(c(0.5, -0.08), "cohen1988")[1:2], c("large", "very small")) + expect_identical( + interpret_r(c(0.5, -0.08), "cohen1988")[1:2], + c("large", "very small") + ) expect_identical(interpret_r(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_r(0.6, "DUPA"), "must be") }) - test_that("interpret_p", { expect_identical(interpret_p(0.021)[1], "significant") expect_identical(interpret_p(0.08)[1], "not significant") - expect_identical(interpret_p(c(0.01, 0.08))[1:2], c("significant", "not significant")) + expect_identical( + interpret_p(c(0.01, 0.08))[1:2], + c("significant", "not significant") + ) expect_identical(interpret_p(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_p(0.6, "DUPA"), "must be") }) test_that("interpret_direction", { - expect_identical(interpret_direction(c(0.01, -0.08))[1:2], c("positive", "negative")) + expect_identical( + interpret_direction(c(0.01, -0.08))[1:2], + c("positive", "negative") + ) }) test_that("interpret_cohens_d", { expect_identical(interpret_cohens_d(0.021)[1], "very small") expect_identical(interpret_cohens_d(1.3, "sawilowsky2009")[1], "very large") - expect_identical(interpret_cohens_d(c(0.45, 0.85), "cohen1988")[1:2], c("small", "large")) - expect_identical(interpret_cohens_d(c(0.45, 0.85), "lovakov2021")[1:2], c("medium", "large")) + expect_identical( + interpret_cohens_d(c(0.45, 0.85), "cohen1988")[1:2], + c("small", "large") + ) + expect_identical( + interpret_cohens_d(c(0.45, 0.85), "lovakov2021")[1:2], + c("medium", "large") + ) expect_identical(interpret_cohens_d(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_cohens_d(0.6, "DUPA"), "must be") }) test_that("interpret_cohens_g", { expect_identical(interpret_cohens_g(0.021)[1], "very small") - expect_identical(interpret_cohens_g(c(0.10, 0.35), "cohen1988")[1:2], c("small", "large")) + expect_identical( + interpret_cohens_g(c(0.10, 0.35), "cohen1988")[1:2], + c("small", "large") + ) expect_identical(interpret_cohens_g(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_cohens_g(0.6, "DUPA"), "must be") }) @@ -91,8 +110,14 @@ test_that("interpret_cohens_g", { test_that("interpret_rope", { expect_identical(interpret_rope(0, ci = 0.9)[1], "significant") - expect_identical(interpret_rope(c(0.50, 1), ci = 0.9)[1:2], c("undecided", "negligible")) - expect_identical(interpret_rope(c(0.98, 0.991), ci = 1)[1:2], c("probably negligible", "negligible")) + expect_identical( + interpret_rope(c(0.50, 1), ci = 0.9)[1:2], + c("undecided", "negligible") + ) + expect_identical( + interpret_rope(c(0.98, 0.991), ci = 1)[1:2], + c("probably negligible", "negligible") + ) expect_identical(interpret_rope(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_rope(0.6, "DUPA"), "must be") }) @@ -102,21 +127,42 @@ test_that("interpret_oddsratio", { # Chen 2010, table 1 row 6 OR <- c(1.4, 2.5, 4.4, 7.5) p0 <- 0.06 - expect_equal(interpret_oddsratio(OR, p0 = p0), c("very small", "small", "medium", "large"), ignore_attr = TRUE) - expect_equal(interpret_oddsratio(OR), c("very small", "medium", "large", "large"), ignore_attr = TRUE) + expect_equal( + interpret_oddsratio(OR, p0 = p0), + c("very small", "small", "medium", "large"), + ignore_attr = TRUE + ) + expect_equal( + interpret_oddsratio(OR), + c("very small", "medium", "large", "large"), + ignore_attr = TRUE + ) - expect_equal(interpret_oddsratio( - c(0.1, 0.5, 2, 10), - rules(3, c("A", "B")) - ), c("B", "A", "A", "B"), ignore_attr = TRUE) + expect_equal( + interpret_oddsratio( + c(0.1, 0.5, 2, 10), + rules(3, c("A", "B")) + ), + c("B", "A", "A", "B"), + ignore_attr = TRUE + ) }) test_that("interpret_r2", { expect_identical(interpret_r2(0.4)[1], "substantial") - expect_identical(interpret_r2(c(0, 0.4), "falk1992")[1:2], c("negligible", "adequate")) - expect_identical(interpret_r2(c(0.1, 0.4), "chin1998")[1:2], c("very weak", "moderate")) - expect_identical(interpret_r2(c(0.1, 0.4), "hair2011")[1:2], c("very weak", "weak")) + expect_identical( + interpret_r2(c(0, 0.4), "falk1992")[1:2], + c("negligible", "adequate") + ) + expect_identical( + interpret_r2(c(0.1, 0.4), "chin1998")[1:2], + c("very weak", "moderate") + ) + expect_identical( + interpret_r2(c(0.1, 0.4), "hair2011")[1:2], + c("very weak", "weak") + ) expect_identical(interpret_r2(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_r2(0.6, "DUPA"), "must be") }) @@ -133,33 +179,50 @@ test_that("interpret_bf", { interpret_bf(c(0.8, 3.5), "raftery1995")[1:2], c("weak evidence against", "positive evidence in favour of") ) - expect_identical(interpret_bf(2, rules(0.5, c("A", "B")))[1], "B evidence in favour of") + expect_identical( + interpret_bf(2, rules(0.5, c("A", "B")))[1], + "B evidence in favour of" + ) expect_error(interpret_bf(2, "DUPA"), "must be") skip_on_cran() # just in case there are changes in insight bf <- c(10^seq(-4, 4), NA) - expect_identical(interpret_bf(bf, include_value = TRUE, protect_ratio = TRUE, exact = TRUE), + expect_identical( + interpret_bf(bf, include_value = TRUE, protect_ratio = TRUE, exact = TRUE), c( - "extreme evidence (BF = 1/1.00e+04) against", "extreme evidence (BF = 1/1000.00) against", - "very strong evidence (BF = 1/100.00) against", "moderate evidence (BF = 1/10.00) against", - "no evidence (BF = 1.00) against or in favour of", "strong evidence (BF = 10.00) in favour of", - "extreme evidence (BF = 100.00) in favour of", "extreme evidence (BF = 1000.00) in favour of", - "extreme evidence (BF = 1.00e+04) in favour of", "" + "extreme evidence (BF = 1/1.00e+04) against", + "extreme evidence (BF = 1/1000.00) against", + "very strong evidence (BF = 1/100.00) against", + "moderate evidence (BF = 1/10.00) against", + "no evidence (BF = 1.00) against or in favour of", + "strong evidence (BF = 10.00) in favour of", + "extreme evidence (BF = 100.00) in favour of", + "extreme evidence (BF = 1000.00) in favour of", + "extreme evidence (BF = 1.00e+04) in favour of", + "" ), ignore_attr = TRUE ) }) - test_that("interpret_omega_squared", { expect_identical(interpret_omega_squared(0.1)[1], "medium") - expect_identical(interpret_omega_squared(c(0.1, 0.25))[1:2], c("medium", "large")) - expect_identical(interpret_omega_squared(0.6, rules(0.5, c("A", "B")))[1], "B") + expect_identical( + interpret_omega_squared(c(0.1, 0.25))[1:2], + c("medium", "large") + ) + expect_identical( + interpret_omega_squared(0.6, rules(0.5, c("A", "B")))[1], + "B" + ) expect_error(interpret_omega_squared(0.6, "DUPA"), "must be") # these should be same - expect_identical(interpret_eta_squared(0.1)[1], interpret_omega_squared(0.1)[1]) + expect_identical( + interpret_eta_squared(0.1)[1], + interpret_omega_squared(0.1)[1] + ) expect_identical( interpret_eta_squared(c(0.1, 0.25))[1:2], interpret_omega_squared(c(0.1, 0.25))[1:2] @@ -181,7 +244,10 @@ test_that("interpret_kendalls_w", { test_that("interpret_rhat", { expect_identical(interpret_rhat(1)[1], "converged") expect_identical(interpret_rhat(c(1, 1.02))[1:2], c("converged", "failed")) - expect_identical(interpret_rhat(c(1, 1.02), "gelman1992")[1:2], c("converged", "converged")) + expect_identical( + interpret_rhat(c(1, 1.02), "gelman1992")[1:2], + c("converged", "converged") + ) expect_identical(interpret_rhat(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_rhat(0.6, "DUPA"), "must be") }) @@ -189,23 +255,66 @@ test_that("interpret_rhat", { test_that("interpret_ess", { expect_identical(interpret_ess(1000)[1], "sufficient") - expect_identical(interpret_ess(c(1000, 800))[1:2], c("sufficient", "insufficient")) + expect_identical( + interpret_ess(c(1000, 800))[1:2], + c("sufficient", "insufficient") + ) expect_identical(interpret_ess(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_ess(0.6, "DUPA"), "must be") }) test_that("interpret_fit", { - expect_equal(interpret_gfi(c(0.5, 0.99)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_agfi(c(0.5, 0.99)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_nfi(c(0.5, 0.99)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_nnfi(c(0.5, 0.99)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_cfi(c(0.5, 0.99)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_rfi(c(0.5, 0.99)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_ifi(c(0.5, 0.99)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_pnfi(c(0.5, 0.99)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_rmsea(c(0.1, 0.05)), c("poor", "satisfactory"), ignore_attr = TRUE) - expect_equal(interpret_srmr(c(0.1, 0.05)), c("poor", "satisfactory"), ignore_attr = TRUE) + expect_equal( + interpret_gfi(c(0.5, 0.99)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_agfi(c(0.5, 0.99)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_nfi(c(0.5, 0.99)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_nnfi(c(0.5, 0.99)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_cfi(c(0.5, 0.99)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_rfi(c(0.5, 0.99)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_ifi(c(0.5, 0.99)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_pnfi(c(0.5, 0.99)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_rmsea(c(0.1, 0.05)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) + expect_equal( + interpret_srmr(c(0.1, 0.05)), + c("poor", "satisfactory"), + ignore_attr = TRUE + ) cr <- rules(0.5, c("A", "B")) expect_equal(interpret_gfi(0.6, cr), "B", ignore_attr = TRUE) @@ -239,28 +348,62 @@ test_that("interpret_fit", { dem60 ~ ind60 " model <- lavaan::sem(structure, data = lavaan::PoliticalDemocracy) int <- interpret(model) - expect_identical(int$Name, c("GFI", "AGFI", "NFI", "NNFI", "CFI", "RMSEA", "SRMR", "RFI", "PNFI", "IFI")) - expect_equal(int$Value, c(0.9666, 0.9124, 0.9749, 1.0001, 1, 0, 0.0273, 0.9529, 0.5199, 1.0001), tolerance = 0.001) + expect_identical( + int$Name, + c( + "GFI", + "AGFI", + "NFI", + "NNFI", + "CFI", + "RMSEA", + "SRMR", + "RFI", + "PNFI", + "IFI" + ) + ) + expect_equal( + int$Value, + c(0.9666, 0.9124, 0.9749, 1.0001, 1, 0, 0.0273, 0.9529, 0.5199, 1.0001), + tolerance = 0.001 + ) int2 <- interpret(performance::model_performance(model)) expect_identical(int, int2) }) test_that("interpret_icc", { - expect_equal(interpret_icc(c(0.45, 0.55, 0.8, 0.95)), c("poor", "moderate", "good", "excellent"), ignore_attr = TRUE) + expect_equal( + interpret_icc(c(0.45, 0.55, 0.8, 0.95)), + c("poor", "moderate", "good", "excellent"), + ignore_attr = TRUE + ) expect_identical(interpret_icc(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_icc(0.6, "DUPA"), "must be") }) test_that("interpret_vif", { - expect_equal(interpret_vif(c(1, 5.5, 10)), c("low", "moderate", "high"), ignore_attr = TRUE) + expect_equal( + interpret_vif(c(1, 5.5, 10)), + c("low", "moderate", "high"), + ignore_attr = TRUE + ) expect_identical(interpret_icc(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_icc(0.6, "DUPA"), "must be") }) test_that("interpret_pd", { - expect_equal(interpret_pd(c(0.9, 0.99)), c("not significant", "significant"), ignore_attr = TRUE) - expect_equal(interpret_pd(c(0.9, 0.99), "makowski2019"), c("uncertain", "likely existing"), ignore_attr = TRUE) + expect_equal( + interpret_pd(c(0.9, 0.99)), + c("not significant", "significant"), + ignore_attr = TRUE + ) + expect_equal( + interpret_pd(c(0.9, 0.99), "makowski2019"), + c("uncertain", "likely existing"), + ignore_attr = TRUE + ) expect_identical(interpret_pd(0.6, rules(0.5, c("A", "B")))[1], "B") expect_error(interpret_pd(0.6, "DUPA"), "must be") }) @@ -274,7 +417,6 @@ test_that("interpret effectsize_table", { expect_output(print(d_), "large") expect_output(print(d_), "Interpretation rule: cohen1988") - V <- cramers_v(matrix(c(71, 30, 50, 100), 2)) V_ <- interpret(V, rules = "funder2019") expect_equal(V_[["Interpretation"]], "large", ignore_attr = TRUE) diff --git a/tests/testthat/test-mahalanobis_D.R b/tests/testthat/test-mahalanobis_D.R index b07cb6cc7..75e92e11f 100644 --- a/tests/testthat/test-mahalanobis_D.R +++ b/tests/testthat/test-mahalanobis_D.R @@ -7,7 +7,6 @@ test_that("mahalanobis_d | two sample | vs cohens_d", { D = sample(bayestestR::distribution_normal(1000, sd = 17)) ) - # Simple: y <- within(x, { B <- B + 15 @@ -17,8 +16,10 @@ test_that("mahalanobis_d | two sample | vs cohens_d", { expect_equal(D[[1]], d[[1]], tolerance = 0.01) expect_equal(D[[3]], d[[3]], tolerance = 0.1) expect_equal(D[[4]], d[[4]], tolerance = 0.1) - expect_equal(D[[1]], sqrt(mahalanobis(rep(0, 4), colMeans(x) - colMeans(y), cov_pooled(x, y)))) # TRUE! - + expect_equal( + D[[1]], + sqrt(mahalanobis(rep(0, 4), colMeans(x) - colMeans(y), cov_pooled(x, y))) + ) # TRUE! # Standardized: y2 <- within(y, { @@ -26,14 +27,14 @@ test_that("mahalanobis_d | two sample | vs cohens_d", { }) d <- unlist(mapply(cohens_d, x, y2, MoreArgs = list(ci = NULL))) R <- cov2cor(cov_pooled(x, y2)) - expect_equal(c(sqrt(t(d) %*% R %*% d)), + expect_equal( + c(sqrt(t(d) %*% R %*% d)), mahalanobis_d(x, y2, ci = NULL)[[1]], tolerance = 0.01 ) }) - test_that("mahalanobis_d | one sample | vs cohens_d", { set.seed(456) x <- data.frame( @@ -43,7 +44,6 @@ test_that("mahalanobis_d | one sample | vs cohens_d", { D = sample(bayestestR::distribution_normal(1000, sd = 17)) ) - # Simple: D <- mahalanobis_d(x, alternative = "two") d <- cohens_d(x$B) @@ -55,7 +55,8 @@ test_that("mahalanobis_d | one sample | vs cohens_d", { # Standardized: d <- unlist(mapply(cohens_d, x, MoreArgs = list(ci = NULL))) R <- cor(x) - expect_equal(c(sqrt(t(d) %*% R %*% d)), + expect_equal( + c(sqrt(t(d) %*% R %*% d)), mahalanobis_d(x, ci = NULL)[[1]], tolerance = 0.01 ) @@ -64,15 +65,24 @@ test_that("mahalanobis_d | one sample | vs cohens_d", { test_that("mahalanobis_d | mu types", { mu <- 0 - expect_error(D1 <- mahalanobis_d(mtcars[, c("mpg", "hp")], mu = mu), regexp = NA) + expect_error( + D1 <- mahalanobis_d(mtcars[, c("mpg", "hp")], mu = mu), + regexp = NA + ) mu <- 2 - expect_error(D2 <- mahalanobis_d(mtcars[, c("mpg", "hp")], mu = mu), regexp = NA) + expect_error( + D2 <- mahalanobis_d(mtcars[, c("mpg", "hp")], mu = mu), + regexp = NA + ) expect_false(D1[[1]] == D2[[1]]) mu <- list(mpg = 3, hp = -14) - expect_error(D3 <- mahalanobis_d(mtcars[, c("mpg", "hp")], mu = mu), regexp = NA) + expect_error( + D3 <- mahalanobis_d(mtcars[, c("mpg", "hp")], mu = mu), + regexp = NA + ) expect_equal(attr(D3, "mu"), dist(rbind(mu, 0)), ignore_attr = TRUE) diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R index 4e217b150..6c664709f 100644 --- a/tests/testthat/test-print.R +++ b/tests/testthat/test-print.R @@ -4,7 +4,11 @@ test_that("print | effectsize table", { expect_output(print(d), "[-1.37, 1.16]", fixed = TRUE) expect_output(print(d, digits = 4), "[-1.3730, 1.1595]", fixed = TRUE) expect_output(print(d, digits = "signif4"), "[-1.373, 1.16]", fixed = TRUE) - expect_output(print(d, digits = "scientific4"), "[-1.3730e+00, 1.1595e+00]", fixed = TRUE) + expect_output( + print(d, digits = "scientific4"), + "[-1.3730e+00, 1.1595e+00]", + fixed = TRUE + ) ## alternative + rounded bound RCT <- matrix(c(71, 30, 31, 13, 50, 100, 4, 5, 7), nrow = 3, byrow = TRUE) @@ -14,19 +18,25 @@ test_that("print | effectsize table", { expect_output(print(V1), regexp = "[1.00]", fixed = TRUE) expect_output(print(V1, digits = "signif4"), regexp = "[1]", fixed = TRUE) - expect_output(print(V1, digits = "scientific2"), regexp = "[1.00e+00]", fixed = TRUE) + expect_output( + print(V1, digits = "scientific2"), + regexp = "[1.00e+00]", + fixed = TRUE + ) expect_error(expect_output(print(V2), regexp = "fixed")) expect_output(print(w), regexp = "[1.41~]", fixed = TRUE) expect_output(print(w, digits = "signif4"), regexp = "[1.414]", fixed = TRUE) - expect_output(print(w, digits = "scientific2"), regexp = "[1.41e+00]", fixed = TRUE) - + expect_output( + print(w, digits = "scientific2"), + regexp = "[1.41e+00]", + fixed = TRUE + ) ## Column name expect_output(print(d), "Cohen's d") expect_output(print(V1), "Cramer's V") expect_output(print(w), "Cohen's w") - ## Interpretation d_ <- interpret(d, rules = "sawilowsky2009") expect_output(print(d_), regexp = "sawilowsky2009") @@ -78,7 +88,11 @@ test_that("print | effectsize_anova", { e1 <- eta_squared(a) expect_output(print(e1), regexp = "(Type I)", fixed = TRUE) expect_output(print(e1), regexp = "Eta2 (partial)", fixed = TRUE) - expect_output(print(e1), regexp = "One-sided CIs: upper bound fixed at [1.00]", fixed = TRUE) + expect_output( + print(e1), + regexp = "One-sided CIs: upper bound fixed at [1.00]", + fixed = TRUE + ) e2 <- eta_squared(a, generalized = "gear") expect_output(print(e2), regexp = "Observed variables: gear", fixed = TRUE) @@ -102,7 +116,11 @@ test_that("print | equivalence_test_effectsize", { expect_output(print(equtest2), regexp = "Conditional") equtest3 <- equivalence_test(d, rule = "bayes") - expect_output(print(equtest3), regexp = "Using Bayesian guidlines", fixed = TRUE) + expect_output( + print(equtest3), + regexp = "Using Bayesian guidlines", + fixed = TRUE + ) }) # Rules ----------- @@ -113,26 +131,29 @@ test_that("rules", { expect_output(print(r1), regexp = "<=") expect_output(print(r1), regexp = "XX") expect_output(print(r1), regexp = "1 < b <= 2") - expect_output(print(r1, digits = "scientific1"), - regexp = "2.0e+00 < c <= 3.0e+00", fixed = TRUE + expect_output( + print(r1, digits = "scientific1"), + regexp = "2.0e+00 < c <= 3.0e+00", + fixed = TRUE ) - r2 <- rules(c(1, 2, 3.1), letters[1:3], name = "YY") expect_output(print(r2), regexp = "Values") expect_output(print(r2), regexp = "YY") expect_output(print(r2), regexp = "b ~ 2") expect_output(print(r2), regexp = "c ~ 3.1") expect_output(print(r2, digits = "signif3"), regexp = "c ~ 3.1") - expect_output(print(r2, digits = "scientific1"), regexp = "a ~ 1.0e+00", fixed = TRUE) - + expect_output( + print(r2, digits = "scientific1"), + regexp = "a ~ 1.0e+00", + fixed = TRUE + ) expect_output(print(interpret(0, r1)), '"a"') expect_output(print(interpret(0, r1)), "XX") }) - test_that("printing symbols works as expected", { skip_if_not(l10n_info()[["UTF-8"]]) diff --git a/tests/testthat/test-r2_semipartial.R b/tests/testthat/test-r2_semipartial.R index 3faef09d9..b4a2ed8d6 100644 --- a/tests/testthat/test-r2_semipartial.R +++ b/tests/testthat/test-r2_semipartial.R @@ -5,25 +5,45 @@ test_that("r2_semipartial basic", { sr2_trms <- r2_semipartial(m, type = "terms") sr2_pars <- r2_semipartial(m, type = "parameters") - expect_equal(sr2_trms[[2]], c(0.0162, 0.0469, 0.0023, 6e-04, 4e-04), tolerance = 0.01) - expect_equal(sr2_pars[[2]], c(0.0091, 0, 0.0469, 0.0023, 6e-04, 4e-04), tolerance = 0.01) + expect_equal( + sr2_trms[[2]], + c(0.0162, 0.0469, 0.0023, 6e-04, 4e-04), + tolerance = 0.01 + ) + expect_equal( + sr2_pars[[2]], + c(0.0091, 0, 0.0469, 0.0023, 6e-04, 4e-04), + tolerance = 0.01 + ) # CI # Alternative ------------------------------------------------------------- - expect_equal(r2_semipartial(m, alternative = "greater")[c(4, 5)], + expect_equal( + r2_semipartial(m, alternative = "greater")[c(4, 5)], data.frame(CI_low = c(0, 0.0004, 0, 0, 0), CI_high = 1), - ignore_attr = TRUE, tolerance = 0.01 + ignore_attr = TRUE, + tolerance = 0.01 ) - expect_equal(r2_semipartial(m, alternative = "less")[c(4, 5)], - data.frame(CI_low = rep(0, 5), CI_high = c(0.0479, 0.1033, 0.0139, 0.0062, 0.0053)), - ignore_attr = TRUE, tolerance = 0.01 + expect_equal( + r2_semipartial(m, alternative = "less")[c(4, 5)], + data.frame( + CI_low = rep(0, 5), + CI_high = c(0.0479, 0.1033, 0.0139, 0.0062, 0.0053) + ), + ignore_attr = TRUE, + tolerance = 0.01 ) - expect_equal(r2_semipartial(m, alternative = "two.sided")[c(4, 5)], - data.frame(CI_low = rep(0, 5), CI_high = c(0.054, 0.1141, 0.0161, 0.0073, 0.0062)), - ignore_attr = TRUE, tolerance = 0.01 + expect_equal( + r2_semipartial(m, alternative = "two.sided")[c(4, 5)], + data.frame( + CI_low = rep(0, 5), + CI_high = c(0.054, 0.1141, 0.0161, 0.0073, 0.0062) + ), + ignore_attr = TRUE, + tolerance = 0.01 ) }) diff --git a/tests/testthat/test-rankES.R b/tests/testthat/test-rankES.R index 9e49ad756..dbabeeebc 100644 --- a/tests/testthat/test-rankES.R +++ b/tests/testthat/test-rankES.R @@ -10,7 +10,6 @@ test_that("rank_biserial", { expect_equal(rRB1$CI_low, 0.2953631, tolerance = 0.01) expect_equal(rRB1$CI_high, 0.9441559, tolerance = 0.01) - A <- c(48, 48, 77, 86, 85, 85, 16) B <- c(14, 34, 34, 77) expect_equal(rank_biserial(A, B)[[1]], 0.6071429, tolerance = 0.01) @@ -88,37 +87,183 @@ test_that("kendalls_w", { # Ties dat <- data.frame( pno = c( - 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 3L, 3L, - 3L, 3L, 4L, 4L, 4L, 4L, 5L, 5L, 5L, 5L, 6L, 6L, 6L, 6L, 7L, 7L, - 7L, 7L, 8L, 8L, 8L, 8L, 9L, 9L, 9L, 9L, 10L, 10L, 10L, 10L + 1L, + 1L, + 1L, + 1L, + 2L, + 2L, + 2L, + 2L, + 3L, + 3L, + 3L, + 3L, + 4L, + 4L, + 4L, + 4L, + 5L, + 5L, + 5L, + 5L, + 6L, + 6L, + 6L, + 6L, + 7L, + 7L, + 7L, + 7L, + 8L, + 8L, + 8L, + 8L, + 9L, + 9L, + 9L, + 9L, + 10L, + 10L, + 10L, + 10L ), condition = c( - 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, - 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, - 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 1L, 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, 2L ), congruency = c( - 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, - 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, - 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, - 1L, 2L + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L ), mrt = c( - 0.86, 0.86, 0.86, 0.78, 0.56, 0.56, 0.59, 0.66, 0.48, - 0.5, 0.47, 0.51, 0.48, 0.52, 0.45, 0.47, 0.65, 0.79, 0.7, - 0.81, 0.58, 0.6, 0.57, 0.6, 0.53, 0.61, 0.47, 0.49, 0.56, - 0.64, 0.56, 0.6, 0.56, 0.66, 0.59, 0.63, 0.7, 0.92, 0.8, + 0.86, + 0.86, + 0.86, + 0.78, + 0.56, + 0.56, + 0.59, + 0.66, + 0.48, + 0.5, + 0.47, + 0.51, + 0.48, + 0.52, + 0.45, + 0.47, + 0.65, + 0.79, + 0.7, + 0.81, + 0.58, + 0.6, + 0.57, + 0.6, + 0.53, + 0.61, + 0.47, + 0.49, + 0.56, + 0.64, + 0.56, + 0.6, + 0.56, + 0.66, + 0.59, + 0.63, + 0.7, + 0.92, + 0.8, 0.96 ) ) dat - W <- kendalls_w(mrt ~ interaction(condition, congruency) | pno, data = dat, verbose = FALSE) + W <- kendalls_w( + mrt ~ interaction(condition, congruency) | pno, + data = dat, + verbose = FALSE + ) expect_equal(W[[1]], 0.4011, tolerance = 0.01) - - # singular ties m <- rbind( c(1, 2, 3, 4), @@ -129,7 +274,10 @@ test_that("kendalls_w", { expect_warning(kendalls_w(m, ci = NULL), "contain ties") expect_warning(W <- kendalls_w(m, ci = NULL), "unique ranking") expect_equal(W[[1]], 0.4666667, tolerance = 0.001) - expect_equal(kendalls_w(t(m), blocks_on_rows = FALSE, ci = NULL, verbose = FALSE)[[1]], W[[1]]) + expect_equal( + kendalls_w(t(m), blocks_on_rows = FALSE, ci = NULL, verbose = FALSE)[[1]], + W[[1]] + ) m[1, 1] <- NA warns <- capture_warnings(W1 <- kendalls_w(m, ci = NULL)) diff --git a/tests/testthat/test-rm_d.R b/tests/testthat/test-rm_d.R index ed0c09e28..b95cee9b5 100644 --- a/tests/testthat/test-rm_d.R +++ b/tests/testthat/test-rm_d.R @@ -1,9 +1,6 @@ test_that("rm_d | paired data", { data("sleep") - sleep2 <- reshape(sleep, - direction = "wide", - idvar = "ID", timevar = "group" - ) + sleep2 <- reshape(sleep, direction = "wide", idvar = "ID", timevar = "group") d1 <- rm_d( sleep$extra[sleep$group == 1], @@ -16,7 +13,9 @@ test_that("rm_d | paired data", { expect_equal(d1, d3) d_z <- rm_d(Pair(extra.1, extra.2) ~ 1, data = sleep2, method = "z") - d_z2 <- hedges_g(sleep$extra[sleep$group == 1] - sleep$extra[sleep$group == 2]) + d_z2 <- hedges_g( + sleep$extra[sleep$group == 1] - sleep$extra[sleep$group == 2] + ) expect_equal(d_z[[1]], d_z2[[1]]) expect_equal(d_z$CI_low, d_z2$CI_low, tolerance = 0.01) @@ -33,19 +32,30 @@ test_that("rm_d | paired data", { expect_no_error(d2NA <- rm_d(Pair(extra.1, extra.2) ~ 1, data = sleep2)) expect_equal(d1NA, d2NA) - # equal with equal variance: dat <- data.frame( V1 = c( - -0.32150435528124, -4.02978032779713, 0.159645811226589, - 1.95179927058772, 0.168527299289471, 3.4499229496418, - -1.87888939495506, 0.431333839911973, -0.26004200470096, + -0.32150435528124, + -4.02978032779713, + 0.159645811226589, + 1.95179927058772, + 0.168527299289471, + 3.4499229496418, + -1.87888939495506, + 0.431333839911973, + -0.26004200470096, 0.328986912076835 ), V2 = c( - 2.50107579495566, -0.32926747002329, 4.01118960037018, - 1.44969284040984, -1.46241877172319, 1.25068499614667, - 0.028928469929524, 3.05532100575796, -1.67014771817319, + 2.50107579495566, + -0.32926747002329, + 4.01118960037018, + 1.44969284040984, + -1.46241877172319, + 1.25068499614667, + 0.028928469929524, + 3.05532100575796, + -1.67014771817319, 3.16494125234984 ) ) @@ -74,22 +84,22 @@ test_that("rm_d | replication data", { rm_d(rt ~ cond | id, data = rouder2016, method = "d"), ) - d_av <- rm_d(rt ~ cond | id, - data = rouder2016, method = "av", - adjust = FALSE, verbose = FALSE - ) - d_z <- rm_d(rt ~ cond | id, - data = rouder2016, method = "z", - adjust = FALSE, verbose = FALSE - ) - d_d <- rm_d(rt ~ cond | id, - data = rouder2016, method = "d", - adjust = FALSE + d_av <- rm_d( + rt ~ cond | id, + data = rouder2016, + method = "av", + adjust = FALSE, + verbose = FALSE ) - d_r <- rm_d(rt ~ cond | id, - data = rouder2016, method = "r", - adjust = FALSE + d_z <- rm_d( + rt ~ cond | id, + data = rouder2016, + method = "z", + adjust = FALSE, + verbose = FALSE ) + d_d <- rm_d(rt ~ cond | id, data = rouder2016, method = "d", adjust = FALSE) + d_r <- rm_d(rt ~ cond | id, data = rouder2016, method = "r", adjust = FALSE) # values takes from # https://jakewestfall.org/blog/index.php/2016/03/25/five-different-cohens-d-statistics-for-within-subject-designs/ @@ -99,9 +109,18 @@ test_that("rm_d | replication data", { expect_equal(d_r[[1]], -0.052298 / 0.20195, tolerance = 0.001) # also: - expect_equal(d_d[[1]], cohens_d(rt ~ cond, data = rouder2016)[[1]], tolerance = 0.001) + expect_equal( + d_d[[1]], + cohens_d(rt ~ cond, data = rouder2016)[[1]], + tolerance = 0.001 + ) - rouder2016_wide <- tapply(rouder2016[["rt"]], rouder2016[1:2], mean, na.rm = TRUE) + rouder2016_wide <- tapply( + rouder2016[["rt"]], + rouder2016[1:2], + mean, + na.rm = TRUE + ) d_z2 <- cohens_d(rouder2016_wide[, 1] - rouder2016_wide[, 2]) expect_equal(d_z[[1]], d_z2[[1]]) expect_equal(d_z$CI_low, d_z2$CI_low, tolerance = 0.02) @@ -111,7 +130,6 @@ test_that("rm_d | replication data", { d_rm2 <- rm_d(rouder2016_wide[, 1], rouder2016_wide[, 2]) expect_equal(d_rm2, d_rm) - # # compare CIs to lmeInfo::g_mlm # mod1 <- nlme::lme(rt ~ cond, random = ~ cond | id, # data = rouder2016, @@ -125,7 +143,6 @@ test_that("rm_d | replication data", { expect_equal(d_r2$CI_low, -0.342050038016442, tolerance = 0.05) expect_equal(d_r2$CI_high, -0.17575096606632, tolerance = 0.05) - d_d2 <- rm_d(rt ~ cond | id, data = rouder2016, method = "d") expect_equal(d_d2$CI_low, -0.329333102235032, tolerance = 0.05) expect_equal(d_d2$CI_high, -0.168904897964021, tolerance = 0.05) diff --git a/tests/testthat/test-rom.R b/tests/testthat/test-rom.R index 1e3a52906..741bc2b1a 100644 --- a/tests/testthat/test-rom.R +++ b/tests/testthat/test-rom.R @@ -2,15 +2,26 @@ test_that("means_ratio", { # Direction --------------------------------------------------------------- rez_t <- t.test(iris$Sepal.Length, iris$Sepal.Width) rez_means_ratio <- means_ratio(iris$Sepal.Length, iris$Sepal.Width) - expect_equal(sign(rez_t$statistic), sign(log(rez_means_ratio[[1]])), + expect_equal( + sign(rez_t$statistic), + sign(log(rez_means_ratio[[1]])), ignore_attr = TRUE ) - # Alternative ------------------------------------------------------------- d1 <- means_ratio(iris$Sepal.Length, iris$Sepal.Width, ci = 0.80) - d2 <- means_ratio(iris$Sepal.Length, iris$Sepal.Width, ci = 0.90, alternative = "l") - d3 <- means_ratio(iris$Sepal.Length, iris$Sepal.Width, ci = 0.90, alternative = "g") + d2 <- means_ratio( + iris$Sepal.Length, + iris$Sepal.Width, + ci = 0.90, + alternative = "l" + ) + d3 <- means_ratio( + iris$Sepal.Length, + iris$Sepal.Width, + ci = 0.90, + alternative = "g" + ) expect_equal(d1$CI_high, d2$CI_high) expect_equal(d1$CI_low, d3$CI_low) @@ -73,16 +84,20 @@ test_that("means_ratio paired - adjusted", { expect_error(means_ratio(extra ~ group, data = sleep), "negative") sleep$y <- sleep$extra + 4 - sleep_wide <- datawizard::data_to_wide(sleep, + sleep_wide <- datawizard::data_to_wide( + sleep, id_cols = "ID", values_from = "y", names_from = "group", names_prefix = "extra_" ) - x <- means_ratio(sleep_wide[["extra_1"]], sleep_wide[["extra_2"]], + x <- means_ratio( + sleep_wide[["extra_1"]], + sleep_wide[["extra_2"]], data = sleep, - adjust = TRUE, paired = TRUE + adjust = TRUE, + paired = TRUE ) expect_equal(colnames(x)[1], "Means_ratio_adjusted") expect_equal(x[[1]], 0.752, tolerance = 0.001) @@ -93,15 +108,19 @@ test_that("means_ratio paired - adjusted", { test_that("means_ratio paired - not adjusted", { data(sleep) sleep$y <- sleep$extra + 4 - sleep_wide <- datawizard::data_to_wide(sleep, + sleep_wide <- datawizard::data_to_wide( + sleep, id_cols = "ID", values_from = "y", names_from = "group", names_prefix = "extra_" ) - x <- means_ratio(sleep_wide[["extra_1"]], sleep_wide[["extra_2"]], + x <- means_ratio( + sleep_wide[["extra_1"]], + sleep_wide[["extra_2"]], data = sleep, - adjust = FALSE, paired = TRUE + adjust = FALSE, + paired = TRUE ) expect_equal(colnames(x)[1], "Means_ratio") expect_equal(x[[1]], 0.75, tolerance = 0.001) diff --git a/tests/testthat/test-utils_validate_input_data.R b/tests/testthat/test-utils_validate_input_data.R index ffd7a35ac..0f8d9e371 100644 --- a/tests/testthat/test-utils_validate_input_data.R +++ b/tests/testthat/test-utils_validate_input_data.R @@ -14,7 +14,10 @@ test_that(".get_data_2_samples", { expect_error(d2 <- cohens_d("a", "c", data = df), regexp = NA) expect_error(d3 <- cohens_d(df$a ~ df$c), regexp = NA) expect_error(d4 <- cohens_d(df$a, df$c), regexp = NA) - expect_error(d5 <- cohens_d(df$a[df$c == "a"], df$a[df$c == "b"]), regexp = NA) + expect_error( + d5 <- cohens_d(df$a[df$c == "a"], df$a[df$c == "b"]), + regexp = NA + ) expect_identical(d1, d2) expect_identical(d1, d3) expect_identical(d1, d4) @@ -29,7 +32,6 @@ test_that(".get_data_2_samples", { cohens_d("exp_a", "c", data = df) ) - expect_error(cohens_d(a ~ b, data = df), "exactly") expect_error(cohens_d(a ~ d, data = df), "exactly") expect_error(cohens_d("a", "d", data = df), "exactly") @@ -62,48 +64,82 @@ test_that(".get_data_2_samples | na.action", { data("mtcars") mtcars$mpg[1] <- NA expect_warning(d1 <- cohens_d(mpg ~ am, data = mtcars), "dropped") - expect_warning(d2 <- cohens_d(mpg ~ am, data = mtcars, na.action = na.omit), NA) + expect_warning( + d2 <- cohens_d(mpg ~ am, data = mtcars, na.action = na.omit), + NA + ) }) test_that(".get_data_2_samples | subset", { expect_error(cohens_d(mpg ~ cyl, data = mtcars), "exactly") - expect_error(cohens_d(mpg ~ cyl, data = mtcars, subset = cyl %in% c(4, 6)), regexp = NA) + expect_error( + cohens_d(mpg ~ cyl, data = mtcars, subset = cyl %in% c(4, 6)), + regexp = NA + ) expect_error(rank_biserial(mpg ~ cyl, data = mtcars), "exactly") - expect_error(rank_biserial(mpg ~ cyl, data = mtcars, subset = cyl %in% c(4, 6)), regexp = NA) + expect_error( + rank_biserial(mpg ~ cyl, data = mtcars, subset = cyl %in% c(4, 6)), + regexp = NA + ) expect_error(sd_pooled(mpg ~ cyl, data = mtcars), "exactly") - expect_error(sd_pooled(mpg ~ cyl, data = mtcars, subset = cyl %in% c(4, 6)), regexp = NA) + expect_error( + sd_pooled(mpg ~ cyl, data = mtcars, subset = cyl %in% c(4, 6)), + regexp = NA + ) expect_error(cohens_u1(mpg ~ cyl, data = mtcars), "exactly") - expect_error(cohens_u1(mpg ~ cyl, data = mtcars, subset = cyl %in% c(4, 6)), regexp = NA) - - d1 <- cohens_d(mpg ~ cyl, - data = mtcars, - subset = cyl < 8 + expect_error( + cohens_u1(mpg ~ cyl, data = mtcars, subset = cyl %in% c(4, 6)), + regexp = NA ) + d1 <- cohens_d(mpg ~ cyl, data = mtcars, subset = cyl < 8) + x <- mtcars$cyl < 8 - d2 <- cohens_d(mpg ~ cyl, - data = mtcars, - subset = x - ) + d2 <- cohens_d(mpg ~ cyl, data = mtcars, subset = x) x <- mtcars$cyl - d3 <- cohens_d(mpg ~ cyl, - data = mtcars, - subset = x < 8 - ) + d3 <- cohens_d(mpg ~ cyl, data = mtcars, subset = x < 8) - d4 <- cohens_d(mpg ~ cyl, + d4 <- cohens_d( + mpg ~ cyl, data = mtcars, - subset = - c( - TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, TRUE, - TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, - TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, FALSE, TRUE, - FALSE, TRUE - ) + subset = c( + TRUE, + TRUE, + TRUE, + TRUE, + FALSE, + TRUE, + FALSE, + TRUE, + TRUE, + TRUE, + TRUE, + FALSE, + FALSE, + FALSE, + FALSE, + FALSE, + FALSE, + TRUE, + TRUE, + TRUE, + TRUE, + FALSE, + FALSE, + FALSE, + FALSE, + TRUE, + TRUE, + TRUE, + FALSE, + TRUE, + FALSE, + TRUE + ) ) expect_identical(d1, d2) @@ -115,7 +151,32 @@ test_that(".get_data_2_samples | reference", { # create data my_tib <- data.frame( group = gl(2, 12, labels = c("No treatment", "Treatment")), - outcome = c(3, 1, 5, 4, 6, 4, 6, 2, 0, 5, 4, 5, 4, 3, 6, 6, 8, 5, 5, 4, 2, 5, 7, 5) + outcome = c( + 3, + 1, + 5, + 4, + 6, + 4, + 6, + 2, + 0, + 5, + 4, + 5, + 4, + 3, + 6, + 6, + 8, + 5, + 5, + 4, + 2, + 5, + 7, + 5 + ) ) my_tib$group_chr <- as.character(my_tib$group) @@ -128,7 +189,9 @@ test_that(".get_data_2_samples | reference", { # fomula input w/ character expect_identical( cohens_d(outcome ~ group_chr, data = my_tib)[[1]], - -cohens_d(outcome ~ group_chr, data = my_tib, reference = "No treatment")[[1]] + -cohens_d(outcome ~ group_chr, data = my_tib, reference = "No treatment")[[ + 1 + ]] ) # vector input w/ factor @@ -146,68 +209,105 @@ test_that(".get_data_2_samples | reference", { # name input w/ factor expect_identical( cohens_d("outcome", "group", data = my_tib)[[1]], - -cohens_d("outcome", "group", data = my_tib, reference = "No treatment")[[1]] + -cohens_d("outcome", "group", data = my_tib, reference = "No treatment")[[ + 1 + ]] ) # name input w/ character expect_identical( cohens_d("outcome", "group_chr", data = my_tib)[[1]], - -cohens_d("outcome", "group_chr", data = my_tib, reference = "No treatment")[[1]] + -cohens_d( + "outcome", + "group_chr", + data = my_tib, + reference = "No treatment" + )[[1]] ) # sign is opposite, same value expect_identical( rank_biserial(outcome ~ group_chr, data = my_tib)[[1]], - -rank_biserial(outcome ~ group_chr, data = my_tib, reference = "No treatment")[[1]] + -rank_biserial( + outcome ~ group_chr, + data = my_tib, + reference = "No treatment" + )[[1]] ) # inverse expect_equal( means_ratio(outcome ~ group_chr, data = my_tib)[[1]], - 1 / means_ratio(outcome ~ group_chr, data = my_tib, reference = "No treatment")[[1]], + 1 / + means_ratio( + outcome ~ group_chr, + data = my_tib, + reference = "No treatment" + )[[1]], tolerance = 0.001 ) # sum to 1 expect_equal( cohens_u3(outcome ~ group_chr, data = my_tib)[[1]], - 1 - cohens_u3(outcome ~ group_chr, data = my_tib, reference = "No treatment")[[1]], + 1 - + cohens_u3( + outcome ~ group_chr, + data = my_tib, + reference = "No treatment" + )[[1]], tolerance = 0.001 ) # sum to 1 expect_equal( p_superiority(outcome ~ group_chr, data = my_tib)[[1]], - 1 - p_superiority(outcome ~ group_chr, data = my_tib, reference = "No treatment")[[1]], + 1 - + p_superiority( + outcome ~ group_chr, + data = my_tib, + reference = "No treatment" + )[[1]], tolerance = 0.001 ) # sign is opposite but so is value delta1 <- glass_delta(outcome ~ group_chr, data = my_tib)[[1]] - delta2 <- glass_delta(outcome ~ group_chr, data = my_tib, reference = "No treatment")[[1]] + delta2 <- glass_delta( + outcome ~ group_chr, + data = my_tib, + reference = "No treatment" + )[[1]] expect_identical(sign(delta1), -sign(delta2)) expect_true(abs(delta1) != abs(delta2)) - - - data("sleep") - sleep2 <- reshape(sleep, - direction = "wide", - idvar = "ID", timevar = "group" - ) + sleep2 <- reshape(sleep, direction = "wide", idvar = "ID", timevar = "group") # formula w/ Pair() expect_identical( hedges_g(Pair(extra.1, extra.2) ~ 1, data = sleep2, verbose = FALSE)[[1]], - -hedges_g(Pair(extra.1, extra.2) ~ 1, data = sleep2, verbose = FALSE, reference = "extra.1")[[1]] + -hedges_g( + Pair(extra.1, extra.2) ~ 1, + data = sleep2, + verbose = FALSE, + reference = "extra.1" + )[[1]] ) - # formula w/ arbitrary Pair() expect_identical( - cohens_d(Pair(extra[group == 1] + pi, extra[group == 2]) ~ 1, data = sleep, verbose = FALSE)[[1]], - -cohens_d(Pair(extra[group == 1] + pi, extra[group == 2]) ~ 1, data = sleep, verbose = FALSE, reference = "extra[group == 1] + pi")[[1]] + cohens_d( + Pair(extra[group == 1] + pi, extra[group == 2]) ~ 1, + data = sleep, + verbose = FALSE + )[[1]], + -cohens_d( + Pair(extra[group == 1] + pi, extra[group == 2]) ~ 1, + data = sleep, + verbose = FALSE, + reference = "extra[group == 1] + pi" + )[[1]] ) }) @@ -221,8 +321,14 @@ test_that(".get_data_multi_group", { ) df$exp_a <- exp(df$a) - expect_error(d1 <- rank_epsilon_squared(a ~ c, data = df, ci = NULL), regexp = NA) - expect_error(d2 <- rank_epsilon_squared("a", "c", data = df, ci = NULL), regexp = NA) + expect_error( + d1 <- rank_epsilon_squared(a ~ c, data = df, ci = NULL), + regexp = NA + ) + expect_error( + d2 <- rank_epsilon_squared("a", "c", data = df, ci = NULL), + regexp = NA + ) expect_error(d3 <- rank_epsilon_squared(df$a ~ df$c, ci = NULL), regexp = NA) expect_error(d4 <- rank_epsilon_squared(df$a, df$c, ci = NULL), regexp = NA) L <- split(df$a, df$c) @@ -243,7 +349,10 @@ test_that(".get_data_multi_group", { expect_error(rank_epsilon_squared("a", "aa", data = df), "missing") df[1, ] <- NA - expect_warning(E1 <- rank_epsilon_squared(a ~ c, data = df, ci = NULL), "dropped") + expect_warning( + E1 <- rank_epsilon_squared(a ~ c, data = df, ci = NULL), + "dropped" + ) expect_identical(E1, rank_epsilon_squared(df$a[-1], df$c[-1], ci = NULL)) }) @@ -268,9 +377,15 @@ test_that(".get_data_nested_groups", { M2 <- data.frame( id = c(1L, 1L, 1L, 2L, 2L, 2L, 3L, 3L, 3L), name = c( - "Round Out", "Narrow Angle", "Wide Angle", - "Round Out", "Narrow Angle", "Wide Angle", - "Round Out", "Narrow Angle", "Wide Angle" + "Round Out", + "Narrow Angle", + "Wide Angle", + "Round Out", + "Narrow Angle", + "Wide Angle", + "Round Out", + "Narrow Angle", + "Wide Angle" ), value = c(5.4, 5.5, 5.55, 5.85, 5.7, 5.75, 5.2, 5.6, 5.5), stringsAsFactors = FALSE @@ -323,38 +438,60 @@ test_that(".get_data_multivariate | na.action", { data("mtcars") mtcars$mpg[1] <- NA expect_warning(mahalanobis_d(mtcars[, c("mpg", "hp")]), regexp = "dropped") - expect_warning(mahalanobis_d(mpg + hp ~ 1, data = mtcars, na.action = na.omit), regexp = NA) - expect_warning(D1 <- mahalanobis_d(mpg + hp ~ 1, data = mtcars), regexp = "dropped") + expect_warning( + mahalanobis_d(mpg + hp ~ 1, data = mtcars, na.action = na.omit), + regexp = NA + ) + expect_warning( + D1 <- mahalanobis_d(mpg + hp ~ 1, data = mtcars), + regexp = "dropped" + ) expect_identical(D1, mahalanobis_d(mpg + hp ~ 1, data = mtcars[-1, ])) }) test_that(".get_data_paired | reference", { data("sleep") - sleep2 <- reshape(sleep, - direction = "wide", - idvar = "ID", timevar = "group" - ) + sleep2 <- reshape(sleep, direction = "wide", idvar = "ID", timevar = "group") # formual w/ Pair() expect_identical( repeated_measures_d(Pair(extra.1, extra.2) ~ 1, data = sleep2)[[1]], - -repeated_measures_d(Pair(extra.1, extra.2) ~ 1, data = sleep2, reference = "extra.1")[[1]] + -repeated_measures_d( + Pair(extra.1, extra.2) ~ 1, + data = sleep2, + reference = "extra.1" + )[[1]] ) - # 3 part formula (+aggragate) data("rouder2016") rouder2016$cond_num <- as.numeric(rouder2016$cond) # with factor expect_identical( - repeated_measures_d(rt ~ cond | id, data = rouder2016, verbose = FALSE)[[1]], - -repeated_measures_d(rt ~ cond | id, data = rouder2016, verbose = FALSE, reference = "2")[[1]] + repeated_measures_d(rt ~ cond | id, data = rouder2016, verbose = FALSE)[[ + 1 + ]], + -repeated_measures_d( + rt ~ cond | id, + data = rouder2016, + verbose = FALSE, + reference = "2" + )[[1]] ) expect_identical( - repeated_measures_d(rt ~ cond_num | id, data = rouder2016, verbose = FALSE)[[1]], - -repeated_measures_d(rt ~ cond_num | id, data = rouder2016, verbose = FALSE, reference = "2")[[1]] + repeated_measures_d( + rt ~ cond_num | id, + data = rouder2016, + verbose = FALSE + )[[1]], + -repeated_measures_d( + rt ~ cond_num | id, + data = rouder2016, + verbose = FALSE, + reference = "2" + )[[1]] ) }) diff --git a/tests/testthat/test-xtab.R b/tests/testthat/test-xtab.R index 3fbebe587..b9c87633f 100644 --- a/tests/testthat/test-xtab.R +++ b/tests/testthat/test-xtab.R @@ -12,7 +12,11 @@ test_that("contingency table", { expect_error(phi(contingency_table), "appropriate") - expect_equal(tschuprows_t(contingency_table, adjust = FALSE), res, ignore_attr = TRUE) + expect_equal( + tschuprows_t(contingency_table, adjust = FALSE), + res, + ignore_attr = TRUE + ) ## Size does not affect estimate xtab <- rbind( @@ -27,8 +31,16 @@ test_that("contingency table", { expect_equal(cv1$Cramers_v, cv2$Cramers_v, tolerance = 1e-4) # Upper bound of phi is the ratio between phi / V and sqrt(min(K,L)-1) - expect_equal(cohens_w(xtab, alternative = "greater")$CI_high, sqrt(2), tolerance = 1e-4) - expect_equal(cohens_w(xtab)[[1]] / cramers_v(xtab, adjust = FALSE)[[1]], sqrt(2), tolerance = 1e-4) + expect_equal( + cohens_w(xtab, alternative = "greater")$CI_high, + sqrt(2), + tolerance = 1e-4 + ) + expect_equal( + cohens_w(xtab)[[1]] / cramers_v(xtab, adjust = FALSE)[[1]], + sqrt(2), + tolerance = 1e-4 + ) # Tschuprows_t with non-square tables xtab <- rbind( @@ -36,10 +48,12 @@ test_that("contingency table", { c(0, 1, 0) ) expect_equal(cramers_v(xtab, adjust = FALSE)[[1]], 1, tolerance = 1e-4) - expect_lt(tschuprows_t(xtab, adjust = FALSE)[[1]], cramers_v(xtab, adjust = FALSE)[[1]]) + expect_lt( + tschuprows_t(xtab, adjust = FALSE)[[1]], + cramers_v(xtab, adjust = FALSE)[[1]] + ) expect_lt(tschuprows_t(xtab)[[1]], cramers_v(xtab)[[1]]) - ## 2*2 tables return phi and cramers_v xtab <- rbind( c(760, 330), @@ -55,7 +69,6 @@ test_that("contingency table", { res <- pearsons_c(xtab) expect_equal(res[[1]], 0.032, tolerance = 0.01) - ## 2*2 perfect correlation xtab <- rbind( c(100, 0), @@ -66,7 +79,6 @@ test_that("contingency table", { expect_equal(V, 1, tolerance = 1e-4) expect_lt(pearsons_c(xtab)[[1]], V) # C is not perfect - ## 2*2 0 correlation xtab <- rbind( c(50, 50), @@ -74,7 +86,6 @@ test_that("contingency table", { ) expect_equal(cramers_v(xtab, adjust = FALSE)$Cramers_v, 0, tolerance = 1e-5) - ## Empty rows/columns xtab <- rbind( c(50, 50, 0), @@ -110,14 +121,26 @@ test_that("goodness of fit", { expect_equal(w2$CI_high, sqrt(0.9 / 0.1), tolerance = 1e-4) C <- pearsons_c(table(mtcars$cyl), p = c(0.8, 0.1, 0.1)) - expect_equal(C[[1]], sqrt(49.289 / (49.289 + sum(table(mtcars$cyl)))), tolerance = 0.001) + expect_equal( + C[[1]], + sqrt(49.289 / (49.289 + sum(table(mtcars$cyl)))), + tolerance = 0.001 + ) expect_equal(C$CI_high, 1, tolerance = 1e-4) # some weird exeptions... df <- subset(mtcars, am == "0") expect_equal(cohens_w(table(df$am, df$cyl))[[1]], 0.64, tolerance = 0.01) - expect_equal(cohens_w(table(df$am, df$cyl)), cohens_w(table(df$cyl)), tolerance = 1e-4) - expect_equal(cohens_w(table(df$am, df$cyl)), cohens_w(table(df$cyl, df$am)), tolerance = 1e-4) + expect_equal( + cohens_w(table(df$am, df$cyl)), + cohens_w(table(df$cyl)), + tolerance = 1e-4 + ) + expect_equal( + cohens_w(table(df$am, df$cyl)), + cohens_w(table(df$cyl, df$am)), + tolerance = 1e-4 + ) # p is a table O <- as.table(c(10, 20, 30, 40)) @@ -183,7 +206,6 @@ test_that("oddsratio & riskratio", { expect_warning(riskratio(RCT, log = TRUE), "log") - ## OR data("mtcars") expect_error(oddsratio(mtcars$am, mtcars$cyl), "only")