effects="all" drops columns (#976)

* `effects="all"` drops columns Fixes #975 * version * lintr * lintr
easystats · Jun 4, 2024 · f012e18 · f012e18
1 parent 6090602
commit f012e18
Show file tree

Hide file tree

Showing 5 changed files with 95 additions and 35 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -4,19 +4,23 @@ 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"
     )
   )
   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)
 })