Support for package WeightIt

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 0.20.3.3
+Version: 0.20.3.4
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

NAMESPACE

@@ -274,6 +274,7 @@ S3method(find_parameters,mle2)
 S3method(find_parameters,mlm)
 S3method(find_parameters,model_fit)
 S3method(find_parameters,multinom)
+S3method(find_parameters,multinom_weightit)
 S3method(find_parameters,mvord)
 S3method(find_parameters,negbinirr)
 S3method(find_parameters,negbinmfx)
@@ -689,11 +690,13 @@ S3method(get_parameters,mle2)
 S3method(get_parameters,mlm)
 S3method(get_parameters,model_fit)
 S3method(get_parameters,multinom)
+S3method(get_parameters,multinom_weightit)
 S3method(get_parameters,mvord)
 S3method(get_parameters,negbinirr)
 S3method(get_parameters,negbinmfx)
 S3method(get_parameters,nestedLogit)
 S3method(get_parameters,nlmerMod)
+S3method(get_parameters,ordinal_weightit)
 S3method(get_parameters,orm)
 S3method(get_parameters,pgmm)
 S3method(get_parameters,poissonirr)
@@ -901,13 +904,15 @@ S3method(get_statistic,mmrm_fit)
 S3method(get_statistic,mmrm_tmb)
 S3method(get_statistic,model_fit)
 S3method(get_statistic,multinom)
+S3method(get_statistic,multinom_weightit)
 S3method(get_statistic,mvord)
 S3method(get_statistic,negbin)
 S3method(get_statistic,negbinirr)
 S3method(get_statistic,negbinmfx)
 S3method(get_statistic,nestedLogit)
 S3method(get_statistic,nlrq)
 S3method(get_statistic,ols)
+S3method(get_statistic,ordinal_weightit)
 S3method(get_statistic,orm)
 S3method(get_statistic,pgmm)
 S3method(get_statistic,plm)
@@ -1142,10 +1147,12 @@ S3method(link_function,mmrm_fit)
 S3method(link_function,mmrm_tmb)
 S3method(link_function,model_fit)
 S3method(link_function,multinom)
+S3method(link_function,multinom_weightit)
 S3method(link_function,mvord)
 S3method(link_function,negbinirr)
 S3method(link_function,negbinmfx)
 S3method(link_function,nestedLogit)
+S3method(link_function,ordinal_weightit)
 S3method(link_function,orm)
 S3method(link_function,phylolm)
 S3method(link_function,plm)
@@ -1268,10 +1275,12 @@ S3method(link_inverse,mmrm_fit)
 S3method(link_inverse,mmrm_tmb)
 S3method(link_inverse,model_fit)
 S3method(link_inverse,multinom)
+S3method(link_inverse,multinom_weightit)
 S3method(link_inverse,mvord)
 S3method(link_inverse,negbinirr)
 S3method(link_inverse,negbinmfx)
 S3method(link_inverse,nestedLogit)
+S3method(link_inverse,ordinal_weightit)
 S3method(link_inverse,orm)
 S3method(link_inverse,phyloglm)
 S3method(link_inverse,phylolm)
@@ -1418,12 +1427,14 @@ S3method(model_info,mmrm_fit)
 S3method(model_info,mmrm_tmb)
 S3method(model_info,model_fit)
 S3method(model_info,multinom)
+S3method(model_info,multinom_weightit)
 S3method(model_info,mvord)
 S3method(model_info,negbinirr)
 S3method(model_info,negbinmfx)
 S3method(model_info,nestedLogit)
 S3method(model_info,nlrq)
 S3method(model_info,nls)
+S3method(model_info,ordinal_weightit)
 S3method(model_info,orm)
 S3method(model_info,phyloglm)
 S3method(model_info,phylolm)

NEWS.md

@@ -1,5 +1,10 @@
 # insight 0.20.4
 
+## New supported models
+
+* Support for models of classes `glm_weighit`, `multinom_weightit` and
+  `ordinal_weightit` (package *WeightIt*).
+
 ## Changes
 
 * `null_model()` and `formula_ok()` now warn when indexed data frames, such as

R/find_parameters.R

