Support for "serp" (#850)

* Support for "serp" * suggest * Update model_info.R * Update NAMESPACE * ... * lintr * add tests * readme * typo * lintr * styler
easystats · Feb 23, 2024 · 0d051b0 · 0d051b0
1 parent 43ccafd
commit 0d051b0
Show file tree

Hide file tree

Showing 16 changed files with 277 additions and 107 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.19.8.3
+Version: 0.19.8.4
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -186,6 +186,7 @@ Suggests:
     rstantools (>= 2.1.0),
     rstudioapi,
     sandwich,
+    serp,
     speedglm,
     splines,
     statmod,

diff --git a/NAMESPACE b/NAMESPACE
@@ -563,6 +563,7 @@ S3method(get_modelmatrix,lm_robust)
 S3method(get_modelmatrix,lme)
 S3method(get_modelmatrix,merMod)
 S3method(get_modelmatrix,rlm)
+S3method(get_modelmatrix,serp)
 S3method(get_modelmatrix,svyglm)
 S3method(get_parameters,BBmm)
 S3method(get_parameters,BBreg)
@@ -1124,6 +1125,7 @@ S3method(link_function,robmixglm)
 S3method(link_function,rq)
 S3method(link_function,rqs)
 S3method(link_function,rqss)
+S3method(link_function,serp)
 S3method(link_function,speedglm)
 S3method(link_function,speedlm)
 S3method(link_function,stanmvreg)
@@ -1248,6 +1250,7 @@ S3method(link_inverse,robmixglm)
 S3method(link_inverse,rq)
 S3method(link_inverse,rqs)
 S3method(link_inverse,rqss)
+S3method(link_inverse,serp)
 S3method(link_inverse,speedglm)
 S3method(link_inverse,speedlm)
 S3method(link_inverse,stanmvreg)
@@ -1397,6 +1400,7 @@ S3method(model_info,robmixglm)
 S3method(model_info,rq)
 S3method(model_info,rqs)
 S3method(model_info,rqss)
+S3method(model_info,serp)
 S3method(model_info,speedglm)
 S3method(model_info,speedlm)
 S3method(model_info,stanmvreg)

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,7 @@
+# insight 0.19.9
+
+* Support for models of class `serp` (package *serp*).
+
 # insight 0.19.8
 
 ## General

diff --git a/R/find_statistic.R b/R/find_statistic.R
@@ -37,7 +37,7 @@ find_statistic <- function(x, ...) {
         t = "t-statistic",
         Z = "z-statistic",
         `Quade F` = ,
-        `F` = "F-statistic",
+        `F` = "F-statistic", # nolint
         `Bartlett's K-squared` = ,
         `Fligner-Killeen:med chi-squared` = ,
         `Friedman chi-squared` = ,
@@ -132,7 +132,7 @@ find_statistic <- function(x, ...) {
     "poissonmfx", "poissonirr", "psm", "probitmfx", "pgmm", "phyloglm",
     "qr", "QRNLMM", "QRLMM",
     "Rchoice", "riskRegression", "robmixglm", "rma", "rma.mv", "rma.uni", "rrvglm",
-    "Sarlm", "sem", "SemiParBIV", "slm", "slopes", "survreg", "svy_vglm",
+    "Sarlm", "sem", "SemiParBIV", "serp", "slm", "slopes", "survreg", "svy_vglm",
     "test_mediation", "tobit",
     "vglm",
     "wbgee",
@@ -229,13 +229,11 @@ find_statistic <- function(x, ...) {
   # family, so this exception needs to be caught before checking for g.mods
 
   tryCatch(
-    {
-      suppressWarnings(
-        if (!is_multivariate(x) && .is_tweedie(x, m_info)) {
-          return("t-statistic")
-        }
-      )
-    },
+    suppressWarnings(
+      if (!is_multivariate(x) && .is_tweedie(x, m_info)) {
+        return("t-statistic")
+      }
+    ),
     error = function(e) {}
   )
 
@@ -267,8 +265,8 @@ find_statistic <- function(x, ...) {
     if (model_class %in% c("emmGrid", "emm_list")) {
       stat <- tryCatch(
         {
-          df <- get_df(x)
-          if (all(is.na(df)) || all(is.infinite(df))) {
+          dof <- get_df(x)
+          if (all(is.na(dof)) || all(is.infinite(dof))) {
             "z-statistic"
           } else {
             "t-statistic"

diff --git a/R/get_df.R b/R/get_df.R
@@ -120,16 +120,15 @@ get_df.default <- function(x, type = "residual", verbose = TRUE, ...) {
   }
 
 
-  # Wald normal approximation - always Inf -----
   if (type == "normal") {
+    # Wald normal approximation - always Inf -----
     return(Inf)
-
-    # residual/analytical df, falls back to Inf if we have no residual df method -----
   } else if (type == "residual") {
+    # residual/analytical df, falls back to Inf if we have no residual df method -----
     dof <- .get_residual_df(x, verbose)
-
-    # Wald df - always Inf for z-statistic, 1 for Chi2-statistic, else residual df -----
   } else if (type == "wald") {
+    # Wald df - always Inf for z-statistic, 1 for Chi2-statistic, else residual df -----
+
     # z-statistic always Inf, *unless* we have residual df (which we have for some models)
     if (identical(statistic, "z-statistic")) {
       return(Inf)

diff --git a/R/get_df_residual.R b/R/get_df_residual.R
@@ -98,12 +98,10 @@
 .degrees_of_freedom_residual.lqmm <- function(x, verbose = TRUE, ...) {
   cs <- summary(x)
   tryCatch(
-    {
-      if (!is.null(cs$rdf)) {
-        cs$rdf
-      } else {
-        attr(cs$B, "R") - 1
-      }
+    if (is.null(cs$rdf)) {
+      attr(cs$B, "R") - 1
+    } else {
+      cs$rdf
     },
     error = function(e) {
       NULL
@@ -136,6 +134,11 @@
   x$df
 }
 
+#' @keywords internal
+.degrees_of_freedom_residual.serp <- function(x, verbose = TRUE, ...) {
+  x$rdf
+}
+
 #' @export
 .degrees_of_freedom_residual.BBmm <- .degrees_of_freedom_residual.glht
 
@@ -207,7 +210,7 @@
 
 #' @keywords internal
 .degrees_of_freedom_residual.systemfit <- function(x, verbose = TRUE, ...) {
-  df <- NULL
+  dof <- NULL
   s <- summary(x)$eq
   params <- find_parameters(x)
   f <- find_formula(x)
@@ -216,8 +219,8 @@
   for (i in seq_along(system_names)) {
     dfs <- rep(s[[i]]$df[2], length(params[[i]]))
     df_names <- rep(names(params[i]), length(params[[i]]))
-    df <- c(df, stats::setNames(dfs, df_names))
+    dof <- c(dof, stats::setNames(dfs, df_names))
   }
 
-  df
+  dof
 }
diff --git a/R/get_modelmatrix.R b/R/get_modelmatrix.R
@@ -51,6 +51,18 @@ get_modelmatrix.bracl <- function(x, ...) {
   mm
 }
 
+#' @export
+get_modelmatrix.serp <- function(x, ...) {
+  dots <- list(...)
+  if ("data" %in% names(dots)) {
+    mm <- stats::model.matrix(object = x$Terms, data = dots$data, ...)
+  } else {
+    mm <- stats::model.matrix(object = x$Terms, data = get_data(x), ...)
+  }
+
+  mm
+}
+
 #' @export
 get_modelmatrix.iv_robust <- function(x, ...) {
   dots <- list(...)
@@ -118,7 +130,7 @@ get_modelmatrix.clmm <- function(x, ...) {
 get_modelmatrix.svyglm <- function(x, ...) {
   dots <- list(...)
   if ("data" %in% names(dots)) {
-    data <- tryCatch(
+    model_data <- tryCatch(
       {
         d <- as.data.frame(dots$data)
         response_name <- find_response(x)
@@ -135,7 +147,7 @@ get_modelmatrix.svyglm <- function(x, ...) {
       }
     )
     model_terms <- stats::terms(x)
-    mm <- stats::model.matrix(model_terms, data = data)
+    mm <- stats::model.matrix(model_terms, data = model_data)
   } else {
     mm <- stats::model.matrix(object = x, ...)
   }
@@ -171,7 +183,7 @@ get_modelmatrix.rlm <- function(x, ...) {
     data = mf,
     contrasts.arg = x$contrasts
   )
-  return(mm)
+  mm
 }
 
 
@@ -191,7 +203,7 @@ get_modelmatrix.betareg <- function(x, ...) {
     ))
     mm <- stats::model.matrix(stats::delete.response(x$terms$mean), mf)
   }
-  return(mm)
+  mm
 }
 
 
@@ -220,7 +232,7 @@ get_modelmatrix.BFBayesFactor <- function(x, ...) {
 
 
 .data_in_dots <- function(..., object = NULL, default_data = NULL) {
-  dot.arguments <- lapply(match.call(expand.dots = FALSE)$`...`, function(x) x)
+  dot.arguments <- lapply(match.call(expand.dots = FALSE)[["..."]], function(x) x)
   data_arg <- if ("data" %in% names(dot.arguments)) {
     eval(dot.arguments[["data"]])
   } else {
@@ -259,7 +271,7 @@ get_modelmatrix.BFBayesFactor <- function(x, ...) {
   out <- rbind(pad, data)
   row.names(out) <- NULL
   attr(out, "pad") <- nrow(pad)
-  return(out)
+  out
 }
 
 

diff --git a/R/is_model.R b/R/is_model.R
@@ -141,7 +141,7 @@ is_regression_model <- function(x) {
     "rma.uni", "rms", "robmixglm", "robtab", "rq", "rqs", "rqss",
 
     # s --------------------
-    "Sarlm", "scam", "selection", "sem", "SemiParBIV", "slm", "speedlm",
+    "Sarlm", "scam", "selection", "sem", "SemiParBIV", "serp", "slm", "speedlm",
     "speedglm", "splmm", "spml", "stanmvreg", "stanreg", "summary.lm",
     "survfit", "survreg", "survPresmooth", "svychisq", "svyglm", "svy_vglm",
     "svyolr", "svytable", "systemfit",

diff --git a/R/is_model_supported.R b/R/is_model_supported.R
@@ -106,8 +106,8 @@ supported_models <- function() {
     "robtab", "RM", "rma", "rma.uni", "robmixglm", "rq", "rqs", "rqss", "rvar",
 
     # s ----------------------------
-    "Sarlm", "scam", "selection", "sem", "semLm", "semLme", "SemiParBIV", "slm",
-    "speedlm", "speedglm", "stanfit", "stanmvreg", "stanreg", "summary.lm",
+    "Sarlm", "scam", "selection", "sem", "semLm", "semLme", "SemiParBIV", "serp",
+    "slm", "speedlm", "speedglm", "stanfit", "stanmvreg", "stanreg", "summary.lm",
     "survfit", "survreg", "svy_vglm", "svychisq", "svyglm", "svyolr",
 
     # t ----------------------------

diff --git a/R/link_function.R b/R/link_function.R
@@ -344,6 +344,9 @@ link_function.clm2 <- link_function.clm
 #' @export
 link_function.clmm <- link_function.clm
 
+#' @export
+link_function.serp <- link_function.clm
+
 #' @export
 link_function.mixor <- link_function.clm
 
@@ -760,16 +763,13 @@ link_function.brmsfit <- function(x, ...) {
   # do we have custom families?
   if (!is.null(fam$family) && (is.character(fam$family) && fam$family == "custom")) {
     il <- stats::make.link(fam$link)$linkfun
+  } else if ("linkfun" %in% names(fam)) {
+    il <- fam$linkfun
+  } else if ("link" %in% names(fam) && is.character(fam$link)) {
+    il <- stats::make.link(fam$link)$linkfun
   } else {
-    if ("linkfun" %in% names(fam)) {
-      il <- fam$linkfun
-    } else if ("link" %in% names(fam) && is.character(fam$link)) {
-      il <- stats::make.link(fam$link)$linkfun
-    } else {
-      ff <- get(fam$family, asNamespace("stats"))
-      il <- ff(fam$link)$linkfun
-    }
+    ff <- get(fam$family, asNamespace("stats"))
+    il <- ff(fam$link)$linkfun
   }
-
   il
 }
diff --git a/R/link_inverse.R b/R/link_inverse.R
@@ -344,6 +344,9 @@ link_inverse.clmm <- link_inverse.clm
 #' @export
 link_inverse.clm2 <- link_inverse.clm
 
+#' @export
+link_inverse.serp <- link_inverse.clm
+
 #' @export
 link_inverse.mixor <- link_inverse.clm
 
@@ -726,17 +729,14 @@ link_inverse.mira <- function(x, ...) {
   # do we have custom families?
   if (!is.null(fam$family) && (is.character(fam$family) && fam$family == "custom")) {
     il <- stats::make.link(fam$link)$linkinv
+  } else if ("linkinv" %in% names(fam)) {
+    il <- fam$linkinv
+  } else if ("link" %in% names(fam) && is.character(fam$link)) {
+    il <- stats::make.link(fam$link)$linkinv
   } else {
-    if ("linkinv" %in% names(fam)) {
-      il <- fam$linkinv
-    } else if ("link" %in% names(fam) && is.character(fam$link)) {
-      il <- stats::make.link(fam$link)$linkinv
-    } else {
-      ff <- get(fam$family, asNamespace("stats"))
-      il <- ff(fam$link)$linkinv
-    }
+    ff <- get(fam$family, asNamespace("stats"))
+    il <- ff(fam$link)$linkinv
   }
-
   il
 }
 

diff --git a/R/model_info.R b/R/model_info.R
@@ -409,6 +409,9 @@ model_info.clm2 <- model_info.clm
 #' @export
 model_info.clmm <- model_info.clm
 
+#' @export
+model_info.serp <- model_info.clm
+
 #' @export
 model_info.mixor <- model_info.clm
 

diff --git a/R/utils_model_info.R b/R/utils_model_info.R
@@ -144,7 +144,7 @@
   # ordinal family --------
 
   is.ordinal <-
-    inherits(x, c("svyolr", "polr", "clm", "clm2", "clmm", "mixor", "LORgee", "mvord")) |
+    inherits(x, c("svyolr", "polr", "serp", "clm", "clm2", "clmm", "mixor", "LORgee", "mvord")) |
       fitfam %in% c("cumulative", "ordinal")