Support for nestedLogit models (#633)

easystats · Oct 4, 2023 · 32199f2 · 32199f2
1 parent 198578d
commit 32199f2
Show file tree

Hide file tree

Showing 17 changed files with 387 additions and 54 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.10.5.5
+Version: 0.10.5.6
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -117,6 +117,7 @@ Suggests:
     mgcv,
     mlogit,
     multimode,
+    nestedLogit,
     nlme,
     nonnest2,
     ordinal,
@@ -149,4 +150,4 @@ Config/Needs/website:
     r-lib/pkgdown,
     easystats/easystatstemplate
 Config/rcmdcheck/ignore-inconsequential-notes: true
-Remotes: easystats/see, easystats/parameters
+Remotes: easystats/see, easystats/parameters, easystats/insight
diff --git a/NAMESPACE b/NAMESPACE
@@ -180,6 +180,7 @@ S3method(model_performance,model_fit)
 S3method(model_performance,multinom)
 S3method(model_performance,negbinirr)
 S3method(model_performance,negbinmfx)
+S3method(model_performance,nestedLogit)
 S3method(model_performance,plm)
 S3method(model_performance,poissonirr)
 S3method(model_performance,poissonmfx)
@@ -371,6 +372,7 @@ S3method(r2,model_fit)
 S3method(r2,multinom)
 S3method(r2,negbinirr)
 S3method(r2,negbinmfx)
+S3method(r2,nestedLogit)
 S3method(r2,ols)
 S3method(r2,phylolm)
 S3method(r2,plm)
@@ -413,6 +415,7 @@ S3method(r2_coxsnell,mclogit)
 S3method(r2_coxsnell,multinom)
 S3method(r2_coxsnell,negbinirr)
 S3method(r2_coxsnell,negbinmfx)
+S3method(r2_coxsnell,nestedLogit)
 S3method(r2_coxsnell,poissonirr)
 S3method(r2_coxsnell,poissonmfx)
 S3method(r2_coxsnell,polr)
@@ -468,6 +471,7 @@ S3method(r2_nagelkerke,mclogit)
 S3method(r2_nagelkerke,multinom)
 S3method(r2_nagelkerke,negbinirr)
 S3method(r2_nagelkerke,negbinmfx)
+S3method(r2_nagelkerke,nestedLogit)
 S3method(r2_nagelkerke,poissonirr)
 S3method(r2_nagelkerke,poissonmfx)
 S3method(r2_nagelkerke,polr)
@@ -479,6 +483,8 @@ S3method(r2_posterior,BFBayesFactor)
 S3method(r2_posterior,brmsfit)
 S3method(r2_posterior,stanmvreg)
 S3method(r2_posterior,stanreg)
+S3method(r2_tjur,default)
+S3method(r2_tjur,nestedLogit)
 S3method(residuals,BFBayesFactor)
 S3method(residuals,check_normality_numeric)
 S3method(residuals,iv_robust)

diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,9 @@
 # performance (development version)
 
+## General
+
+* Support for `nestedLogit` models.
+
 ## Changes to functions
 
 * `check_outliers()` for method `"ics"` now detects number of available cores

diff --git a/R/check_itemscale.R b/R/check_itemscale.R
@@ -40,8 +40,6 @@
 #' - Briggs SR, Cheek JM (1986) The role of factor analysis in the development
 #'   and evaluation of personality scales. Journal of Personality, 54(1),
 #'   106-148. doi: 10.1111/j.1467-6494.1986.tb00391.x
-#' - Trochim WMK (2008) Types of Reliability.
-#'   ([web](https://conjointly.com/kb/types-of-reliability/))
 #'
 #' @examplesIf require("parameters") && require("psych")
 #' # data generation from '?prcomp', slightly modified
@@ -82,9 +80,9 @@ check_itemscale <- function(x) {
       Mean = vapply(items, mean, numeric(1), na.rm = TRUE),
       SD = vapply(items, stats::sd, numeric(1), na.rm = TRUE),
       Skewness = vapply(items, function(i) as.numeric(datawizard::skewness(i)), numeric(1)),
-      "Difficulty" = item_difficulty(items)$Difficulty,
-      "Discrimination" = .item_discr,
-      "alpha if deleted" = .item_alpha,
+      Difficulty = item_difficulty(items)$Difficulty,
+      Discrimination = .item_discr,
+      `alpha if deleted` = .item_alpha,
       stringsAsFactors = FALSE,
       check.names = FALSE
     )

diff --git a/R/model_performance.lm.R b/R/model_performance.lm.R
@@ -125,10 +125,10 @@ model_performance.lm <- function(model, metrics = "all", verbose = TRUE, ...) {
   if (("LOGLOSS" %in% toupper(metrics)) && isTRUE(info$is_binomial)) {
     out$Log_loss <- .safe({
       .logloss <- performance_logloss(model, verbose = verbose)
-      if (!is.na(.logloss)) {
-        .logloss
-      } else {
+      if (is.na(.logloss)) {
         NULL
+      } else {
+        .logloss
       }
     })
   }
@@ -253,6 +253,22 @@ model_performance.zeroinfl <- model_performance.lm
 #' @export
 model_performance.zerotrunc <- model_performance.lm
 
+#' @export
+model_performance.nestedLogit <- function(model, metrics = "all", verbose = TRUE, ...) {
+  mp <- lapply(model$models, model_performance.lm, metrics = metrics, verbose = verbose, ...)
+  out <- cbind(
+    data.frame(Response = names(mp), stringsAsFactors = FALSE),
+    do.call(rbind, mp)
+  )
+  # need to handle R2 separately
+  if (any(c("ALL", "R2") %in% toupper(metrics))) {
+    out$R2 <- unlist(r2_tjur(model))
+  }
+
+  row.names(out) <- NULL
+  class(out) <- unique(c("performance_model", class(out)))
+  out
+}