Support ggeffects (#820)

* Support ggeffects

* more methods

* fix

* fix

* version

* update suggests

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 0.19.6
+Version: 0.19.6.1
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -123,6 +123,7 @@ Suggests:
     gee,
     geepack,
     geoR,
+    ggeffects,
     GLMMadaptive,
     glmmTMB,
     gmnl,
@@ -206,3 +207,4 @@ Config/Needs/website:
     rstudio/bslib,
     r-lib/pkgdown,
     easystats/easystatstemplate
+Remotes: strengejacke/ggeffects

NAMESPACE

@@ -608,6 +608,7 @@ S3method(get_parameters,gam)
 S3method(get_parameters,gamlss)
 S3method(get_parameters,gamm)
 S3method(get_parameters,gbm)
+S3method(get_parameters,ggcomparisons)
 S3method(get_parameters,glht)
 S3method(get_parameters,glimML)
 S3method(get_parameters,glmm)
@@ -816,6 +817,7 @@ S3method(get_statistic,gamm)
 S3method(get_statistic,garch)
 S3method(get_statistic,gee)
 S3method(get_statistic,geeglm)
+S3method(get_statistic,ggcomparisons)
 S3method(get_statistic,glht)
 S3method(get_statistic,glimML)
 S3method(get_statistic,glmm)
@@ -1314,6 +1316,7 @@ S3method(model_info,gamlss)
 S3method(model_info,gamm)
 S3method(model_info,garch)
 S3method(model_info,gbm)
+S3method(model_info,ggcomparisons)
 S3method(model_info,glht)
 S3method(model_info,glimML)
 S3method(model_info,glmm)

NEWS.md

@@ -1,3 +1,9 @@
+# insight 0.19.7
+
+## General
+
+* Support for objects of class `ggcomparisons` from `ggeffects::hypothesis_test()`.
+
 # insight 0.19.6
 
 ## General

R/find_statistic.R

@@ -120,8 +120,8 @@ find_statistic <- function(x, ...) {
     "deltaMethod", "DirichletRegModel",
     "ergm",
     "feglm", "flexsurvreg",
-    "gee", "glimML", "glmm", "glmmadmb", "glmmFit", "glmmLasso", "glmmTMB",
-    "glmx", "gmnl",
+    "gee", "ggcomparisons", "glimML", "glmm", "glmmadmb", "glmmFit", "glmmLasso",
+    "glmmTMB", "glmx", "gmnl",
     "hurdle",
     "lavaan", "loggammacenslmrob", "logitmfx", "logitor", "logitr", "LORgee", "lrm",
     "margins", "marginaleffects", "marginaleffects.summary", "metaplus", "mixor",

R/get_parameters_others.R

@@ -364,3 +364,31 @@ get_parameters.deltaMethod <- function(x, ...) {
     row.names = NULL
   )
 }
+
+
+#' @export
+get_parameters.ggcomparisons <- function(x, merge_parameters = FALSE, ...) {
+  estimate_pos <- which(colnames(x) == attr(x, "estimate_name"))
+  params <- x[, seq_len(estimate_pos - 1), drop = FALSE]
+
+  if (isTRUE(merge_parameters) && ncol(params) > 1L) {
+    r <- apply(params, 1, function(i) paste0(colnames(params), " [", i, "]"))
+    out <- data.frame(
+      Parameter = unname(vapply(as.data.frame(r), toString, character(1))),
+      Estimate = x[[estimate_pos]],
+      stringsAsFactors = FALSE,
+      row.names = NULL
+    )
+  } else {
+    out <- data.frame(
+      params,
+      Estimate = x[[estimate_pos]],
+      stringsAsFactors = FALSE,
+      row.names = NULL
+    )
+    if (isTRUE(merge_parameters)) {
+      colnames(out)[1] <- "Parameter"
+    }
+  }
+  text_remove_backticks(out)
+}

R/get_statistic.R

@@ -1598,6 +1598,33 @@ get_statistic.emm_list <- function(x, ci = 0.95, adjust = "none", ...) {
 }
 
 
+#' @export
+get_statistic.ggcomparisons <- function(x, merge_parameters = FALSE, ...) {
+  estimate_pos <- which(colnames(x) == attr(x, "estimate_name"))
+  if (isTRUE(merge_parameters)) {
+    params <- get_parameters(x, merge_parameters = TRUE)["Parameter"]
+  } else {
+    params <- x[, seq_len(estimate_pos - 1), drop = FALSE]
+  }
+
+  stat <- .safe(x[[estimate_pos]] / attributes(x)$standard_error)
+  if (is.null(stat)) {
+    return(NULL)
+  }
+
+  out <- data.frame(
+    params,
+    Statistic = as.vector(stat),
+    stringsAsFactors = FALSE,
+    row.names = NULL
+  )
+
+  out <- text_remove_backticks(out)
+  attr(out, "statistic") <- find_statistic(x)
+  out
+}
+
+
 #' @export
 get_statistic.robmixglm <- function(x, ...) {
   cs <- stats::coef(summary(x))

R/is_model.R

@@ -89,7 +89,7 @@ is_regression_model <- function(x) {
     "glmaag", "glmbb", "glmboostLSS", "glmc", "glmdm", "glmdisc",
     "glmerMod", "glmlep", "glmm", "glmmadmb", "glmmEP", "glmmFit",
     "glmmfields", "glmmLasso", "glmmPQL", "glmmTMB", "glmnet", "glmrob",
-    "glmRob", "glmx", "gls", "gmnl", "gmm", "gnls", "gsm",
+    "glmRob", "glmx", "gls", "gmnl", "gmm", "gnls", "gsm", "ggcomparisons",
 
     # h --------------------
     "heavyLme", "HLfit", "htest", "hurdle", "hglm",

R/model_info.R

@@ -1366,3 +1366,8 @@ model_info.earth <- function(x, ...) {
 model_info.deltaMethod <- function(x, ...) {
   NULL
 }
+
+#' @export
+model_info.ggcomparisons <- function(x, ...) {
+  NULL
+}

tests/testthat/test-ggeffects.R

@@ -0,0 +1,118 @@
+skip_if_not_installed("ggeffects")
+
+test_that("get_parameters, hypothesis_test", {
+  data(iris)
+  mgg <- lm(Sepal.Width ~ Sepal.Length * Species, data = iris)
+
+  out <- ggeffects::hypothesis_test(
+    ggeffects::ggpredict(mgg, c("Sepal.Length", "Species")),
+    test = NULL
+  )
+
+  param <- get_parameters(out)
+  expect_named(param, c("Sepal.Length", "Species", "Estimate"))
+  expect_identical(
+    param$Sepal.Length,
+    c("slope", "slope", "slope")
+  )
+  expect_identical(
+    param$Species,
+    structure(1:3, levels = c("setosa", "versicolor", "virginica"), class = "factor")
+  )
+  expect_equal(
+    param$Estimate,
+    c(0.79853, 0.31972, 0.23189),
+    tolerance = 1e-3
+  )
+
+  param <- get_parameters(out, merge_parameters = TRUE)
+  expect_named(param, c("Parameter", "Estimate"))
+  expect_identical(
+    param$Parameter,
+    c(
+      "Sepal.Length [slope], Species [setosa]", "Sepal.Length [slope], Species [versicolor]",
+      "Sepal.Length [slope], Species [virginica]"
+    )
+  )
+  expect_equal(
+    param$Estimate,
+    c(0.79853, 0.31972, 0.23189),
+    tolerance = 1e-3
+  )
+
+  out <- ggeffects::hypothesis_test(ggeffects::ggpredict(mgg, c("Sepal.Length", "Species")))
+
+  param <- get_parameters(out)
+  expect_named(param, c("Sepal.Length", "Species", "Estimate"))
+  expect_identical(
+    param$Sepal.Length,
+    c("slope", "slope", "slope")
+  )
+  expect_equal(
+    param$Estimate,
+    c(0.47881, 0.56664, 0.08783),
+    tolerance = 1e-3
+  )
+
+  param <- get_parameters(out, merge_parameters = TRUE)
+  expect_named(param, c("Parameter", "Estimate"))
+})
+
+
+test_that("get_statistic, hypothesis_test", {
+  data(iris)
+  mgg <- lm(Sepal.Width ~ Sepal.Length * Species, data = iris)
+
+  out <- ggeffects::hypothesis_test(
+    ggeffects::ggpredict(mgg, c("Sepal.Length", "Species")),
+    test = NULL
+  )
+
+  param <- get_statistic(out)
+  expect_named(param, c("Sepal.Length", "Species", "Statistic"))
+  expect_identical(
+    param$Sepal.Length,
+    c("slope", "slope", "slope")
+  )
+  expect_identical(
+    param$Species,
+    structure(1:3, levels = c("setosa", "versicolor", "virginica"), class = "factor")
+  )
+  expect_equal(
+    param$Statistic,
+    c(7.23551, 4.24211, 3.79015),
+    tolerance = 1e-3
+  )
+
+  param <- get_statistic(out, merge_parameters = TRUE)
+  expect_named(param, c("Parameter", "Statistic"))
+  expect_identical(
+    param$Parameter,
+    c(
+      "Sepal.Length [slope], Species [setosa]", "Sepal.Length [slope], Species [versicolor]",
+      "Sepal.Length [slope], Species [virginica]"
+    )
+  )
+  expect_equal(
+    param$Statistic,
+    c(7.23551, 4.24211, 3.79015),
+    tolerance = 1e-3
+  )
+
+  out <- ggeffects::hypothesis_test(ggeffects::ggpredict(mgg, c("Sepal.Length", "Species")))
+
+  param <- get_statistic(out)
+  expect_named(param, c("Sepal.Length", "Species", "Statistic"))
+  expect_identical(
+    param$Sepal.Length,
+    c("slope", "slope", "slope")
+  )
+  expect_equal(
+    param$Statistic,
+    c(3.58262, 4.48915, 0.90475),
+    tolerance = 1e-3
+  )
+
+  param <- get_statistic(out, merge_parameters = TRUE)
+  expect_named(param, c("Parameter", "Statistic"))
+})