@@ -173,6 +173,19 @@
 #' @export
 find_parameters.brmultinom <- find_parameters.multinom
 
+#' @export
+find_parameters.multinom_weightit <- function(x, flatten = FALSE, ...) {
+  params <- stats::coef(x)
+  resp <- gsub("(.*)~(.*)", "\\1", names(params))
+  pars <- gsub("(.*)~(.*)", "\\2", names(params))[resp == resp[1]]
+
+  if (flatten) {
+    unique(unlist(pars, use.names = FALSE))
+  } else {
+    pars
+  }
+}
+
 
 # SEM models ------------------------------------------------------
 
@@ -815,7 +828,7 @@
 
 # helper ----------------------------
 
 .filter_parameters <- function(l, effects, component = "all", flatten, recursive = TRUE) {
   if (isTRUE(recursive)) {
     # recursively remove back-ticks from all list-elements parameters
     l <- rapply(l, text_remove_backticks, how = "list")

R/find_statistic.R

@@ -18,7 +18,7 @@
 #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars)
 #' find_statistic(m)
 #' @export
 find_statistic <- function(x, ...) {
   # model object check --------------------------------------------------------
 
   # check if the object is a model object; if not, quit early
@@ -127,9 +127,9 @@
     "lavaan", "loggammacenslmrob", "logitmfx", "logitor", "logitr", "LORgee", "lrm",
     "margins", "marginaleffects", "marginaleffects.summary", "metaplus", "mixor",
     "MixMod", "mjoint", "mle", "mle2", "mlogit", "mblogit", "mclogit", "mmclogit",
-    "multinom", "mvmeta", "mvord",
+    "multinom", "mvmeta", "mvord", "multinom_weightit",
     "negbin", "negbinmfx", "negbinirr", "nlreg", "nestedLogit",
-    "objectiveML", "orm",
+    "objectiveML", "orm", "ordinal_weightit",
     "poissonmfx", "poissonirr", "psm", "probitmfx", "pgmm", "phyloglm",
     "qr", "QRNLMM", "QRLMM",
     "Rchoice", "riskRegression", "robmixglm", "rma", "rma.mv", "rma.uni", "rrvglm",

R/get_parameters.R

@@ -82,7 +82,7 @@ get_parameters.default <- function(x, verbose = TRUE, ...) {
           sprintf("Parameters can't be retrieved for objects of class `%s`.", class(x)[1])
         )
       }
-      return(NULL)
+      NULL
     }
   )
 }
@@ -128,6 +128,14 @@ get_parameters.model_fit <- function(x, ...) {
 }
 
 
