[Proposal] Adding support for pooled (multiple imputed) glmtoolbox::g…

…lmgee Fixes #894
easystats · Jun 17, 2024 · ba4e61a · ba4e61a
1 parent 94e620e
commit ba4e61a
Show file tree

Hide file tree

Showing 21 changed files with 267 additions and 26 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 0.20.1.4
+Version: 0.20.1.5
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -126,6 +126,7 @@ Suggests:
     ggeffects,
     GLMMadaptive,
     glmmTMB,
+    glmtoolbox,
     gmnl,
     grDevices,
     gt,

diff --git a/NAMESPACE b/NAMESPACE
@@ -121,6 +121,7 @@ S3method(find_formula,gamm)
 S3method(find_formula,gee)
 S3method(find_formula,glht)
 S3method(find_formula,glimML)
+S3method(find_formula,glmgee)
 S3method(find_formula,glmm)
 S3method(find_formula,glmmPQL)
 S3method(find_formula,glmmTMB)
@@ -233,6 +234,7 @@ S3method(find_parameters,gamm)
 S3method(find_parameters,gbm)
 S3method(find_parameters,glht)
 S3method(find_parameters,glimML)
+S3method(find_parameters,glmgee)
 S3method(find_parameters,glmm)
 S3method(find_parameters,glmmTMB)
 S3method(find_parameters,glmmadmb)
@@ -406,6 +408,7 @@ S3method(get_data,gee)
 S3method(get_data,geeglm)
 S3method(get_data,glht)
 S3method(get_data,glimML)
+S3method(get_data,glmgee)
 S3method(get_data,glmm)
 S3method(get_data,glmmTMB)
 S3method(get_data,glmmadmb)
@@ -621,6 +624,7 @@ S3method(get_parameters,gbm)
 S3method(get_parameters,ggcomparisons)
 S3method(get_parameters,glht)
 S3method(get_parameters,glimML)
+S3method(get_parameters,glmgee)
 S3method(get_parameters,glmm)
 S3method(get_parameters,glmmTMB)
 S3method(get_parameters,glmmadmb)
@@ -830,6 +834,7 @@ S3method(get_statistic,geeglm)
 S3method(get_statistic,ggcomparisons)
 S3method(get_statistic,glht)
 S3method(get_statistic,glimML)
+S3method(get_statistic,glmgee)
 S3method(get_statistic,glmm)
 S3method(get_statistic,glmmTMB)
 S3method(get_statistic,glmmadmb)
@@ -1076,6 +1081,7 @@ S3method(link_function,gamm)
 S3method(link_function,gbm)
 S3method(link_function,glimML)
 S3method(link_function,glm)
+S3method(link_function,glmgee)
 S3method(link_function,glmm)
 S3method(link_function,glmmadmb)
 S3method(link_function,glmx)
@@ -1198,6 +1204,7 @@ S3method(link_inverse,gamm)
 S3method(link_inverse,gbm)
 S3method(link_inverse,glimML)
 S3method(link_inverse,glm)
+S3method(link_inverse,glmgee)
 S3method(link_inverse,glmm)
 S3method(link_inverse,glmmPQL)
 S3method(link_inverse,glmmTMB)
@@ -1335,6 +1342,7 @@ S3method(model_info,gbm)
 S3method(model_info,ggcomparisons)
 S3method(model_info,glht)
 S3method(model_info,glimML)
+S3method(model_info,glmgee)
 S3method(model_info,glmm)
 S3method(model_info,glmmPQL)
 S3method(model_info,glmmTMB)
@@ -1475,6 +1483,7 @@ S3method(n_obs,gbm)
 S3method(n_obs,glimML)
 S3method(n_obs,glm)
 S3method(n_obs,glmRob)
+S3method(n_obs,glmgee)
 S3method(n_obs,gmnl)
 S3method(n_obs,hurdle)
 S3method(n_obs,ivFixed)

diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,9 @@
 # insight 0.20.2
 
