From f012e180eb5f23bc35569768e46b19a9ea59563f Mon Sep 17 00:00:00 2001 From: Daniel Date: Tue, 4 Jun 2024 14:09:03 +0200 Subject: [PATCH] `effects="all"` drops columns (#976) * `effects="all"` drops columns Fixes #975 * version * lintr * lintr --- DESCRIPTION | 2 +- NEWS.md | 9 ++++ R/extract_parameters_anova.R | 17 ++++--- R/methods_htest.R | 50 ++++++++++++++----- tests/testthat/test-model_parameters.htest.R | 52 ++++++++++++++------ 5 files changed, 95 insertions(+), 35 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f0c0bd102..b85849cdc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: parameters Title: Processing of Model Parameters -Version: 0.21.7.2 +Version: 0.21.7.3 Authors@R: c(person(given = "Daniel", family = "Lüdecke", diff --git a/NEWS.md b/NEWS.md index cbda7012f..180c60436 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,15 @@ * Deprecated arguments in `model_parameters()` for `htest`, `aov` and `BFBayesFactor` objects were removed. +## New supported models + +* Support for objects from `stats::Box.test()`. + +## Bug fixes + +* Fixed issues with partial matching of argument `effects` and `effectsize_type` + in `model_parameters()` for objects of class `htest`. + # parameters 0.21.7 ## Changes diff --git a/R/extract_parameters_anova.R b/R/extract_parameters_anova.R index ab3e2df9b..00d8eb485 100644 --- a/R/extract_parameters_anova.R +++ b/R/extract_parameters_anova.R @@ -68,8 +68,13 @@ # Reorder row.names(parameters) <- NULL - order <- c("Response", "Group", "Parameter", "Coefficient", "SE", "Pillai", "AIC", "BIC", "Log_Likelihood", "Chi2", "Chi2_df", "RSS", "Sum_Squares", "Sum_Squares_Partial", "Sum_Squares_Error", "df", "Deviance", "Statistic", "df_num", "df_error", "Deviance_error", "Mean_Square", "F", "Rao", "p") - parameters <- parameters[order[order %in% names(parameters)]] + col_order <- c( + "Response", "Group", "Parameter", "Coefficient", "SE", "Pillai", "AIC", + "BIC", "Log_Likelihood", "Chi2", "Chi2_df", "RSS", "Sum_Squares", + "Sum_Squares_Partial", "Sum_Squares_Error", "df", "Deviance", "Statistic", + "df_num", "df_error", "Deviance_error", "Mean_Square", "F", "Rao", "p" + ) + parameters <- parameters[col_order[col_order %in% names(parameters)]] insight::text_remove_backticks(parameters, verbose = FALSE) } @@ -235,7 +240,7 @@ Parameter = model$terms[i], df = model$df[i], Statistic = test[1], - `F` = test[2], + `F` = test[2], # nolint df_num = test[3], df_error = test[4], p = stats::pf(test[2], test[3], test[4], lower.tail = FALSE), @@ -311,7 +316,7 @@ .power_for_aov <- function(model, params) { if (requireNamespace("effectsize", quietly = TRUE)) { - power <- tryCatch( + power_aov <- tryCatch( { cohens_f2 <- effectsize::cohens_f_squared(model, partial = TRUE, verbose = FALSE) @@ -329,8 +334,8 @@ ) } - if (!is.null(power)) { - params <- merge(params, cohens_f2[c("Parameter", "Power")], sort = FALSE, all = TRUE) + if (!is.null(power_aov)) { + params <- merge(params, power_aov[c("Parameter", "Power")], sort = FALSE, all = TRUE) } params diff --git a/R/methods_htest.R b/R/methods_htest.R index c2c7f4e1b..4586a6cf7 100644 --- a/R/methods_htest.R +++ b/R/methods_htest.R @@ -128,7 +128,10 @@ model_parameters.svytable <- function(model, verbose = TRUE, ...) { ...) { m_info <- insight::model_info(model, verbose = FALSE) - if (m_info$is_correlation) { + if (!is.null(model$method) && startsWith(model$method, "Box-")) { + # Box-Pierce --------- + out <- .extract_htest_boxpierce(model) + } else if (m_info$is_correlation) { # correlation --------- out <- .extract_htest_correlation(model) } else if (.is_levenetest(model)) { @@ -175,6 +178,22 @@ model_parameters.svytable <- function(model, verbose = TRUE, ...) { +# extract htest Box-Pierce ---------------------- + +#' @keywords internal +.extract_htest_boxpierce <- function(model) { + data.frame( + Parameter = model$data.name, + Chi2 = model$statistic, + df_error = model$parameter, + p = model$p.value, + Method = model$method, + stringsAsFactors = FALSE + ) +} + + + # extract htest correlation ---------------------- #' @keywords internal @@ -500,7 +519,7 @@ model_parameters.svytable <- function(model, verbose = TRUE, ...) { #' @keywords internal .extract_htest_prop <- function(model) { out <- data.frame( - Proportion = paste0(insight::format_value(model$estimate, as_percent = TRUE), collapse = " / "), + Proportion = paste(insight::format_value(model$estimate, as_percent = TRUE), collapse = " / "), stringsAsFactors = FALSE ) if (length(model$estimate) == 2) { @@ -559,6 +578,13 @@ model_parameters.svytable <- function(model, verbose = TRUE, ...) { return(out) } + # return on invalid options. We may have partial matching with argument + # `effects` for `effectsize_type`, and thus all "effects" options should be + # ignored. + if (effectsize_type %in% c("fixed", "random", "all")) { + return(out) + } + # try to extract effectsize es <- tryCatch( { @@ -637,17 +663,15 @@ model_parameters.svytable <- function(model, verbose = TRUE, ...) { if (!is.null(model$alternative)) { h1_text <- "Alternative hypothesis: " - if (!is.null(model$null.value)) { - if (length(model$null.value) == 1L) { - alt.char <- switch(model$alternative, - two.sided = "not equal to", - less = "less than", - greater = "greater than" - ) - h1_text <- paste0(h1_text, "true ", names(model$null.value), " is ", alt.char, " ", model$null.value) - } else { - h1_text <- paste0(h1_text, model$alternative) - } + if (is.null(model$null.value)) { + h1_text <- paste0(h1_text, model$alternative) + } else if (length(model$null.value) == 1L) { + alt.char <- switch(model$alternative, + two.sided = "not equal to", + less = "less than", + greater = "greater than" + ) + h1_text <- paste0(h1_text, "true ", names(model$null.value), " is ", alt.char, " ", model$null.value) } else { h1_text <- paste0(h1_text, model$alternative) } diff --git a/tests/testthat/test-model_parameters.htest.R b/tests/testthat/test-model_parameters.htest.R index 3e63d9c28..15a76c6f4 100644 --- a/tests/testthat/test-model_parameters.htest.R +++ b/tests/testthat/test-model_parameters.htest.R @@ -4,8 +4,8 @@ skip_if_not_installed("effectsize") test_that("model_parameters.htest", { params <- model_parameters(cor.test(mtcars$mpg, mtcars$cyl, method = "pearson")) - expect_equal( - colnames(params), + expect_named( + params, c( "Parameter1", "Parameter2", "r", "CI", "CI_low", "CI_high", "t", "df_error", "p", "Method", "Alternative" @@ -13,10 +13,14 @@ test_that("model_parameters.htest", { ) expect_equal(params$r, -0.852, tolerance = 0.05) - expect_warning(params <- model_parameters(cor.test(mtcars$mpg, mtcars$cyl, method = "spearman"))) + expect_warning({ + params <- model_parameters(cor.test(mtcars$mpg, mtcars$cyl, method = "spearman")) + }) expect_equal(params$rho, -0.9108, tolerance = 0.05) - expect_warning(params <- model_parameters(cor.test(mtcars$mpg, mtcars$cyl, method = "kendall"))) + expect_warning({ + params <- model_parameters(cor.test(mtcars$mpg, mtcars$cyl, method = "kendall")) + }) expect_equal(params$tau, -0.795, tolerance = 0.05) params <- model_parameters(t.test(iris$Sepal.Width, iris$Sepal.Length)) @@ -32,21 +36,21 @@ test_that("model_parameters.htest", { test_that("model_parameters.htest-2", { x <- c(A = 20, B = 15, C = 25) mp <- model_parameters(chisq.test(x)) - expect_equal(colnames(mp), c("Chi2", "df", "p", "Method")) + expect_named(mp, c("Chi2", "df", "p", "Method")) }) test_that("model_parameters-chisq-test NULL", { mp <- model_parameters(stats::chisq.test(table(mtcars$am))) expect_equal(mp$Chi2, 1.125, tolerance = 1e-3) - expect_equal(colnames(mp), c("Chi2", "df", "p", "Method")) + expect_named(mp, c("Chi2", "df", "p", "Method")) }) test_that("model_parameters-chisq-test two way table", { mp2 <- suppressWarnings(model_parameters(stats::chisq.test(table(mtcars$am, mtcars$cyl)))) expect_equal(mp2$Chi2, 8.740733, tolerance = 1e-3) - expect_equal(colnames(mp2), c("Chi2", "df", "p", "Method")) + expect_named(mp2, c("Chi2", "df", "p", "Method")) }) test_that("model_parameters-chisq-test works with `svychisq` objects", { @@ -59,21 +63,23 @@ test_that("model_parameters-chisq-test works with `svychisq` objects", { mp <- model_parameters(m) expect_equal(mp$F, 5.19337, tolerance = 1e-3) - expect_equal(names(mp), c("F", "df", "df_error", "p", "Method")) + expect_named(mp, c("F", "df", "df_error", "p", "Method")) }) test_that("model_parameters-chisq-test adjusted", { - expect_message(mp <- model_parameters(stats::chisq.test(table(mtcars$am)), effectsize_type = "phi", ci = 0.95)) + expect_message({ + mp <- model_parameters(stats::chisq.test(table(mtcars$am)), effectsize_type = "phi", ci = 0.95) + }) expect_equal(mp$Chi2, 1.125, tolerance = 1e-3) - expect_equal(colnames(mp), c("Chi2", "df", "p", "Method")) + expect_named(mp, c("Chi2", "df", "p", "Method")) }) test_that("model_parameters-t-test standardized d", { params <- model_parameters(t.test(iris$Sepal.Width, iris$Sepal.Length), effectsize_type = "cohens_d") expect_equal(params$Cohens_d, -4.210417, tolerance = 0.05) expect_equal(params$d_CI_low, -4.655306, tolerance = 0.05) - expect_equal( - colnames(params), + expect_named( + params, c( "Parameter1", "Parameter2", "Mean_Parameter1", "Mean_Parameter2", "Difference", "CI", "CI_low", "CI_high", "Cohens_d", "d_CI_low", @@ -85,8 +91,8 @@ test_that("model_parameters-t-test standardized d", { test_that("model_parameters-t-test standardized d", { mp <- model_parameters(t.test(mtcars$mpg ~ mtcars$vs), effectsize_type = "cohens_d", verbose = FALSE) expect_equal(mp$Cohens_d, -1.696032, tolerance = 1e-3) - expect_equal( - colnames(mp), + expect_named( + mp, c( "Parameter", "Group", "Mean_Group1", "Mean_Group2", "Difference", "CI", "CI_low", "CI_high", "Cohens_d", "d_CI_low", "d_CI_high", "t", "df_error", @@ -102,5 +108,21 @@ test_that("model_parameters-t-test reports the same unregarding of interface", { compare_only <- c("Difference", "CI", "CI_low", "CI_high", "t", "df_error", "p", "Method") default_ttest <- model_parameters(t.test(x = g1, y = g2))[compare_only] formula_ttest <- model_parameters(t.test(y ~ x, df))[compare_only] - expect_equal(default_ttest, formula_ttest) + expect_equal(default_ttest, formula_ttest, ignore_attr = TRUE) +}) + +test_that("model_parameters-Box.test works, and ignores partial matching", { + set.seed(123) + ts1 <- ts(rnorm(200, mean = 10, sd = 3)) + result1 <- Box.test(ts1, lag = 5, type = "Box-Pierce", fitdf = 2) + result2 <- Box.test(ts1, lag = 5, type = "Ljung-Box", fitdf = 2) + + out1 <- model_parameters(result1) + out2 <- model_parameters(result1, effects = "all") + expect_equal(out1, out2, ignore_attr = TRUE) + expect_named(out1, c("Parameter", "Chi2", "df_error", "p", "Method")) + + out1 <- model_parameters(result2) + out2 <- model_parameters(result2, effects = "all") + expect_equal(out1, out2, ignore_attr = TRUE) })