+#' @export
+get_parameters.ordinal_weightit <- function(x, ...) {
+  out <- get_parameters.default(x, ...)
+  out$Component <- "conditional"
+  out
+}
+
+
 #' @export
 get_parameters.bfsl <- function(x, ...) {
   cf <- stats::coef(x)
@@ -426,6 +434,22 @@ get_parameters.multinom <- function(x, ...) {
 }
 
 
+#' @export
+get_parameters.multinom_weightit <- function(x, ...) {
+  params <- stats::coef(x)
+
+  out <- data.frame(
+    Parameter = gsub("(.*)~(.*)", "\\2", names(params)),
+    Estimate = unname(params),
+    Response = gsub("(.*)~(.*)", "\\1", names(params)),
+    stringsAsFactors = FALSE,
+    row.names = NULL
+  )
+
+  text_remove_backticks(out)
+}
+
+
 #' @export
 get_parameters.brmultinom <- get_parameters.multinom
 
@@ -749,7 +773,7 @@ get_parameters.manova <- function(x, ...) {
   out <- out[c("Parameter", "Estimate", "Response")]
   rownames(out) <- NULL
 
-  pattern <- paste0("(", paste0(paste0(".", unique(out$Response)), collapse = "|"), ")$")
+  pattern <- paste0("(", paste(paste0(".", unique(out$Response)), collapse = "|"), ")$")
   out$Parameter <- gsub(pattern, "", out$Parameter)
 
   text_remove_backticks(out)

R/get_statistic.R

@@ -795,6 +795,14 @@ get_statistic.clm2 <- function(x, component = "all", ...) {
 get_statistic.clmm2 <- get_statistic.clm2
 
 
+#' @export
+get_statistic.ordinal_weightit <- function(x, ...) {
+  out <- get_statistic.default(x, ...)
+  out$Component <- "conditional"
+  out
+}
+
+
 #' @export
 get_statistic.mvord <- function(x, component = "all", ...) {
   component <- match.arg(
@@ -924,6 +932,26 @@ get_statistic.multinom <- function(x, ...) {
 #' @export
 get_statistic.brmultinom <- get_statistic.multinom
 
+#' @export
+get_statistic.multinom_weightit <- function(x, ...) {
+  parms <- get_parameters(x)
+  cs <- suppressWarnings(stats::coef(summary(x)))
+
+  out <- data.frame(
+    Parameter = parms$Parameter,
+    Statistic = as.vector(cs[, 3]),
+    stringsAsFactors = FALSE,
+    row.names = NULL
+  )
+
+  if ("Response" %in% colnames(parms)) {
+    out$Response <- parms$Response
+  }
+
+  attr(out, "statistic") <- find_statistic(x)
+  out
+}
+
 
 #' @export
 get_statistic.bracl <- function(x, ...) {

R/is_model.R

@@ -90,6 +90,7 @@ is_regression_model <- function(x) {
     "glmerMod", "glmlep", "glmm", "glmmadmb", "glmmEP", "glmmFit",
     "glmmfields", "glmmLasso", "glmmPQL", "glmmTMB", "glmnet", "glmrob",
     "glmRob", "glmx", "gls", "gmnl", "gmm", "gnls", "gsm", "ggcomparisons",
+    "glm_weighit",
 
     # h --------------------
     "heavyLme", "HLfit", "htest", "hurdle", "hglm",
@@ -118,14 +119,14 @@ is_regression_model <- function(x) {
     "mle", "mle2", "mlergm", "mlm", "mlma", "mlogit", "model_fit",
     "multinom", "mvmeta", "mvord", "mvr", "marginaleffects",
     "marginaleffects.summary", "mblogit", "mclogit", "mmrm", "mmrm_fit",
-    "mmrm_tmb",
+    "mmrm_tmb", "multinom_weightit",
 
     # n --------------------
     "negbin", "negbinmfx", "negbinirr", "nlreg", "nlrq", "nls",
     "nparLD", "nestedLogit",
 
     # o --------------------
-    "objectiveML", "ols", "osrt", "orcutt",
+    "objectiveML", "ols", "osrt", "orcutt", "ordinal_weightit",
 
     # p --------------------
     "pairwise.htest", "pb1", "pb2", "pgmm", "plm", "plmm", "PMCMR",

R/is_model_supported.R

@@ -71,7 +71,7 @@ supported_models <- function() {
     "gam", "Gam", "gamlss", "gamm", "gamm4", "garch", "gbm", "gee", "geeglm",
     "glht", "glimML", "glmm", "glm", "Glm", "glmmadmb", "glmmPQL", "glmmTMB",
     "glmrob", "glmRob", "glmx", "gls", "gmnl", "glmgee", "ggcomparisons",
-    "glmerMod",
+    "glmerMod", "glm_weighit",
 
     # h ----------------------------
     "HLfit", "htest", "hurdle", "hglm",
@@ -90,13 +90,13 @@ supported_models <- function() {
     "metaplus", "merMod", "merModList", "mipo", "mira", "mixed", "mixor", "MixMod",
     "mhurdle", "mjoint", "mle", "mle2", "mlm", "mblogit", "mclogit", "mcmc.list",
     "meta_bma", "meta_fixed", "meta_random", "mlogit", "mmlogit", "model_fit",
-    "multinom", "mvord", "mmclogit", "mmrm", "mmrm_fit", "mmrm_tmb",
+    "multinom", "mvord", "mmclogit", "mmrm", "mmrm_fit", "mmrm_tmb", "multinom_weightit",
 
     # n ----------------------------
     "negbinmfx", "negbinirr", "nestedLogit",
 
     # o ----------------------------
-    "ols", "onesampb", "orm",
+    "ols", "onesampb", "orm", "ordinal_weighit",
 
     # p ----------------------------
     "PMCMR", "poissonmfx", "poissonirr", "pgmm", "plm", "polr", "psm",

R/link_function.R

@@ -265,6 +265,14 @@ link_function.riskRegression <- link_function.multinom
 #' @export
 link_function.comprisk <- link_function.multinom
 
+#' @export
+link_function.multinom_weightit <- function(x, ...) {
+  stats::make.link(link = x$family$link)$linkfun
+}
+
+#' @export
+link_function.ordinal_weightit <- link_function.multinom_weightit
+
 
 # Phylo glm ------------------------
 

R/link_inverse.R

@@ -302,6 +302,14 @@ link_inverse.flic <- link_inverse.gmnl
 #' @export
 link_inverse.multinom <- link_inverse.gmnl
 
+#' @export
+link_inverse.multinom_weightit <- function(x, ...) {
+  stats::make.link(link = x$family$link)$linkinv
+}
+
+#' @export
+link_inverse.ordinal_weightit <- link_inverse.multinom_weightit
+
 
 # Probit link ------------------------
 

R/model_info.R

@@ -39,7 +39,7 @@
 #' * `is_hurdle`: model has zero-inflation component and is a hurdle-model (truncated family distribution)
 #' * `is_dispersion`: model has dispersion component (not only dispersion _parameter_)
 #' * `is_mixed`: model is a mixed effects model (with random effects)
 #' * `is_multivariate`: model is a multivariate response model (currently only works for _brmsfit_ and _vglm/vgam_ objects)
 #' * `is_trial`: model response contains additional information about the trials
 #' * `is_bayesian`: model is a Bayesian model
 #' * `is_gam`: model is a generalized additive model
@@ -415,6 +415,21 @@
 #' @export
 model_info.mixor <- model_info.clm
 
+#' @export
+model_info.ordinal_weightit <- function(x, verbose = TRUE, ...) {
+  faminfo <- stats::binomial(link = .get_ordinal_link(x$family))
+  .make_family(
+    x = x,
+    fitfam = faminfo$family,
+    logit.link = faminfo$link == "logit",
+    link.fun = faminfo$link,
+    verbose = verbose,
+    ...
+  )
+}
+
+#' @export
+model_info.multinom_weightit <- model_info.ordinal_weightit
 
 #' @export
 model_info.mvord <- function(x, verbose = verbose, ...) {

R/utils_model_info.R

@@ -1,4 +1,4 @@
 .make_family <- function(x,
                          fitfam = "gaussian",
                          zero.inf = FALSE,
                          hurdle = FALSE,
@@ -144,14 +144,14 @@
   # ordinal family --------
 
   is.ordinal <-
-    inherits(x, c("svyolr", "polr", "serp", "clm", "clm2", "clmm", "mixor", "LORgee", "mvord")) |
+    inherits(x, c("svyolr", "polr", "serp", "clm", "clm2", "clmm", "mixor", "LORgee", "mvord", "ordinal_weightit")) |
       fitfam %in% c("cumulative", "ordinal")
 
 
   # multinomial family --------
 
   is.multinomial <-
-    inherits(x, c("gmnl", "mclogit", "mblogit", "mmclogit", "mlogit", "DirichletRegModel", "multinom", "brmultinom")) |
+    inherits(x, c("gmnl", "mclogit", "mblogit", "mmclogit", "mlogit", "DirichletRegModel", "multinom", "brmultinom", "multinom_weightit")) |
       fitfam %in% c("cratio", "sratio", "acat", "multinom", "multinomial", "multinomial2", "dirichlet")
 
 
@@ -345,7 +345,7 @@
     dirichlet_fam || is.ordinal || zero.inf || is.censored || is.survival || is_binomtest ||
     is.categorical || hurdle || is.multinomial || is_chi2test || is_proptest || is_xtab) {
     linear_model <- FALSE
   } else if (!(fitfam %in% c("Student's-t", "t Family", "gaussian", "Gaussian", "lognormal")) && !grepl("(\\st)$", fitfam)) {
     linear_model <- FALSE
   }
   if (!linear_model && is.survival && fitfam == "gaussian") {