+## New supported models
+
+* Support for models of class `glmgee` (package *glmtoolbox*).
+
 ## General
 
 * Massive overhaul of `get_variance()`. The function should be now more

diff --git a/R/find_formula.R b/R/find_formula.R
@@ -574,6 +574,9 @@ find_formula.gee <- function(x, verbose = TRUE, ...) {
   .find_formula_return(f, verbose = verbose)
 }
 
+#' @export
+find_formula.glmgee <- find_formula.gee
+
 
 #' @export
 find_formula.MANOVA <- function(x, verbose = TRUE, ...) {

diff --git a/R/find_parameters_other.R b/R/find_parameters_other.R
@@ -36,6 +36,34 @@ find_parameters.averaging <- function(x,
 }
 
 
+#' @rdname find_parameters.averaging
+#' @export
+find_parameters.glmgee <- function(x,
+                                   component = c("all", "conditional", "dispersion"),
+                                   flatten = FALSE,
+                                   ...) {
+  component <- match.arg(component)
+
+  junk <- utils::capture.output({
+    cs <- suppressWarnings(stats::coef(summary(x, corr = FALSE)))
+  })
+  params <- compact_character(rownames(cs))
+
+  out <- list(
+    conditional = text_remove_backticks(params[params != "Dispersion"]),
+    dispersion = text_remove_backticks(params[params == "Dispersion"])
+  )
+
+  .filter_parameters(
+    out,
+    effects = "all",
+    component = component,
+    flatten = flatten,
+    recursive = FALSE
+  )
+}
+
+
 #' @rdname find_parameters.averaging
 #' @export
 find_parameters.betareg <- function(x,

diff --git a/R/find_statistic.R b/R/find_statistic.R
@@ -121,7 +121,7 @@ find_statistic <- function(x, ...) {
     "ergm",
     "feglm", "flexsurvreg",
     "gee", "ggcomparisons", "glimML", "glmm", "glmmadmb", "glmmFit", "glmmLasso",
-    "glmmTMB", "glmx", "gmnl",
+    "glmmTMB", "glmx", "gmnl", "glmgee",
     "hurdle",
     "lavaan", "loggammacenslmrob", "logitmfx", "logitor", "logitr", "LORgee", "lrm",
     "margins", "marginaleffects", "marginaleffects.summary", "metaplus", "mixor",

diff --git a/R/get_data.R b/R/get_data.R
@@ -425,6 +425,9 @@ get_data.geeglm <- function(x,
   .prepare_get_data(x, mf, effects = effects, verbose = verbose)
 }
 
+#' @export
+get_data.glmgee <- get_data.geeglm
+
 
 #' @export
 get_data.gee <- function(x,

diff --git a/R/get_df.R b/R/get_df.R
@@ -120,7 +120,7 @@ get_df.default <- function(x, type = "residual", verbose = TRUE, ...) {
   }
 
 
-  if (type == "normal") {
+  if (type == "normal") { # nolint
     # Wald normal approximation - always Inf -----
     return(Inf)
   } else if (type == "residual") {

diff --git a/R/get_parameters_gam.R b/R/get_parameters_gam.R
@@ -170,35 +170,35 @@ get_parameters.SemiParBIV <- function(x, ...) {
 
 
 .return_smooth_parms <- function(conditional, smooth_terms, component) {
-  if (!is_empty_object(conditional)) {
+  if (is_empty_object(conditional)) {
+    cond <- NULL
+  } else {
     cond <- data.frame(
       Parameter = names(conditional),
       Estimate = conditional,
       Component = "conditional",
       stringsAsFactors = FALSE,
       row.names = NULL
     )
-  } else {
-    cond <- NULL
   }
 
-  if (!is_empty_object(smooth_terms)) {
-    smooth <- data.frame(
+  if (is_empty_object(smooth_terms)) {
+    smooth_pars <- NULL
+  } else {
+    smooth_pars <- data.frame(
       Parameter = names(smooth_terms),
       Estimate = smooth_terms,
       Component = "smooth_terms",
       stringsAsFactors = FALSE,
       row.names = NULL
     )
-  } else {
-    smooth <- NULL
   }
 
   pars <- switch(component,
     all = ,
-    location = rbind(cond, smooth),
+    location = rbind(cond, smooth_pars),
     conditional = cond,
-    smooth_terms = smooth
+    smooth_terms = smooth_pars
   )
 
   if (!component %in% c("all", "location")) {

diff --git a/R/get_parameters_others.R b/R/get_parameters_others.R
@@ -38,6 +38,35 @@ get_parameters.betareg <- function(x,
 }
 
 
+#' @rdname get_parameters.betareg
+#' @export
+get_parameters.glmgee <- function(x, component = c("all", "conditional", "dispersion"), ...) {
+  component <- match.arg(component)
+
+  junk <- utils::capture.output({
+    cs <- suppressWarnings(stats::coef(summary(x, corr = FALSE)))
+  })
+  est <- stats::na.omit(cs[, "Estimate"])
+
+  out <- data.frame(
+    Parameter = names(est),
+    Estimate = as.vector(est),
+    Component = "conditional",
+    stringsAsFactors = FALSE,
+    row.names = NULL
+  )
+
+  # mark dispersion parameter
+  out$Component[out$Parameter == "Dispersion"] <- "dispersion"
+
+  if (component != "all") {
+    out <- out[out$Component == component, , drop = FALSE]
+  }
+
+  text_remove_backticks(out)
+}
+
+
 #' @export
 get_parameters.nestedLogit <- function(x, component = "all", verbose = TRUE, ...) {
   cf <- as.data.frame(stats::coef(x))
@@ -204,22 +233,22 @@ get_parameters.mvord <- function(x,
   thresholds$Parameter <- rownames(thresholds)
   thresholds$Response <- gsub("(.*)\\s(.*)", "\\1", thresholds$Parameter)
   # coefficients
-  coefficients <- as.data.frame(s$coefficients)
-  coefficients$Parameter <- rownames(coefficients)
-  coefficients$Response <- gsub("(.*)\\s(.*)", "\\2", coefficients$Parameter)
+  model_coef <- as.data.frame(s$coefficients)
+  model_coef$Parameter <- rownames(model_coef)
+  model_coef$Response <- gsub("(.*)\\s(.*)", "\\2", model_coef$Parameter)
 
-  if (!all(coefficients$Response %in% thresholds$Response)) {
+  if (!all(model_coef$Response %in% thresholds$Response)) {
     resp <- unique(thresholds$Response)
-    for (i in coefficients$Response) {
-      coefficients$Response[coefficients$Response == i] <- resp[grepl(paste0(i, "$"), resp)]
+    for (i in model_coef$Response) {
+      model_coef$Response[model_coef$Response == i] <- resp[grepl(paste0(i, "$"), resp)]
     }
   }
 
   params <- data.frame(
-    Parameter = c(thresholds$Parameter, coefficients$Parameter),
-    Estimate = c(unname(thresholds[, "Estimate"]), unname(coefficients[, "Estimate"])),
-    Component = c(rep("thresholds", nrow(thresholds)), rep("conditional", nrow(coefficients))),
-    Response = c(thresholds$Response, coefficients$Response),
+    Parameter = c(thresholds$Parameter, model_coef$Parameter),
+    Estimate = c(unname(thresholds[, "Estimate"]), unname(model_coef[, "Estimate"])),
+    Component = c(rep("thresholds", nrow(thresholds)), rep("conditional", nrow(model_coef))),
+    Response = c(thresholds$Response, model_coef$Response),
     stringsAsFactors = FALSE,
     row.names = NULL
   )

diff --git a/R/get_statistic.R b/R/get_statistic.R
@@ -1128,6 +1128,26 @@ get_statistic.negbinirr <- get_statistic.logitor
 # Other models -------------------------------------------------------
 
 
+#' @export
+get_statistic.glmgee <- function(x, ...) {
+  junk <- utils::capture.output({
+    cs <- suppressWarnings(stats::coef(summary(x, corr = FALSE)))
+  })
+  stat <- stats::na.omit(cs[, "z-value"])
+
+  out <- data.frame(
+    Parameter = names(stat),
+    Statistic = as.vector(stat),
+    stringsAsFactors = FALSE,
+    row.names = NULL
+  )
+
+  out <- text_remove_backticks(out)
+  attr(out, "statistic") <- find_statistic(x)
+  out
+}
+
+
 #' @export
 get_statistic.nestedLogit <- function(x, component = "all", verbose = TRUE, ...) {
   cf <- as.data.frame(stats::coef(x))

diff --git a/R/helper_functions.R b/R/helper_functions.R
@@ -125,7 +125,8 @@
     model,
     c(
       "MCMCglmm", "gee", "LORgee", "mixor", "clmm2", "felm", "feis", "bife",
-      "BFBayesFactor", "BBmm", "glimML", "MANOVA", "RM", "cglm", "glmm"
+      "BFBayesFactor", "BBmm", "glimML", "MANOVA", "RM", "cglm", "glmm",
+      "glmgee"
     )
   )
 

diff --git a/R/is_model.R b/R/is_model.R
@@ -86,7 +86,7 @@ is_regression_model <- function(x) {
     # g --------------------
     "gam", "Gam", "GAMBoost", "gamlr", "gamlss", "gamm", "gamm4",
     "garch", "gbm", "gee", "geeglm", "gjrm", "glht", "glimML", "Glm", "glm",
-    "glmaag", "glmbb", "glmboostLSS", "glmc", "glmdm", "glmdisc",
+    "glmaag", "glmbb", "glmboostLSS", "glmc", "glmdm", "glmdisc", "glmgee",
     "glmerMod", "glmlep", "glmm", "glmmadmb", "glmmEP", "glmmFit",
     "glmmfields", "glmmLasso", "glmmPQL", "glmmTMB", "glmnet", "glmrob",
     "glmRob", "glmx", "gls", "gmnl", "gmm", "gnls", "gsm", "ggcomparisons",
@@ -166,7 +166,7 @@ is_regression_model <- function(x) {
   if (isTRUE(regression_only)) {
     out <- setdiff(out, c(
       "emmGrid", "emm_list", "htest", "pairwise.htest", "summary.lm",
-      "marginaleffects", "marginaleffects.summary"
+      "marginaleffects", "marginaleffects.summary", "ggcomparisons"
     ))
   }
 

diff --git a/R/link_function.R b/R/link_function.R
@@ -512,6 +512,9 @@ link_function.bife <- function(x, ...) {
   x$family$linkfun
 }
 
+#' @export
+link_function.glmgee <- link_function.bife
+
 
 #' @export
 link_function.cpglmm <- function(x, ...) {

diff --git a/R/link_inverse.R b/R/link_inverse.R
@@ -479,6 +479,9 @@ link_inverse.bife <- function(x, ...) {
   x$family$linkinv
 }
 
+#' @export
+link_inverse.glmgee <- link_inverse.bife
+
 
 #' @export
 link_inverse.glmmadmb <- function(x, ...) {

diff --git a/R/model_info.R b/R/model_info.R
@@ -1001,6 +1001,19 @@ model_info.glmmadmb <- function(x, ...) {
 }
 
 
+#' @export
+model_info.glmgee <- function(x, ...) {
+  faminfo <- x$family
+  .make_family(
+    x = x,
+    fitfam = faminfo$family,
+    logit.link = faminfo$link == "logit",
+    link.fun = faminfo$link,
+    ...
+  )
+}
+
+
 #' @export
 model_info.cpglmm <- function(x, ...) {
   link <- parse(text = safe_deparse(x@call))[[1]]$link

diff --git a/R/n_obs.R b/R/n_obs.R
@@ -620,6 +620,12 @@ n_obs.wbgee <- function(x, ...) {
 }
 
 
+#' @export
+n_obs.glmgee <- function(x, ...) {
+  length(x$fitted.values)
+}
+
+
 #' @export
 n_obs.Rchoice <- function(x, ...) {
   nrow(x$mf)