Merge branch 'JOSE_paper' of https://github.com/easystats/performance …

…into JOSE_paper

.github/workflows/html-5-check.yaml

@@ -6,8 +6,8 @@ on:
   pull_request:
     branches: [main, master]
 
-name: HTML5 check
+name: html-5-check
 
 jobs:
-  HTML5-check:
+  html-5-check:
     uses: easystats/workflows/.github/workflows/html-5-check.yaml@main

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.10.5.4
+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

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)

NEWS.md

@@ -1,12 +1,21 @@
 # performance (development version)
 
+## General
+
+* Support for `nestedLogit` models.
+
 ## Changes to functions
 
 * `check_outliers()` for method `"ics"` now detects number of available cores
   for parallel computing via the `"mc.cores"` option. This is more robust than
   the previous method, which used `parallel::detectCores()`. Now you should
   set the number of cores via `options(mc.cores = 4)`.
 
+## Bug fixes
+
+* Fixed issues is `check_model()` for models that used data sets with
+  variables of class `"haven_labelled"`.
+
 # performance 0.10.5
 
 ## Changes to functions

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
     )

R/check_model_diagnostics.R

@@ -153,7 +153,7 @@
 # prepare data for normality of residuals plot ----------------------------------
 
 .diag_norm <- function(model, verbose = TRUE) {
-  r <- try(stats::residuals(model), silent = TRUE)
+  r <- try(as.numeric(stats::residuals(model)), silent = TRUE)
 
   if (inherits(r, "try-error")) {
     insight::format_alert(sprintf("Non-normality of residuals could not be computed. Cannot extract residuals from objects of class '%s'.", class(model)[1]))
@@ -174,16 +174,16 @@
 
   if (inherits(model, "lm", which = TRUE) == 1) {
     cook_levels <- round(stats::qf(0.5, s$fstatistic[2], s$fstatistic[3]), 2)
-  } else if (!is.null(threshold)) {
-    cook_levels <- threshold
-  } else {
+  } else if (is.null(threshold)) {
     cook_levels <- c(0.5, 1)
+  } else {
+    cook_levels <- threshold
   }
 
   n_params <- tryCatch(model$rank, error = function(e) insight::n_parameters(model))
 
   infl <- stats::influence(model, do.coef = FALSE)
-  resid <- insight::get_residuals(model)
+  resid <- as.numeric(insight::get_residuals(model))
 
   std_resid <- tryCatch(stats::rstandard(model, infl), error = function(e) resid)
 
@@ -212,8 +212,8 @@
   ncv <- tryCatch(
     {
       data.frame(
-        x = stats::fitted(model),
-        y = stats::residuals(model)
+        x = as.numeric(stats::fitted(model)),
+        y = as.numeric(stats::residuals(model))
       )
     },
     error = function(e) {

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
+}