finalize work on hglm

easystats · Mar 6, 2023 · 86ee222 · 86ee222
1 parent 2beb030
commit 86ee222
Show file tree

Hide file tree

Showing 4 changed files with 134 additions and 9 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: parameters
 Title: Processing of Model Parameters
-Version: 0.20.2.7
+Version: 0.20.2.8
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

diff --git a/NAMESPACE b/NAMESPACE
@@ -43,6 +43,7 @@ S3method(ci,glht)
 S3method(ci,glm)
 S3method(ci,glmm)
 S3method(ci,glmmTMB)
+S3method(ci,hglm)
 S3method(ci,hurdle)
 S3method(ci,ivFixed)
 S3method(ci,ivprobit)

diff --git a/NEWS.md b/NEWS.md
@@ -2,7 +2,7 @@
 
 ## General
 
-* Added support for models of class `hgml` (*hglm*).
+* Added support for models of class `hglm` (*hglm*).
 
 ## Changes to functions
 

diff --git a/R/methods_hglm.R b/R/methods_hglm.R
@@ -29,31 +29,96 @@ model_parameters.hglm <- function(model,
                                   ...) {
   # which components to return?
   effects <- match.arg(effects, choices = c("fixed", "random", "all"))
-  component <- match.arg(component, choices = c("all", "conditional", "zi", "zero_inflated", "dispersion"))
+  component <- match.arg(component, choices = c("all", "conditional", "dispersion"))
+
+  # fixed effects
 
   mp <- model_parameters.default(
     model, ci = ci, ci_method = ci_method, bootstrap = bootstrap,
-    effects = "fixed", component = component, iterations = iterations,
+    effects = "fixed", component = "conditional", iterations = iterations,
     exponentiate = exponentiate, p_adjust = p_adjust, summary = summary,
     keep = keep, drop = drop, verbose = verbose, ...
   )
 
+  # hglm has a special structure, so we add random effects and dispersion
+  # manually here...
+
+  if (effects %in% c("all", "random")) {
+    re_params <- insight::get_parameters(model, effects = "random", component = "conditional")
+    re_se <- standard_error(model, effects = "random", component = "conditional")
+    re_ci <- ci(model, effects = "random", component = "conditional")
+    # bind all results
+    re_params <- cbind(
+      re_params[c("Parameter", "Estimate")],
+      re_se["SE"],
+      re_ci[c("CI", "CI_low", "CI_high")]
+    )
+    # no values for statistic, df and p
+    re_params$t <- re_params$df_error <- re_params$p <- NA
+    # add effects-columns
+    mp$Effects <- "fixed"
+    re_params$Effects <- "random"
+    # renaming
+    colnames(re_params)[colnames(re_params) == "Estimate"] <- "Coefficient"
+    # bind together
+    mp <- rbind(mp, re_params)
+  }
+
+  # add dispersion model
+
+  has_dispersion <- !is.null(insight::find_formula(model)$dispersion)
+  if (has_dispersion && component %in% c("all", "dispersion")) {
+    disp_params <- insight::get_parameters(model, effects = "fixed", component = "dispersion")
+    disp_se <- standard_error(model, effects = "fixed", component = "dispersion")
+    disp_ci <- ci(model, effects = "fixed", component = "dispersion")
+    # bind all results
+    disp_params <- cbind(
+      disp_params[c("Parameter", "Estimate")],
+      disp_se["SE"],
+      disp_ci[c("CI", "CI_low", "CI_high")]
+    )
+    # no values for statistic, df and p
+    disp_params$t <- disp_params$df_error <- disp_params$p <- NA
+    # add effects-columns
+    if (is.null(mp$Effects)) {
+      mp$Effects <- "fixed"
+    }
+    disp_params$Effects <- "fixed"
+    # add component-columns
+    mp$Component <- "conditional"
+    disp_params$Component <- "dispersion"
+    # renaming
+    colnames(disp_params)[colnames(disp_params) == "Estimate"] <- "Coefficient"
+    # bind together
+    mp <- rbind(mp, disp_params)
+  }
+
   mp
 }
 
+
 #' @export
 standard_error.hglm <- function(model,
                                 effects = "fixed",
                                 component = "conditional",
+                                verbose = TRUE,
                                 ...) {
   effects <- match.arg(effects, choices = c("all", "fixed", "random"))
   component <- match.arg(component, choices = c("all", "conditional", "dispersion"))
 
   f <- insight::find_formula(model)
   if (component == "dispersion" && is.null(f$dispersion)) {
-    insight::format_warning("No standard errors found for model's dispersion parameters.")
+    if (verbose) {
+      insight::format_warning("No standard errors found for model's dispersion parameters.")
+    }
     return(NULL)
   }
+
+  # sanity check, make sure we have a dispersion component
+  if (component == "all" && is.null(f$dispersion)) {
+    compomnent <- "conditional"
+  }
+
   s <- summary(model)
 
   if (effects == "fixed") {
@@ -68,15 +133,22 @@ standard_error.hglm <- function(model,
     SE = as.vector(se[, 2])
   )
 
-  if (effects != "random" && component != "conditional") {
+  # dispersion component?
+  if (effects != "random" && component %in% c("dispersion", "all")) {
     se <- s$SummVC1
-    out$Component <- "conditional"
-    out <- rbind(out, .data_frame(
+    disp <- .data_frame(
       Parameter = row.names(se),
       SE = as.vector(se[, 2]),
       Component = "dispersion"
-    ))
+    )
+    if (component == "dispersion") {
+      out <- disp
+    } else {
+      out$Component <- "conditional"
+      out <- rbind(out, disp)
+    }
   }
+
   out
 }
 
@@ -88,3 +160,55 @@ degrees_of_freedom.hglm <- function(model, method = "residual", ...) {
   }
   insight::get_df(model, type = method, ...)
 }
+
+
+#' @export
+ci.hglm <- function(model,
+                    ci = 0.95,
+                    method = "wald",
+                    dof = NULL,
+                    effects = "fixed",
+                    component = "conditional",
+                    verbose = TRUE,
+                    ...) {
+  effects <- match.arg(effects, choices = c("all", "fixed", "random"))
+  component <- match.arg(component, choices = c("all", "conditional", "dispersion"))
+
+  # fixed effects -----------------
+
+  if (effects %in% c("fixed", "all")) {
+    out <- .ci_generic(
+      model,
+      ci = ci,
+      method = method,
+      dof = dof,
+      effects = "fixed",
+      component = component,
+      verbose = verbose,
+      ...
+    )
+  }
+
+  # add random effects -----------------
+
+  if (effects %in% c("random", "all")) {
+    se <- standard_error(model, effects = "random", component = "conditional")$SE
+    .ci_re <- .ci_dof(
+      model,
+      ci = ci,
+      method = method,
+      dof = dof,
+      effects = "random",
+      component = "conditional",
+      se = se,
+      verbose = verbose,
+      ...
+    )
+    if (effects == "all") {
+      out <- rbind(out, .ci_Re)
+    } else {
+      out <- .ci_re
+    }
+  }
+  out
+}