From cd524bc3819cff6a774a474f3665d0068c1433b7 Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Tue, 7 Oct 2025 06:23:53 +0000 Subject: [PATCH 01/12] Initial plan From cdd951be187dd89dbd009904e34e78c322076ddc Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Tue, 7 Oct 2025 06:29:18 +0000 Subject: [PATCH 02/12] Implement check_autocorrelation for simulated residuals and use simulated residuals for Poisson mixed models Co-authored-by: strengejacke <26301769+strengejacke@users.noreply.github.com> --- R/check_autocorrelation.R | 32 ++++++++++++++++++++++++++++++-- R/check_overdispersion.R | 11 ++++++----- R/check_zeroinflation.R | 15 +++++++++------ 3 files changed, 45 insertions(+), 13 deletions(-) diff --git a/R/check_autocorrelation.R b/R/check_autocorrelation.R index d94f788f1..fe16e2334 100644 --- a/R/check_autocorrelation.R +++ b/R/check_autocorrelation.R @@ -4,9 +4,11 @@ #' @description Check model for independence of residuals, i.e. for autocorrelation #' of error terms. #' -#' @param x A model object. +#' @param x A model object, or an object returned by `simulate_residuals()`. #' @param nsim Number of simulations for the Durbin-Watson-Test. -#' @param ... Currently not used. +#' @param ... Currently not used for models. For simulated residuals, arguments are +#' passed to `DHARMa::testTemporalAutocorrelation()`, which can include `time` (a +#' vector with time values) to specify the temporal order of the data. #' #' @return Invisibly returns the p-value of the test statistics. A p-value < 0.05 #' indicates autocorrelated residuals. @@ -18,6 +20,11 @@ #' results for the estimates, or maybe a mixed model with error term for the #' cluster groups should be used. #' +#' For simulated residuals (from `simulate_residuals()`), the function uses +#' `DHARMa::testTemporalAutocorrelation()` to check for temporal autocorrelation. +#' This requires the data to be ordered by time. If the data are not ordered by +#' time, you can provide a `time` argument to specify the temporal order. +#' #' @examples #' m <- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) #' check_autocorrelation(m) @@ -49,6 +56,27 @@ check_autocorrelation.default <- function(x, nsim = 1000, ...) { } +#' @rdname check_autocorrelation +#' @export +check_autocorrelation.performance_simres <- function(x, ...) { + insight::check_if_installed("DHARMa") + + # Use DHARMa's temporal autocorrelation test + # This requires the residuals to be ordered by time + # DHARMa::testTemporalAutocorrelation expects a DHARMa object + result <- DHARMa::testTemporalAutocorrelation(x, plot = FALSE, ...) + + # Extract p-value from the result + p.val <- result$p.value + + class(p.val) <- c("check_autocorrelation", "see_check_autocorrelation", class(p.val)) + p.val +} + +#' @export +check_autocorrelation.DHARMa <- check_autocorrelation.performance_simres + + # methods ------------------------------ #' @export diff --git a/R/check_overdispersion.R b/R/check_overdispersion.R index fc2613429..f271282c5 100644 --- a/R/check_overdispersion.R +++ b/R/check_overdispersion.R @@ -40,10 +40,10 @@ #' [GLMM FAQ](http://bbolker.github.io/mixedmodels-misc/glmmFAQ.html), #' section *How can I deal with overdispersion in GLMMs?*. Note that this #' function only returns an *approximate* estimate of an overdispersion -#' parameter. Using this approach would be inaccurate for zero-inflated or -#' negative binomial mixed models (fitted with `glmmTMB`), thus, in such cases, -#' the overdispersion test is based on [`simulate_residuals()`] (which is identical -#' to `check_overdispersion(simulate_residuals(model))`). +#' parameter. For Poisson, zero-inflated, or negative binomial mixed models +#' (fitted with `glmmTMB` or `lme4`), the overdispersion test is based on +#' [`simulate_residuals()`] (which is identical to +#' `check_overdispersion(simulate_residuals(model))`). #' #' @inheritSection check_zeroinflation Tests based on simulated residuals #' @@ -242,7 +242,8 @@ check_overdispersion.merMod <- function(x, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) # for certain distributions, simulated residuals are more accurate - use_simulated <- info$family == "genpois" || info$is_zero_inflated || info$is_bernoulli || info$is_binomial || (!info$is_count && !info$is_binomial) || info$is_negbin # nolint + # Note: now including Poisson models for mixed models (see #595, #643) + use_simulated <- info$family == "genpois" || info$is_zero_inflated || info$is_bernoulli || info$is_binomial || (!info$is_count && !info$is_binomial) || info$is_negbin || info$is_poisson # nolint if (use_simulated) { return(check_overdispersion(simulate_residuals(x, ...), object_name = obj_name, ...)) diff --git a/R/check_zeroinflation.R b/R/check_zeroinflation.R index ede10a717..efbec0814 100644 --- a/R/check_zeroinflation.R +++ b/R/check_zeroinflation.R @@ -25,9 +25,9 @@ #' negative binomial or zero-inflated models. #' #' In case of negative binomial models, models with zero-inflation component, -#' or hurdle models, the results from `check_zeroinflation()` are based on -#' [`simulate_residuals()`], i.e. `check_zeroinflation(simulate_residuals(model))` -#' is internally called if necessary. +#' hurdle models, or Poisson mixed models, the results from `check_zeroinflation()` +#' are based on [`simulate_residuals()`], i.e. +#' `check_zeroinflation(simulate_residuals(model))` is internally called if necessary. #' #' @section Tests based on simulated residuals: #' For certain models, resp. model from certain families, tests are based on @@ -88,9 +88,12 @@ check_zeroinflation.default <- function(x, tolerance = 0.05, ...) { # model classes not supported in DHARMa not_supported <- c("fixest", "glmx") - # for models with zero-inflation component or negative binomial families, - # we use simulate_residuals() - if (!inherits(x, not_supported) && (model_info$is_zero_inflated || model_info$is_negbin || model_info$family == "genpois")) { # nolint + # for models with zero-inflation component, negative binomial families, + # or Poisson mixed models, we use simulate_residuals() + # Note: now including Poisson mixed models (see #595, #643) + use_simulated <- model_info$is_zero_inflated || model_info$is_negbin || model_info$family == "genpois" || (model_info$is_mixed && model_info$is_poisson) # nolint + + if (!inherits(x, not_supported) && use_simulated) { if (missing(tolerance)) { tolerance <- 0.1 } From bce60d761ec67fb8a2cdea282dd086bbf339bb77 Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Tue, 7 Oct 2025 06:31:22 +0000 Subject: [PATCH 03/12] Add tests for autocorrelation with simulated residuals and update overdispersion test Co-authored-by: strengejacke <26301769+strengejacke@users.noreply.github.com> --- .../test-check_autocorrelation_simres.R | 47 +++++++++++++++++++ tests/testthat/test-check_overdispersion.R | 18 +++---- 2 files changed, 57 insertions(+), 8 deletions(-) create mode 100644 tests/testthat/test-check_autocorrelation_simres.R diff --git a/tests/testthat/test-check_autocorrelation_simres.R b/tests/testthat/test-check_autocorrelation_simres.R new file mode 100644 index 000000000..c01b3312e --- /dev/null +++ b/tests/testthat/test-check_autocorrelation_simres.R @@ -0,0 +1,47 @@ +test_that("check_autocorrelation works with simulated residuals", { + skip_if_not_installed("DHARMa") + skip_if_not_installed("glmmTMB") + skip_if_not(getRversion() >= "4.0.0") + + data(Salamanders, package = "glmmTMB") + + # Test with a simple Poisson GLM + m <- glm(count ~ spp + mined, family = poisson, data = Salamanders) + + # Simulate residuals + set.seed(123) + simres <- simulate_residuals(m) + + # Check autocorrelation + set.seed(123) + out <- check_autocorrelation(simres) + + # Should return a p-value + expect_type(out, "double") + expect_s3_class(out, "check_autocorrelation") + + # P-value should be between 0 and 1 + expect_true(out >= 0 && out <= 1) +}) + + +test_that("check_autocorrelation.DHARMa works", { + skip_if_not_installed("DHARMa") + + # Test that the DHARMa method works + data(mtcars) + m <- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) + + set.seed(123) + simres <- DHARMa::simulateResiduals(m, plot = FALSE) + + set.seed(123) + out <- check_autocorrelation(simres) + + # Should return a p-value + expect_type(out, "double") + expect_s3_class(out, "check_autocorrelation") + + # P-value should be between 0 and 1 + expect_true(out >= 0 && out <= 1) +}) diff --git a/tests/testthat/test-check_overdispersion.R b/tests/testthat/test-check_overdispersion.R index 1af6b1327..780031473 100644 --- a/tests/testthat/test-check_overdispersion.R +++ b/tests/testthat/test-check_overdispersion.R @@ -50,6 +50,7 @@ test_that("check_overdispersion, glmmTMB-poisson", { test_that("check_overdispersion, glmmTMB-poisson mixed", { skip_if_not_installed("glmmTMB") + skip_if_not_installed("DHARMa") skip_if_not(getRversion() >= "4.0.0") data(Salamanders, package = "glmmTMB") @@ -58,19 +59,20 @@ test_that("check_overdispersion, glmmTMB-poisson mixed", { family = poisson, data = Salamanders ) + # Poisson mixed models now use simulated residuals (see #595, #643) + set.seed(123) + out <- check_overdispersion(m2) expect_equal( - check_overdispersion(m2), + out, structure( list( - chisq_statistic = 1475.87512547128, - dispersion_ratio = 2.32421279601777, - residual_df = 635L, - p_value = 8.41489530177729e-69 + dispersion_ratio = 3.30, + p_value = 0 ), - class = c("check_overdisp", "see_check_overdisp"), - object_name = "m2" + class = c("check_overdisp", "see_check_overdisp") ), - tolerance = 1e-3 + tolerance = 0.1, + ignore_attr = TRUE ) }) From f7ea9ac42097d1b60a9dd35cf7fa9cfa37a67650 Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Tue, 7 Oct 2025 06:33:27 +0000 Subject: [PATCH 04/12] Add TODO comment for overdispersion plot consistency with simulated residuals Co-authored-by: strengejacke <26301769+strengejacke@users.noreply.github.com> --- R/check_overdispersion.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/check_overdispersion.R b/R/check_overdispersion.R index f271282c5..e27177d9a 100644 --- a/R/check_overdispersion.R +++ b/R/check_overdispersion.R @@ -99,6 +99,10 @@ plot.check_overdisp <- function(x, ...) { } } if (!is.null(model)) { + # TODO: For models that use simulated residuals in check_overdispersion() + # (e.g., Poisson mixed models, zero-inflated models), this still uses + # classical residuals for plotting. Consider using simulated residuals + # for consistency. See #595, #643, #654 x <- .model_diagnostic_overdispersion(model) class(x) <- c("see_check_overdisp", "data.frame") attr(x, "colors") <- list(...)$colors From 38eb303d51a4cdec7223ab7a9317b248d67c5141 Mon Sep 17 00:00:00 2001 From: Daniel Date: Wed, 8 Oct 2025 11:21:16 +0200 Subject: [PATCH 05/12] rd --- DESCRIPTION | 2 +- NAMESPACE | 2 + R/check_autocorrelation.R | 11 +++-- R/check_overdispersion.R | 48 +++++++++++++++---- R/check_zeroinflation.R | 23 ++++++--- man/binned_residuals.Rd | 2 +- man/check_autocorrelation.Rd | 11 ++++- man/check_collinearity.Rd | 2 +- man/check_convergence.Rd | 2 +- man/check_dag.Rd | 2 +- man/check_distribution.Rd | 4 +- man/check_group_variation.Rd | 2 +- man/check_heteroscedasticity.Rd | 2 +- man/check_homogeneity.Rd | 2 +- man/check_itemscale.Rd | 2 +- man/check_model.Rd | 2 +- man/check_multimodal.Rd | 2 +- man/check_normality.Rd | 2 +- man/check_outliers.Rd | 2 +- man/check_overdispersion.Rd | 10 ++-- man/check_predictions.Rd | 2 +- man/check_residuals.Rd | 2 +- man/check_singularity.Rd | 2 +- man/check_sphericity.Rd | 2 +- man/check_zeroinflation.Rd | 8 ++-- man/compare_performance.Rd | 2 +- man/icc.Rd | 2 +- man/item_omega.Rd | 2 +- man/looic.Rd | 2 +- man/model_performance.fa.Rd | 2 +- man/model_performance.lavaan.Rd | 2 +- man/model_performance.merMod.Rd | 2 +- man/model_performance.rma.Rd | 2 +- man/model_performance.stanreg.Rd | 2 +- man/performance_reliability.Rd | 2 +- man/performance_rmse.Rd | 2 +- man/performance_score.Rd | 2 +- man/r2.Rd | 2 +- man/r2_bayes.Rd | 2 +- man/r2_ferrari.Rd | 2 +- man/r2_loo.Rd | 2 +- man/r2_nakagawa.Rd | 2 +- man/simulate_residuals.Rd | 2 +- .../test-check_autocorrelation_simres.R | 22 ++++----- 44 files changed, 129 insertions(+), 80 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 62d4fd4d6..667d78382 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -159,7 +159,7 @@ Suggests: withr (>= 3.0.0) Encoding: UTF-8 Language: en-US -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Roxygen: list(markdown = TRUE) Config/testthat/edition: 3 Config/testthat/parallel: true diff --git a/NAMESPACE b/NAMESPACE index 2920eeb3d..e24788242 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,7 +28,9 @@ S3method(as.data.frame,r2_nakagawa) S3method(as.double,check_outliers) S3method(as.double,item_omega) S3method(as.double,performance_roc) +S3method(check_autocorrelation,DHARMa) S3method(check_autocorrelation,default) +S3method(check_autocorrelation,performance_simres) S3method(check_collinearity,BFBayesFactor) S3method(check_collinearity,MixMod) S3method(check_collinearity,afex_aov) diff --git a/R/check_autocorrelation.R b/R/check_autocorrelation.R index fe16e2334..96472e0f9 100644 --- a/R/check_autocorrelation.R +++ b/R/check_autocorrelation.R @@ -56,19 +56,18 @@ check_autocorrelation.default <- function(x, nsim = 1000, ...) { } -#' @rdname check_autocorrelation #' @export check_autocorrelation.performance_simres <- function(x, ...) { insight::check_if_installed("DHARMa") - + # Use DHARMa's temporal autocorrelation test # This requires the residuals to be ordered by time # DHARMa::testTemporalAutocorrelation expects a DHARMa object result <- DHARMa::testTemporalAutocorrelation(x, plot = FALSE, ...) - + # Extract p-value from the result p.val <- result$p.value - + class(p.val) <- c("check_autocorrelation", "see_check_autocorrelation", class(p.val)) p.val } @@ -81,7 +80,9 @@ check_autocorrelation.DHARMa <- check_autocorrelation.performance_simres #' @export plot.check_autocorrelation <- function(x, ...) { - insight::format_warning("There is currently no `plot()` method for `check_autocorrelation()`.") + insight::format_warning( + "There is currently no `plot()` method for `check_autocorrelation()`." + ) } diff --git a/R/check_overdispersion.R b/R/check_overdispersion.R index e27177d9a..37dda0c1d 100644 --- a/R/check_overdispersion.R +++ b/R/check_overdispersion.R @@ -78,7 +78,11 @@ check_overdispersion <- function(x, ...) { check_overdispersion.default <- function(x, ...) { .is_model_valid(x) insight::format_error( - paste0("`check_overdisperion()` not yet implemented for models of class `", class(x)[1], "`.") + paste0( + "`check_overdisperion()` not yet implemented for models of class `", + class(x)[1], + "`." + ) ) } @@ -122,7 +126,9 @@ print.check_overdisp <- function(x, digits = 3, ...) { } x$p_value <- pval <- round(x$p_value, digits = digits) - if (x$p_value < 0.001) x$p_value <- "< 0.001" + if (x$p_value < 0.001) { + x$p_value <- "< 0.001" + } maxlen <- max( nchar(x$dispersion_ratio), @@ -132,12 +138,27 @@ print.check_overdisp <- function(x, digits = 3, ...) { insight::print_color("# Overdispersion test\n\n", "blue") if (is.null(x$chisq_statistic)) { - cat(sprintf(" dispersion ratio = %s\n", format(x$dispersion_ratio, justify = "right", width = maxlen))) - cat(sprintf(" p-value = %s\n\n", format(x$p_value, justify = "right", width = maxlen))) + cat(sprintf( + " dispersion ratio = %s\n", + format(x$dispersion_ratio, justify = "right", width = maxlen) + )) + cat(sprintf( + " p-value = %s\n\n", + format(x$p_value, justify = "right", width = maxlen) + )) } else { - cat(sprintf(" dispersion ratio = %s\n", format(x$dispersion_ratio, justify = "right", width = maxlen))) - cat(sprintf(" Pearson's Chi-Squared = %s\n", format(x$chisq_statistic, justify = "right", width = maxlen))) - cat(sprintf(" p-value = %s\n\n", format(x$p_value, justify = "right", width = maxlen))) + cat(sprintf( + " dispersion ratio = %s\n", + format(x$dispersion_ratio, justify = "right", width = maxlen) + )) + cat(sprintf( + " Pearson's Chi-Squared = %s\n", + format(x$chisq_statistic, justify = "right", width = maxlen) + )) + cat(sprintf( + " p-value = %s\n\n", + format(x$p_value, justify = "right", width = maxlen) + )) } if (pval > 0.05) { @@ -161,7 +182,10 @@ check_overdispersion.glm <- function(x, verbose = TRUE, ...) { obj_name <- insight::safe_deparse_symbol(substitute(x)) # for certain distributions, simulated residuals are more accurate - use_simulated <- info$is_bernoulli || info$is_binomial || (!info$is_count && !info$is_binomial) || info$is_negbin + use_simulated <- info$is_bernoulli || + info$is_binomial || + (!info$is_count && !info$is_binomial) || + info$is_negbin # model classes not supported in DHARMa not_supported <- c("fixest", "glmx") @@ -247,7 +271,13 @@ check_overdispersion.merMod <- function(x, ...) { # for certain distributions, simulated residuals are more accurate # Note: now including Poisson models for mixed models (see #595, #643) - use_simulated <- info$family == "genpois" || info$is_zero_inflated || info$is_bernoulli || info$is_binomial || (!info$is_count && !info$is_binomial) || info$is_negbin || info$is_poisson # nolint + use_simulated <- info$family == "genpois" || + info$is_zero_inflated || + info$is_bernoulli || + info$is_binomial || + (!info$is_count && !info$is_binomial) || + info$is_negbin || + info$is_poisson if (use_simulated) { return(check_overdispersion(simulate_residuals(x, ...), object_name = obj_name, ...)) diff --git a/R/check_zeroinflation.R b/R/check_zeroinflation.R index efbec0814..4032e0242 100644 --- a/R/check_zeroinflation.R +++ b/R/check_zeroinflation.R @@ -91,8 +91,11 @@ check_zeroinflation.default <- function(x, tolerance = 0.05, ...) { # for models with zero-inflation component, negative binomial families, # or Poisson mixed models, we use simulate_residuals() # Note: now including Poisson mixed models (see #595, #643) - use_simulated <- model_info$is_zero_inflated || model_info$is_negbin || model_info$family == "genpois" || (model_info$is_mixed && model_info$is_poisson) # nolint - + use_simulated <- model_info$is_zero_inflated || + model_info$is_negbin || + model_info$family == "genpois" || + (model_info$is_mixed && model_info$is_poisson) + if (!inherits(x, not_supported) && use_simulated) { if (missing(tolerance)) { tolerance <- 0.1 @@ -120,17 +123,23 @@ check_zeroinflation.default <- function(x, tolerance = 0.05, ...) { #' @rdname check_zeroinflation #' @export -check_zeroinflation.performance_simres <- function(x, - tolerance = 0.1, - alternative = "two.sided", - ...) { +check_zeroinflation.performance_simres <- function( + x, + tolerance = 0.1, + alternative = "two.sided", + ... +) { alternative <- insight::validate_argument( alternative, c("two.sided", "less", "greater") ) # compute test results - result <- .simres_statistics(x, statistic_fun = function(i) sum(i == 0), alternative = alternative) + result <- .simres_statistics( + x, + statistic_fun = function(i) sum(i == 0), + alternative = alternative + ) structure( class = "check_zi", diff --git a/man/binned_residuals.Rd b/man/binned_residuals.Rd index 5c9f59cb7..e1c438b5c 100644 --- a/man/binned_residuals.Rd +++ b/man/binned_residuals.Rd @@ -93,7 +93,7 @@ result # look at the data frame as.data.frame(result) -\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) withAutoprint(\{ # examplesIf} \donttest{ # plot plot(result, show_dots = TRUE) diff --git a/man/check_autocorrelation.Rd b/man/check_autocorrelation.Rd index ce1cba6e4..7ba5e2805 100644 --- a/man/check_autocorrelation.Rd +++ b/man/check_autocorrelation.Rd @@ -10,9 +10,11 @@ check_autocorrelation(x, ...) \method{check_autocorrelation}{default}(x, nsim = 1000, ...) } \arguments{ -\item{x}{A model object.} +\item{x}{A model object, or an object returned by \code{simulate_residuals()}.} -\item{...}{Currently not used.} +\item{...}{Currently not used for models. For simulated residuals, arguments are +passed to \code{DHARMa::testTemporalAutocorrelation()}, which can include \code{time} (a +vector with time values) to specify the temporal order of the data.} \item{nsim}{Number of simulations for the Durbin-Watson-Test.} } @@ -29,6 +31,11 @@ Performs a Durbin-Watson-Test to check for autocorrelated residuals. In case of autocorrelation, robust standard errors return more accurate results for the estimates, or maybe a mixed model with error term for the cluster groups should be used. + +For simulated residuals (from \code{simulate_residuals()}), the function uses +\code{DHARMa::testTemporalAutocorrelation()} to check for temporal autocorrelation. +This requires the data to be ordered by time. If the data are not ordered by +time, you can provide a \code{time} argument to specify the temporal order. } \examples{ m <- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) diff --git a/man/check_collinearity.Rd b/man/check_collinearity.Rd index 7c86ce753..d8591fd9c 100644 --- a/man/check_collinearity.Rd +++ b/man/check_collinearity.Rd @@ -140,7 +140,7 @@ increasing lack of identifiability. The \emph{VIF proportion} column equals the m <- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) check_collinearity(m) -\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) withAutoprint(\{ # examplesIf} # plot results x <- check_collinearity(m) plot(x) diff --git a/man/check_convergence.Rd b/man/check_convergence.Rd index 12c181a14..22ac325b2 100644 --- a/man/check_convergence.Rd +++ b/man/check_convergence.Rd @@ -63,7 +63,7 @@ or not. } \examples{ -\dontshow{if (require("lme4") && require("glmmTMB")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lme4") && require("glmmTMB")) withAutoprint(\{ # examplesIf} data(cbpp, package = "lme4") set.seed(1) cbpp$x <- rnorm(nrow(cbpp)) diff --git a/man/check_dag.Rd b/man/check_dag.Rd index d6dbfb34b..5e3473a8c 100644 --- a/man/check_dag.Rd +++ b/man/check_dag.Rd @@ -146,7 +146,7 @@ adjustments or over-adjustment. } \examples{ -\dontshow{if (all(insight::check_if_installed(c("ggdag", "dagitty", "see"), quietly = TRUE))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (all(insight::check_if_installed(c("ggdag", "dagitty", "see"), quietly = TRUE))) withAutoprint(\{ # examplesIf} # no adjustment needed check_dag( y ~ x + b, diff --git a/man/check_distribution.Rd b/man/check_distribution.Rd index 3870cad37..ade233871 100644 --- a/man/check_distribution.Rd +++ b/man/check_distribution.Rd @@ -45,12 +45,12 @@ implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \examples{ -\dontshow{if (all(insight::check_if_installed(c("lme4", "parameters", "randomForest"), quietly = TRUE))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (all(insight::check_if_installed(c("lme4", "parameters", "randomForest"), quietly = TRUE))) withAutoprint(\{ # examplesIf} data(sleepstudy, package = "lme4") model <<- lme4::lmer(Reaction ~ Days + (Days | Subject), sleepstudy) check_distribution(model) \dontshow{\}) # examplesIf} -\dontshow{if (all(insight::check_if_installed(c("see", "patchwork", "randomForest"), quietly = TRUE))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (all(insight::check_if_installed(c("see", "patchwork", "randomForest"), quietly = TRUE))) withAutoprint(\{ # examplesIf} plot(check_distribution(model)) \dontshow{\}) # examplesIf} } diff --git a/man/check_group_variation.Rd b/man/check_group_variation.Rd index cf9000dc0..959e90bea 100644 --- a/man/check_group_variation.Rd +++ b/man/check_group_variation.Rd @@ -157,7 +157,7 @@ result summary(result) -\dontshow{if (insight::check_if_installed("lme4", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (insight::check_if_installed("lme4", quietly = TRUE)) withAutoprint(\{ # examplesIf} data(sleepstudy, package = "lme4") check_group_variation(sleepstudy, select = "Days", by = "Subject") diff --git a/man/check_heteroscedasticity.Rd b/man/check_heteroscedasticity.Rd index 7fc16c9aa..5b21d78d7 100644 --- a/man/check_heteroscedasticity.Rd +++ b/man/check_heteroscedasticity.Rd @@ -36,7 +36,7 @@ m <<- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) check_heteroscedasticity(m) # plot results -\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) withAutoprint(\{ # examplesIf} x <- check_heteroscedasticity(m) plot(x) \dontshow{\}) # examplesIf} diff --git a/man/check_homogeneity.Rd b/man/check_homogeneity.Rd index 1bdfc45c6..e7f39982f 100644 --- a/man/check_homogeneity.Rd +++ b/man/check_homogeneity.Rd @@ -39,7 +39,7 @@ model <<- lm(len ~ supp + dose, data = ToothGrowth) check_homogeneity(model) # plot results -\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) withAutoprint(\{ # examplesIf} result <- check_homogeneity(model) plot(result) \dontshow{\}) # examplesIf} diff --git a/man/check_itemscale.Rd b/man/check_itemscale.Rd index b0421448d..1bb68b73f 100644 --- a/man/check_itemscale.Rd +++ b/man/check_itemscale.Rd @@ -54,7 +54,7 @@ acceptability. Satisfactory range lies between 0.2 and 0.4. See also } } \examples{ -\dontshow{if (require("parameters") && require("psych")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("parameters") && require("psych")) withAutoprint(\{ # examplesIf} # data generation from '?prcomp', slightly modified C <- chol(S <- toeplitz(0.9^(0:15))) set.seed(17) diff --git a/man/check_model.Rd b/man/check_model.Rd index 73d478c2c..4d858f14a 100644 --- a/man/check_model.Rd +++ b/man/check_model.Rd @@ -250,7 +250,7 @@ get hints about possible problems. } \examples{ -\dontshow{if (require("lme4")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lme4")) withAutoprint(\{ # examplesIf} \donttest{ m <- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) check_model(m) diff --git a/man/check_multimodal.Rd b/man/check_multimodal.Rd index 1fc7003cb..491ea34b3 100644 --- a/man/check_multimodal.Rd +++ b/man/check_multimodal.Rd @@ -19,7 +19,7 @@ it always returns a significant result (suggesting that the distribution is multimodal). A better method might be needed here. } \examples{ -\dontshow{if (require("multimode") && require("mclust")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("multimode") && require("mclust")) withAutoprint(\{ # examplesIf} \donttest{ # Univariate x <- rnorm(1000) diff --git a/man/check_normality.Rd b/man/check_normality.Rd index d875bffea..b75ce0340 100644 --- a/man/check_normality.Rd +++ b/man/check_normality.Rd @@ -43,7 +43,7 @@ standardized residuals, are used for the test. There is also a implemented in the \href{https://easystats.github.io/see/}{\strong{see}-package}. } \examples{ -\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) withAutoprint(\{ # examplesIf} m <<- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) check_normality(m) diff --git a/man/check_outliers.Rd b/man/check_outliers.Rd index 762144b13..db5f0a377 100644 --- a/man/check_outliers.Rd +++ b/man/check_outliers.Rd @@ -336,7 +336,7 @@ filtered_data <- data[outliers_info$Outlier < 0.1, ] group_iris <- datawizard::data_group(iris, "Species") check_outliers(group_iris) # nolint start -\dontshow{if (all(insight::check_if_installed(c("bigutilsr", "MASS", "ICSOutlier", "ICS", "dbscan", "loo", "see"), quietly = TRUE))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (all(insight::check_if_installed(c("bigutilsr", "MASS", "ICSOutlier", "ICS", "dbscan", "loo", "see"), quietly = TRUE))) withAutoprint(\{ # examplesIf} # nolint end \donttest{ # You can also run all the methods diff --git a/man/check_overdispersion.Rd b/man/check_overdispersion.Rd index 82f94712f..cdb391ebb 100644 --- a/man/check_overdispersion.Rd +++ b/man/check_overdispersion.Rd @@ -64,10 +64,10 @@ is based on the code in the \href{http://bbolker.github.io/mixedmodels-misc/glmmFAQ.html}{GLMM FAQ}, section \emph{How can I deal with overdispersion in GLMMs?}. Note that this function only returns an \emph{approximate} estimate of an overdispersion -parameter. Using this approach would be inaccurate for zero-inflated or -negative binomial mixed models (fitted with \code{glmmTMB}), thus, in such cases, -the overdispersion test is based on \code{\link[=simulate_residuals]{simulate_residuals()}} (which is identical -to \code{check_overdispersion(simulate_residuals(model))}). +parameter. For Poisson, zero-inflated, or negative binomial mixed models +(fitted with \code{glmmTMB} or \code{lme4}), the overdispersion test is based on +\code{\link[=simulate_residuals]{simulate_residuals()}} (which is identical to +\code{check_overdispersion(simulate_residuals(model))}). } \section{How to fix Overdispersion}{ @@ -96,7 +96,7 @@ accurate results. } \examples{ -\dontshow{if (getRversion() >= "4.0.0" && require("glmmTMB")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (getRversion() >= "4.0.0" && require("glmmTMB")) withAutoprint(\{ # examplesIf} data(Salamanders, package = "glmmTMB") m <- glm(count ~ spp + mined, family = poisson, data = Salamanders) check_overdispersion(m) diff --git a/man/check_predictions.Rd b/man/check_predictions.Rd index 8c88e2bd9..cc44198a5 100644 --- a/man/check_predictions.Rd +++ b/man/check_predictions.Rd @@ -86,7 +86,7 @@ If \code{check_predictions()} doesn't work as expected, try setting \code{verbos to get hints about possible problems. } \examples{ -\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (insight::check_if_installed("see", minimum_version = "0.9.1", quietly = TRUE)) withAutoprint(\{ # examplesIf} # linear model model <- lm(mpg ~ disp, data = mtcars) check_predictions(model) diff --git a/man/check_residuals.Rd b/man/check_residuals.Rd index c7d8732ca..5993cb892 100644 --- a/man/check_residuals.Rd +++ b/man/check_residuals.Rd @@ -73,7 +73,7 @@ accurate results. } \examples{ -\dontshow{if (require("DHARMa")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("DHARMa")) withAutoprint(\{ # examplesIf} dat <- DHARMa::createData(sampleSize = 100, overdispersion = 0.5, family = poisson()) m <- glm(observedResponse ~ Environment1, family = poisson(), data = dat) res <- simulate_residuals(m) diff --git a/man/check_singularity.Rd b/man/check_singularity.Rd index 17c03f20c..d609492ed 100644 --- a/man/check_singularity.Rd +++ b/man/check_singularity.Rd @@ -81,7 +81,7 @@ question of whether we can assume that the numerical optimization has worked correctly or not. } \examples{ -\dontshow{if (require("lme4") && require("glmmTMB")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lme4") && require("glmmTMB")) withAutoprint(\{ # examplesIf} data(sleepstudy, package = "lme4") set.seed(123) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) diff --git a/man/check_sphericity.Rd b/man/check_sphericity.Rd index 6aaa53b3b..04244e820 100644 --- a/man/check_sphericity.Rd +++ b/man/check_sphericity.Rd @@ -20,7 +20,7 @@ Check model for violation of sphericity. For \link[=check_factorstructure]{Bartl (used for correlation matrices and factor analyses), see \link{check_sphericity_bartlett}. } \examples{ -\dontshow{if (require("car") && require("carData")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("car") && require("carData")) withAutoprint(\{ # examplesIf} data(Soils, package = "carData") soils.mod <- lm( cbind(pH, N, Dens, P, Ca, Mg, K, Na, Conduc) ~ Block + Contour * Depth, diff --git a/man/check_zeroinflation.Rd b/man/check_zeroinflation.Rd index 7f00520d6..2604d6f63 100644 --- a/man/check_zeroinflation.Rd +++ b/man/check_zeroinflation.Rd @@ -43,9 +43,9 @@ zero-inflation in the data. In such cases, it is recommended to use negative binomial or zero-inflated models. In case of negative binomial models, models with zero-inflation component, -or hurdle models, the results from \code{check_zeroinflation()} are based on -\code{\link[=simulate_residuals]{simulate_residuals()}}, i.e. \code{check_zeroinflation(simulate_residuals(model))} -is internally called if necessary. +hurdle models, or Poisson mixed models, the results from \code{check_zeroinflation()} +are based on \code{\link[=simulate_residuals]{simulate_residuals()}}, i.e. +\code{check_zeroinflation(simulate_residuals(model))} is internally called if necessary. } \section{Tests based on simulated residuals}{ @@ -66,7 +66,7 @@ accurate results. } \examples{ -\dontshow{if (require("glmmTMB") && require("DHARMa")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("glmmTMB") && require("DHARMa")) withAutoprint(\{ # examplesIf} data(Salamanders, package = "glmmTMB") m <- glm(count ~ spp + mined, family = poisson, data = Salamanders) check_zeroinflation(m) diff --git a/man/compare_performance.Rd b/man/compare_performance.Rd index d6b17b9f1..14c0f4629 100644 --- a/man/compare_performance.Rd +++ b/man/compare_performance.Rd @@ -92,7 +92,7 @@ same (AIC/...) values as from the defaults in \code{AIC.merMod()}. There is also a \href{https://easystats.github.io/see/articles/performance.html}{\code{plot()}-method} implemented in the \href{https://easystats.github.io/see/}{\pkg{see}-package}. } \examples{ -\dontshow{if (require("lme4")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lme4")) withAutoprint(\{ # examplesIf} data(iris) lm1 <- lm(Sepal.Length ~ Species, data = iris) lm2 <- lm(Sepal.Length ~ Species + Petal.Length, data = iris) diff --git a/man/icc.Rd b/man/icc.Rd index 8b38ece25..dbc5887e5 100644 --- a/man/icc.Rd +++ b/man/icc.Rd @@ -243,7 +243,7 @@ r-squared values, which may not be meaningful. } \examples{ -\dontshow{if (require("lme4")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lme4")) withAutoprint(\{ # examplesIf} model <- lme4::lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris) icc(model) diff --git a/man/item_omega.Rd b/man/item_omega.Rd index f3291bf7e..52d69017f 100644 --- a/man/item_omega.Rd +++ b/man/item_omega.Rd @@ -76,7 +76,7 @@ to return the reliability coefficients as (named) numeric vector. Detailed information can be found in the docs of \code{?psych::omega}. } \examples{ -\dontshow{if (insight::check_if_installed("parameters", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (insight::check_if_installed("parameters", quietly = TRUE)) withAutoprint(\{ # examplesIf} data(mtcars) x <- mtcars[1:7] result <- item_omega(x, n = 2) diff --git a/man/looic.Rd b/man/looic.Rd index 7f985f4a2..a40424d55 100644 --- a/man/looic.Rd +++ b/man/looic.Rd @@ -21,7 +21,7 @@ regressions. For LOOIC and ELPD, smaller and larger values are respectively indicative of a better fit. } \examples{ -\dontshow{if (require("rstanarm")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("rstanarm")) withAutoprint(\{ # examplesIf} \donttest{ model <- suppressWarnings(rstanarm::stan_glm( mpg ~ wt + cyl, diff --git a/man/model_performance.fa.Rd b/man/model_performance.fa.Rd index e73c66927..03136c683 100644 --- a/man/model_performance.fa.Rd +++ b/man/model_performance.fa.Rd @@ -34,7 +34,7 @@ score adequacy. \code{R2} refers to the multiple R square of scores with factors while \code{Correlation} indicates the correlation of scores with factors. } \examples{ -\dontshow{if (all(insight::check_if_installed(c("psych", "GPArotation", "psychTools"), quietly = TRUE))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (all(insight::check_if_installed(c("psych", "GPArotation", "psychTools"), quietly = TRUE))) withAutoprint(\{ # examplesIf} out <- psych::fa(psychTools::bfi[, 1:25], 5) model_performance(out) diff --git a/man/model_performance.lavaan.Rd b/man/model_performance.lavaan.Rd index b65e9d0f0..96ee5f64f 100644 --- a/man/model_performance.lavaan.Rd +++ b/man/model_performance.lavaan.Rd @@ -77,7 +77,7 @@ and the \strong{SRMR}. } } \examples{ -\dontshow{if (require("lavaan")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lavaan")) withAutoprint(\{ # examplesIf} # Confirmatory Factor Analysis (CFA) --------- data(HolzingerSwineford1939, package = "lavaan") structure <- " visual =~ x1 + x2 + x3 diff --git a/man/model_performance.merMod.Rd b/man/model_performance.merMod.Rd index 2f02ea179..4cb7133cf 100644 --- a/man/model_performance.merMod.Rd +++ b/man/model_performance.merMod.Rd @@ -59,7 +59,7 @@ on returned indices. } } \examples{ -\dontshow{if (require("lme4")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lme4")) withAutoprint(\{ # examplesIf} model <- lme4::lmer(Petal.Length ~ Sepal.Length + (1 | Species), data = iris) model_performance(model) \dontshow{\}) # examplesIf} diff --git a/man/model_performance.rma.Rd b/man/model_performance.rma.Rd index 69747fd6d..88891baab 100644 --- a/man/model_performance.rma.Rd +++ b/man/model_performance.rma.Rd @@ -66,7 +66,7 @@ See the documentation for \code{?metafor::fitstats}. } } \examples{ -\dontshow{if (require("metafor") && require("metadat")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("metafor") && require("metadat")) withAutoprint(\{ # examplesIf} data(dat.bcg, package = "metadat") dat <- metafor::escalc( measure = "RR", diff --git a/man/model_performance.stanreg.Rd b/man/model_performance.stanreg.Rd index 622c5b18a..237281ea3 100644 --- a/man/model_performance.stanreg.Rd +++ b/man/model_performance.stanreg.Rd @@ -60,7 +60,7 @@ values mean better fit. See \code{?loo::waic}. } } \examples{ -\dontshow{if (require("rstanarm") && require("rstantools")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("rstanarm") && require("rstantools")) withAutoprint(\{ # examplesIf} \donttest{ model <- suppressWarnings(rstanarm::stan_glm( mpg ~ wt + cyl, diff --git a/man/performance_reliability.Rd b/man/performance_reliability.Rd index a66c43ac5..98da41ecd 100644 --- a/man/performance_reliability.Rd +++ b/man/performance_reliability.Rd @@ -98,7 +98,7 @@ the meta-reliability - depends on the number of groups). } } \examples{ -\dontshow{if (all(insight::check_if_installed(c("lme4", "glmmTMB"), quietly = TRUE))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (all(insight::check_if_installed(c("lme4", "glmmTMB"), quietly = TRUE))) withAutoprint(\{ # examplesIf} url <- "https://raw.githubusercontent.com/easystats/circus/refs/heads/main/data/illusiongame.csv" df <- read.csv(url) diff --git a/man/performance_rmse.Rd b/man/performance_rmse.Rd index 124570c29..edd0d9f91 100644 --- a/man/performance_rmse.Rd +++ b/man/performance_rmse.Rd @@ -73,7 +73,7 @@ range of the response variable. Hence, lower values indicate less residual variance. } \examples{ -\dontshow{if (require("nlme")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("nlme")) withAutoprint(\{ # examplesIf} data(Orthodont, package = "nlme") m <- nlme::lme(distance ~ age, data = Orthodont) diff --git a/man/performance_score.Rd b/man/performance_score.Rd index 21e72ca24..79de13ed6 100644 --- a/man/performance_score.Rd +++ b/man/performance_score.Rd @@ -38,7 +38,7 @@ Code is partially based on \href{https://drizopoulos.github.io/GLMMadaptive/reference/scoring_rules.html}{GLMMadaptive::scoring_rules()}. } \examples{ -\dontshow{if (require("glmmTMB")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("glmmTMB")) withAutoprint(\{ # examplesIf} ## Dobson (1990) Page 93: Randomized Controlled Trial : counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12) outcome <- gl(3, 1, 9) diff --git a/man/r2.Rd b/man/r2.Rd index a8d514908..0a17bf9bf 100644 --- a/man/r2.Rd +++ b/man/r2.Rd @@ -61,7 +61,7 @@ to return a "generic" r-quared value, calculated as following: \code{1-sum((y-y_hat)^2)/sum((y-y_bar)^2)} } \examples{ -\dontshow{if (require("lme4")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lme4")) withAutoprint(\{ # examplesIf} # Pseudo r-quared for GLM model <- glm(vs ~ wt + mpg, data = mtcars, family = "binomial") r2(model) diff --git a/man/r2_bayes.Rd b/man/r2_bayes.Rd index 05280c992..0476fcd51 100644 --- a/man/r2_bayes.Rd +++ b/man/r2_bayes.Rd @@ -69,7 +69,7 @@ that the random effects are integrated out, but are "ignored". posterior sample of Bayesian R2 values. } \examples{ -\dontshow{if (require("rstanarm") && require("rstantools") && require("brms") && require("RcppEigen")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("rstanarm") && require("rstantools") && require("brms") && require("RcppEigen")) withAutoprint(\{ # examplesIf} library(performance) \donttest{ model <- suppressWarnings(rstanarm::stan_glm( diff --git a/man/r2_ferrari.Rd b/man/r2_ferrari.Rd index 78635539b..cf273769c 100644 --- a/man/r2_ferrari.Rd +++ b/man/r2_ferrari.Rd @@ -26,7 +26,7 @@ Calculates Ferrari's and Cribari-Neto's pseudo R2 (for beta-regression models). } \examples{ -\dontshow{if (require("betareg")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("betareg")) withAutoprint(\{ # examplesIf} data("GasolineYield", package = "betareg") model <- betareg::betareg(yield ~ batch + temp, data = GasolineYield) r2_ferrari(model) diff --git a/man/r2_loo.Rd b/man/r2_loo.Rd index e6592e08c..6697ea7c3 100644 --- a/man/r2_loo.Rd +++ b/man/r2_loo.Rd @@ -52,7 +52,7 @@ Mixed models are not currently fully supported. returns a posterior sample of LOO-adjusted Bayesian R2 values. } \examples{ -\dontshow{if (require("rstanarm") && require("rstantools")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("rstanarm") && require("rstantools")) withAutoprint(\{ # examplesIf} model <- suppressWarnings(rstanarm::stan_glm( mpg ~ wt + cyl, data = mtcars, diff --git a/man/r2_nakagawa.Rd b/man/r2_nakagawa.Rd index 75f2de3d0..a53075719 100644 --- a/man/r2_nakagawa.Rd +++ b/man/r2_nakagawa.Rd @@ -142,7 +142,7 @@ r-squared values, which may not be meaningful. } \examples{ -\dontshow{if (require("lme4")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("lme4")) withAutoprint(\{ # examplesIf} model <- lme4::lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris) r2_nakagawa(model) r2_nakagawa(model, by_group = TRUE) diff --git a/man/simulate_residuals.Rd b/man/simulate_residuals.Rd index 493461cda..19a88cbf0 100644 --- a/man/simulate_residuals.Rd +++ b/man/simulate_residuals.Rd @@ -62,7 +62,7 @@ accurate results. } \examples{ -\dontshow{if (require("DHARMa")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (require("DHARMa")) withAutoprint(\{ # examplesIf} m <- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) simulate_residuals(m) diff --git a/tests/testthat/test-check_autocorrelation_simres.R b/tests/testthat/test-check_autocorrelation_simres.R index c01b3312e..8a1bef33a 100644 --- a/tests/testthat/test-check_autocorrelation_simres.R +++ b/tests/testthat/test-check_autocorrelation_simres.R @@ -2,24 +2,24 @@ test_that("check_autocorrelation works with simulated residuals", { skip_if_not_installed("DHARMa") skip_if_not_installed("glmmTMB") skip_if_not(getRversion() >= "4.0.0") - + data(Salamanders, package = "glmmTMB") - + # Test with a simple Poisson GLM m <- glm(count ~ spp + mined, family = poisson, data = Salamanders) - + # Simulate residuals set.seed(123) simres <- simulate_residuals(m) - + # Check autocorrelation set.seed(123) out <- check_autocorrelation(simres) - + # Should return a p-value expect_type(out, "double") expect_s3_class(out, "check_autocorrelation") - + # P-value should be between 0 and 1 expect_true(out >= 0 && out <= 1) }) @@ -27,21 +27,21 @@ test_that("check_autocorrelation works with simulated residuals", { test_that("check_autocorrelation.DHARMa works", { skip_if_not_installed("DHARMa") - + # Test that the DHARMa method works data(mtcars) m <- lm(mpg ~ wt + cyl + gear + disp, data = mtcars) - + set.seed(123) simres <- DHARMa::simulateResiduals(m, plot = FALSE) - + set.seed(123) out <- check_autocorrelation(simres) - + # Should return a p-value expect_type(out, "double") expect_s3_class(out, "check_autocorrelation") - + # P-value should be between 0 and 1 expect_true(out >= 0 && out <= 1) }) From 5d1b44645340e59bf3bd27cce299173eaa988fc7 Mon Sep 17 00:00:00 2001 From: Daniel Date: Wed, 8 Oct 2025 11:23:37 +0200 Subject: [PATCH 06/12] news, desc --- DESCRIPTION | 2 +- NEWS.md | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 667d78382..5f39651ce 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: performance Title: Assessment of Regression Models Performance -Version: 0.15.2 +Version: 0.15.2.1 Authors@R: c(person(given = "Daniel", family = "Lüdecke", diff --git a/NEWS.md b/NEWS.md index 6814f64bc..4d7db93b8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,8 @@ +# performance (devel) + +* `check_autocorrelation()` gets methods for `DHARMa` objects and objects from + `simulate_residuals()`. + # performance 0.15.2 ## Bug fixes From 6ddbaaa9b5edea159014704d694c624aec2b830b Mon Sep 17 00:00:00 2001 From: Daniel Date: Wed, 8 Oct 2025 11:36:01 +0200 Subject: [PATCH 07/12] air styler --- R/binned_residuals.R | 46 +- R/check_clusterstructure.R | 24 +- R/check_collinearity.R | 110 +++-- R/check_dag.R | 168 ++++++-- R/check_distribution.R | 25 +- R/check_factorstructure.R | 9 +- R/check_group_variation.R | 48 ++- R/check_heteroscedasticity.R | 11 +- R/check_htest.R | 78 +++- R/check_itemscale.R | 13 +- R/check_model.R | 258 +++++++---- R/check_multimodal.R | 17 +- R/check_normality.R | 45 +- R/check_outliers.R | 766 +++++++++++++++++++++------------ R/model_performance.R | 5 +- R/model_performance.bayesian.R | 41 +- R/model_performance.rma.R | 8 +- R/model_performance_default.R | 8 +- R/performance_accuracy.R | 98 +++-- R/r2_nakagawa.R | 70 ++- man/check_distribution.Rd | 6 +- man/check_outliers.Rd | 8 +- 22 files changed, 1239 insertions(+), 623 deletions(-) diff --git a/R/binned_residuals.R b/R/binned_residuals.R index a6802ca37..afda1643b 100644 --- a/R/binned_residuals.R +++ b/R/binned_residuals.R @@ -75,16 +75,18 @@ #' } #' #' @export -binned_residuals <- function(model, - term = NULL, - n_bins = NULL, - show_dots = NULL, - ci = 0.95, - ci_type = "exact", - residuals = "deviance", - iterations = 1000, - verbose = TRUE, - ...) { +binned_residuals <- function( + model, + term = NULL, + n_bins = NULL, + show_dots = NULL, + ci = 0.95, + ci_type = "exact", + residuals = "deviance", + iterations = 1000, + verbose = TRUE, + ... +) { ci_type <- insight::validate_argument( ci_type, c("exact", "gaussian", "boot") @@ -98,7 +100,9 @@ binned_residuals <- function(model, if (isFALSE(insight::model_info(model)$is_bernoulli)) { ci_type <- "gaussian" if (verbose) { - insight::format_alert("Using `ci_type = \"gaussian\"` because model is not bernoulli.") + insight::format_alert( + "Using `ci_type = \"gaussian\"` because model is not bernoulli." + ) } } @@ -121,7 +125,8 @@ binned_residuals <- function(model, y0 <- .recode_to_zero(insight::get_response(model, verbose = FALSE)) # calculate residuals - y <- switch(residuals, + y <- switch( + residuals, response = y0 - fitted_values, pearson = .safe((y0 - fitted_values) / sqrt(fitted_values * (1 - fitted_values))), deviance = .safe(stats::residuals(model, type = "deviance")) @@ -129,10 +134,14 @@ binned_residuals <- function(model, # make sure we really have residuals if (is.null(y)) { - insight::format_error("Could not calculate residuals. Try using `residuals = \"response\"`.") + insight::format_error( + "Could not calculate residuals. Try using `residuals = \"response\"`." + ) } - if (is.null(n_bins)) n_bins <- round(sqrt(length(pred))) + if (is.null(n_bins)) { + n_bins <- round(sqrt(length(pred))) + } breaks.index <- floor(length(pred) * (1:(n_bins - 1)) / n_bins) breaks <- unique(c(-Inf, sort(pred)[breaks.index], Inf)) @@ -151,8 +160,13 @@ binned_residuals <- function(model, if (n == 0) { conf_int <- stats::setNames(c(NA, NA), c("CI_low", "CI_high")) } else { - conf_int <- switch(ci_type, - gaussian = stats::qnorm(c((1 - ci) / 2, (1 + ci) / 2), mean = ybar, sd = sdev / sqrt(n)), + conf_int <- switch( + ci_type, + gaussian = stats::qnorm( + c((1 - ci) / 2, (1 + ci) / 2), + mean = ybar, + sd = sdev / sqrt(n) + ), exact = { out <- stats::binom.test(sum(y0[items]), n)$conf.int # center CIs around point estimate diff --git a/R/check_clusterstructure.R b/R/check_clusterstructure.R index fd275cf5d..380dd96dc 100644 --- a/R/check_clusterstructure.R +++ b/R/check_clusterstructure.R @@ -37,10 +37,7 @@ #' assessment of (cluster) tendency. In Proceedings of the 2002 International #' Joint Conference on Neural Networks. IJCNN02 (3), 2225-2230. IEEE. #' @export -check_clusterstructure <- function(x, - standardize = TRUE, - distance = "euclidean", - ...) { +check_clusterstructure <- function(x, standardize = TRUE, distance = "euclidean", ...) { if (standardize) { x <- as.data.frame(scale(x)) } @@ -64,13 +61,22 @@ check_clusterstructure <- function(x, out <- list( H = H, - dissimilarity_matrix = .clusterstructure_dm(x, distance = distance, method = "ward.D2") + dissimilarity_matrix = .clusterstructure_dm( + x, + distance = distance, + method = "ward.D2" + ) ) attr(out, "text") <- res_text attr(out, "color") <- color attr(out, "title") <- "Clustering tendency" - class(out) <- c("see_check_clusterstructure", "check_clusterstructure", "easystats_check", class(out)) + class(out) <- c( + "see_check_clusterstructure", + "check_clusterstructure", + "easystats_check", + class(out) + ) out } @@ -80,8 +86,10 @@ plot.check_clusterstructure <- function(x, ...) { # Can be reimplemented with ggplot in see stats::heatmap( x$dissimilarity_matrix, - Rowv = NA, Colv = NA, - labRow = FALSE, labCol = FALSE, + Rowv = NA, + Colv = NA, + labRow = FALSE, + labCol = FALSE, col = grDevices::colorRampPalette(c("#2196F3", "#FAFAFA", "#E91E63"))(100) ) } diff --git a/R/check_collinearity.R b/R/check_collinearity.R index fae07d631..a31ebc0e0 100644 --- a/R/check_collinearity.R +++ b/R/check_collinearity.R @@ -313,11 +313,13 @@ check_collinearity.betamfx <- check_collinearity.logitor #' @rdname check_collinearity #' @export -check_collinearity.glmmTMB <- function(x, - component = "all", - ci = 0.95, - verbose = TRUE, - ...) { +check_collinearity.glmmTMB <- function( + x, + component = "all", + ci = 0.95, + verbose = TRUE, + ... +) { component <- insight::validate_argument( component, c("all", "conditional", "count", "zi", "zero_inflated") @@ -327,11 +329,13 @@ check_collinearity.glmmTMB <- function(x, #' @export -check_collinearity.MixMod <- function(x, - component = "all", - ci = 0.95, - verbose = TRUE, - ...) { +check_collinearity.MixMod <- function( + x, + component = "all", + ci = 0.95, + verbose = TRUE, + ... +) { component <- insight::validate_argument( component, c("all", "conditional", "count", "zi", "zero_inflated") @@ -341,11 +345,13 @@ check_collinearity.MixMod <- function(x, #' @export -check_collinearity.hurdle <- function(x, - component = "all", - ci = 0.95, - verbose = verbose, - ...) { +check_collinearity.hurdle <- function( + x, + component = "all", + ci = 0.95, + verbose = verbose, + ... +) { component <- insight::validate_argument( component, c("all", "conditional", "count", "zi", "zero_inflated") @@ -355,11 +361,13 @@ check_collinearity.hurdle <- function(x, #' @export -check_collinearity.zeroinfl <- function(x, - component = "all", - ci = 0.95, - verbose = verbose, - ...) { +check_collinearity.zeroinfl <- function( + x, + component = "all", + ci = 0.95, + verbose = verbose, + ... +) { component <- insight::validate_argument( component, c("all", "conditional", "count", "zi", "zero_inflated") @@ -369,11 +377,13 @@ check_collinearity.zeroinfl <- function(x, #' @export -check_collinearity.zerocount <- function(x, - component = "all", - ci = 0.95, - verbose = verbose, - ...) { +check_collinearity.zerocount <- function( + x, + component = "all", + ci = 0.95, + verbose = verbose, + ... +) { component <- insight::validate_argument( component, c("all", "conditional", "count", "zi", "zero_inflated") @@ -385,11 +395,17 @@ check_collinearity.zerocount <- function(x, # utilities --------------------------------- .check_collinearity_zi_model <- function(x, component, ci = 0.95, verbose = TRUE) { - if (component == "count") component <- "conditional" - if (component == "zi") component <- "zero_inflated" + if (component == "count") { + component <- "conditional" + } + if (component == "zi") { + component <- "zero_inflated" + } mi <- insight::model_info(x, verbose = FALSE) - if (!mi$is_zero_inflated) component <- "conditional" + if (!mi$is_zero_inflated) { + component <- "conditional" + } if (component == "all") { cond <- .check_collinearity(x, "conditional", ci = ci, verbose = verbose) @@ -439,7 +455,10 @@ check_collinearity.zerocount <- function(x, if (isTRUE(verbose)) { insight::format_alert( paste( - sprintf("Could not extract the variance-covariance matrix for the %s component of the model.", component), + sprintf( + "Could not extract the variance-covariance matrix for the %s component of the model.", + component + ), "Please try to run `vcov(model)`, which may help identifying the problem." ) ) @@ -453,13 +472,15 @@ check_collinearity.zerocount <- function(x, if (is.null(term_assign) || all(is.na(term_assign))) { if (verbose) { insight::format_alert( - sprintf("Could not extract model terms for the %s component of the model.", component) + sprintf( + "Could not extract model terms for the %s component of the model.", + component + ) ) } return(NULL) } - # we have rank-deficiency here. remove NA columns from assignment if (isTRUE(attributes(v)$rank_deficient) && !is.null(attributes(v)$na_columns_index)) { term_assign <- term_assign[-attributes(v)$na_columns_index] @@ -482,9 +503,11 @@ check_collinearity.zerocount <- function(x, # hurdle or zeroinfl model can have no zero-inflation formula, in which case # we have the same formula as for conditional formula part - if (inherits(x, c("hurdle", "zeroinfl", "zerocount")) && - component == "zero_inflated" && - is.null(f[["zero_inflated"]])) { + if ( + inherits(x, c("hurdle", "zeroinfl", "zerocount")) && + component == "zero_inflated" && + is.null(f[["zero_inflated"]]) + ) { f$zero_inflated <- f$conditional } @@ -503,7 +526,10 @@ check_collinearity.zerocount <- function(x, if (n.terms < 2) { if (isTRUE(verbose)) { insight::format_alert( - sprintf("Not enough model terms in the %s part of the model to check for multicollinearity.", component) + sprintf( + "Not enough model terms in the %s part of the model to check for multicollinearity.", + component + ) ) } return(NULL) @@ -639,17 +665,20 @@ check_collinearity.zerocount <- function(x, tryCatch( { if (inherits(x, c("hurdle", "zeroinfl", "zerocount"))) { - term_assign <- switch(component, + term_assign <- switch( + component, conditional = attr(insight::get_modelmatrix(x, model = "count"), "assign"), zero_inflated = attr(insight::get_modelmatrix(x, model = "zero"), "assign") ) } else if (inherits(x, "glmmTMB")) { - term_assign <- switch(component, + term_assign <- switch( + component, conditional = attr(insight::get_modelmatrix(x), "assign"), zero_inflated = .zi_term_assignment(x, component, verbose = verbose) ) } else if (inherits(x, "MixMod")) { - term_assign <- switch(component, + term_assign <- switch( + component, conditional = attr(insight::get_modelmatrix(x, type = "fixed"), "assign"), zero_inflated = attr(insight::get_modelmatrix(x, type = "zi_fixed"), "assign") ) @@ -692,7 +721,10 @@ check_collinearity.zerocount <- function(x, })) if (insight::is_gam_model(x)) { - model_params <- as.vector(unlist(insight::find_parameters(x)[c(component, "smooth_terms")])) + model_params <- as.vector(unlist(insight::find_parameters(x)[c( + component, + "smooth_terms" + )])) } else { model_params <- insight::find_parameters(x)[[component]] } diff --git a/R/check_dag.R b/R/check_dag.R index 123eab17f..1a49c8c0d 100644 --- a/R/check_dag.R +++ b/R/check_dag.R @@ -210,13 +210,15 @@ #' dag #' plot(dag) #' @export -check_dag <- function(..., - outcome = NULL, - exposure = NULL, - adjusted = NULL, - latent = NULL, - effect = "all", - coords = NULL) { +check_dag <- function( + ..., + outcome = NULL, + exposure = NULL, + adjusted = NULL, + latent = NULL, + effect = "all", + coords = NULL +) { insight::check_if_installed( c("ggdag", "dagitty"), reason = "to check correct adjustments for identifying causal effects." @@ -243,7 +245,9 @@ check_dag <- function(..., ) # if we have a model, we *always* overwrite adjusted if (!is.null(adjusted)) { - insight::format_alert("The `adjusted` argument will be overwritten by all independent variables from the model.") # nolint + insight::format_alert( + "The `adjusted` argument will be overwritten by all independent variables from the model." + ) # nolint } adjusted <- vars$conditional } @@ -279,12 +283,15 @@ check_dag <- function(..., coords <- .process_coords(coords) # convert to dag - dag_args <- c(formulas, list( - exposure = exposure, - outcome = outcome, - latent = latent, - coords = coords - )) + dag_args <- c( + formulas, + list( + exposure = exposure, + outcome = outcome, + latent = latent, + coords = coords + ) + ) dag <- do.call(ggdag::dagify, dag_args) # add adjustments @@ -315,7 +322,14 @@ check_dag <- function(..., adjustment_set <- unlist(dagitty::adjustmentSets(dag, effect = x), use.names = FALSE) adjustment_nodes <- unlist(dagitty::adjustedNodes(dag), use.names = FALSE) minimal_adjustments <- as.list(dagitty::adjustmentSets(dag, effect = x)) - collider <- adjustment_nodes[vapply(adjustment_nodes, ggdag::is_collider, logical(1), .dag = dag, downstream = FALSE)] # nolint + collider <- adjustment_nodes[vapply( + adjustment_nodes, + ggdag::is_collider, + logical(1), + .dag = dag, + downstream = FALSE + )] + if (length(collider)) { # if we *have* colliders, remove them from minimal adjustments minimal_adjustments <- lapply(minimal_adjustments, setdiff, y = collider) @@ -323,15 +337,19 @@ check_dag <- function(..., # if we don't have colliders, set to NULL collider <- NULL } + list( # no adjustment needed when # - required and current adjustment sets are NULL # - AND we have no collider in current adjustments - adjustment_not_needed = is.null(adjustment_set) && is.null(adjustment_nodes) && is.null(collider), + adjustment_not_needed = is.null(adjustment_set) && + is.null(adjustment_nodes) && + is.null(collider), # incorrect adjustment when # - required is NULL and current adjustment not NULL # - OR we have a collider in current adjustments - incorrectly_adjusted = (is.null(adjustment_set) && !is.null(adjustment_nodes)) || (!is.null(collider) && collider %in% adjustment_nodes), # nolint + incorrectly_adjusted = (is.null(adjustment_set) && !is.null(adjustment_nodes)) || + (!is.null(collider) && collider %in% adjustment_nodes), # nolint current_adjustments = adjustment_nodes, minimal_adjustments = minimal_adjustments, collider = collider @@ -359,10 +377,20 @@ check_dag <- function(..., .adjust_dag <- function(dag, adjusted) { for (i in adjusted) { # first option, we just have the variable name - dag <- gsub(paste0("\n", i, "\n"), paste0("\n", i, " [adjusted]\n"), dag, fixed = TRUE) + dag <- gsub( + paste0("\n", i, "\n"), + paste0("\n", i, " [adjusted]\n"), + dag, + fixed = TRUE + ) # second option, we have the variable name with a [pos] tag when the user # provided coords - dag <- gsub(paste0("\n", i, " [pos="), paste0("\n", i, " [adjusted,pos="), dag, fixed = TRUE) + dag <- gsub( + paste0("\n", i, " [pos="), + paste0("\n", i, " [adjusted,pos="), + dag, + fixed = TRUE + ) } dag } @@ -388,7 +416,13 @@ check_dag <- function(..., # # we have to check that it's not a data frame and that it is a list - # values like `ggdag::time_ordered_coords()` returns a function, not a list - if (!is.null(coords) && !is.data.frame(coords) && is.list(coords) && (length(coords) != 2 || !identical(names(coords), c("x", "y")))) { # nolint + if ( + !is.null(coords) && + !is.data.frame(coords) && + is.list(coords) && + (length(coords) != 2 || !identical(names(coords), c("x", "y"))) + ) { + # nolint # transform list into data frame, split x and y coordinates into columns coords <- datawizard::rownames_as_column( stats::setNames(as.data.frame(do.call(rbind, coords)), c("x", "y")), @@ -423,9 +457,12 @@ print.check_dag <- function(x, ...) { # model specification exposure_outcome_text <- paste0( - "\n- Outcome: ", attributes(x)$outcome, - "\n- Exposure", ifelse(length(attributes(x)$exposure) > 1, "s", ""), - ": ", datawizard::text_concatenate(attributes(x)$exposure) + "\n- Outcome: ", + attributes(x)$outcome, + "\n- Exposure", + ifelse(length(attributes(x)$exposure) > 1, "s", ""), + ": ", + datawizard::text_concatenate(attributes(x)$exposure) ) # add information on adjustments @@ -434,7 +471,8 @@ print.check_dag <- function(x, ...) { exposure_outcome_text, "\n- Adjustment", ifelse(length(attributes(x)$adjustment_sets) > 1, "s", ""), - ": ", datawizard::text_concatenate(attributes(x)$adjustment_sets) + ": ", + datawizard::text_concatenate(attributes(x)$adjustment_sets) ) } @@ -444,7 +482,8 @@ print.check_dag <- function(x, ...) { exposure_outcome_text, "\n- Collider", ifelse(length(collider) > 1, "s", ""), - ": ", insight::color_text(datawizard::text_concatenate(collider), "cyan") + ": ", + insight::color_text(datawizard::text_concatenate(collider), "cyan") ) } @@ -453,7 +492,12 @@ print.check_dag <- function(x, ...) { # minimal adjustment sets for direct and total effect identical? # Then print only once - if (identical(attributes(x)$check_direct$minimal_adjustments, attributes(x)$check_total$minimal_adjustments)) { + if ( + identical( + attributes(x)$check_direct$minimal_adjustments, + attributes(x)$check_total$minimal_adjustments + ) + ) { .print_dag_results(attributes(x)$check_direct, x, "direct and total", "all", collider) } else { for (i in c("direct", "total")) { @@ -471,9 +515,13 @@ print.check_dag <- function(x, ...) { # missing adjustements - minimal_adjustment can be a list of different # options for minimal adjustements, so we check here if any of the minimal # adjustments are currently sufficient - sufficient_adjustments <- vapply(out$minimal_adjustments, function(min_adj) { - !is.null(out$current_adjustments) && all(min_adj %in% out$current_adjustments) - }, logical(1)) + sufficient_adjustments <- vapply( + out$minimal_adjustments, + function(min_adj) { + !is.null(out$current_adjustments) && all(min_adj %in% out$current_adjustments) + }, + logical(1) + ) # build message with check results for effects ----------------------- @@ -481,7 +529,9 @@ print.check_dag <- function(x, ...) { # Scenario 1: no adjustment needed msg <- paste0( insight::color_text("Model is correctly specified.", "green"), - "\nNo adjustment needed to estimate the ", i, " effect of ", + "\nNo adjustment needed to estimate the ", + i, + " effect of ", datawizard::text_concatenate(attributes(x)$exposure, enclose = "`"), " on `", attributes(x)$outcome, @@ -491,7 +541,9 @@ print.check_dag <- function(x, ...) { # Scenario 2: adjusted for collider msg <- paste0( insight::color_text("Incorrectly adjusted!", "red"), - "\nYour model adjusts for a potential collider. To estimate the ", i, " effect, do ", + "\nYour model adjusts for a potential collider. To estimate the ", + i, + " effect, do ", insight::color_text("not", "italic"), " adjust for ", insight::color_text(datawizard::text_concatenate(collider, enclose = "`"), "cyan"), @@ -501,24 +553,33 @@ print.check_dag <- function(x, ...) { # Scenario 3: incorrectly adjusted, adjustments where none is allowed msg <- paste0( insight::color_text("Incorrectly adjusted!", "red"), - "\nTo estimate the ", i, " effect, do ", + "\nTo estimate the ", + i, + " effect, do ", insight::color_text("not", "italic"), " adjust for ", ifelse(length(out$current_adjustments) > 1, "some or all of ", ""), - insight::color_text(datawizard::text_concatenate(out$current_adjustments, enclose = "`"), "red"), + insight::color_text( + datawizard::text_concatenate(out$current_adjustments, enclose = "`"), + "red" + ), "." ) } else if (any(sufficient_adjustments)) { # Scenario 4: correct adjustment msg <- paste0( insight::color_text("Model is correctly specified.", "green"), - "\nAll minimal sufficient adjustments to estimate the ", i, " effect were done." + "\nAll minimal sufficient adjustments to estimate the ", + i, + " effect were done." ) } else { # Scenario 5: missing adjustments msg <- paste0( insight::color_text("Incorrectly adjusted!", "red"), - "\nTo estimate the ", i, " effect, ", + "\nTo estimate the ", + i, + " effect, ", insight::color_text("at least", "italic"), " adjust for " ) @@ -530,7 +591,10 @@ print.check_dag <- function(x, ...) { insight::color_text( paste( "-", - unlist(lapply(out$minimal_adjustments, paste, collapse = ", "), use.names = FALSE), + unlist( + lapply(out$minimal_adjustments, paste, collapse = ", "), + use.names = FALSE + ), collapse = "\n" ), "yellow" @@ -541,10 +605,13 @@ print.check_dag <- function(x, ...) { } else { msg <- paste0( msg, - insight::color_text(datawizard::text_concatenate( - unlist(out$minimal_adjustments, use.names = FALSE), - enclose = "`" - ), "yellow"), + insight::color_text( + datawizard::text_concatenate( + unlist(out$minimal_adjustments, use.names = FALSE), + enclose = "`" + ), + "yellow" + ), "." ) current_str <- " Currently" @@ -553,7 +620,9 @@ print.check_dag <- function(x, ...) { msg <- paste0(msg, current_str, ", the model does not adjust for any variables.") } else { msg <- paste0( - msg, current_str, ", the model only adjusts for ", + msg, + current_str, + ", the model only adjusts for ", datawizard::text_concatenate(out$current_adjustments, enclose = "`"), "." ) @@ -561,8 +630,12 @@ print.check_dag <- function(x, ...) { missing_vars <- setdiff(unlist(out$minimal_adjustments), out$current_adjustments) if (length(missing_vars) > 0) { msg <- paste0( - msg, " You possibly also need to adjust for ", - insight::color_text(datawizard::text_concatenate(missing_vars, enclose = "`"), "green"), + msg, + " You possibly also need to adjust for ", + insight::color_text( + datawizard::text_concatenate(missing_vars, enclose = "`"), + "green" + ), " to block biasing paths." ) } @@ -570,9 +643,12 @@ print.check_dag <- function(x, ...) { } if (effect %in% c("all", i)) { - cat(insight::print_color(insight::format_message( - paste0("Identification of ", i, " effects\n\n") - ), "blue")) + cat(insight::print_color( + insight::format_message( + paste0("Identification of ", i, " effects\n\n") + ), + "blue" + )) cat(msg) cat("\n\n") } diff --git a/R/check_distribution.R b/R/check_distribution.R index 9f2a08e9b..bc0ac0216 100644 --- a/R/check_distribution.R +++ b/R/check_distribution.R @@ -23,7 +23,7 @@ NULL #' @note This function is somewhat experimental and might be improved in future #' releases. The final decision on the model-family should also be based on #' theoretical aspects and other information about the data and the model. -#' \cr \cr +#' #' There is also a #' [`plot()`-method](https://easystats.github.io/see/articles/performance.html) #' implemented in the @@ -39,11 +39,11 @@ NULL #' `"inverse-gamma"`, `"lognormal"`, `"normal"`, `"negative binomial"`, #' `"negative binomial (zero-inflated)"`, `"pareto"`, `"poisson"`, #' `"poisson (zero-inflated)"`, `"tweedie"`, `"uniform"` and `"weibull"`. -#' \cr \cr +#' #' Note the similarity between certain distributions according to shape, skewness, #' etc. Thus, the predicted distribution may not be perfectly representing the #' distributional family of the underlying fitted model, or the response value. -#' \cr \cr +#' #' There is a `plot()` method, which shows the probabilities of all predicted #' distributions, however, only if the probability is greater than zero. #' @@ -76,8 +76,11 @@ check_distribution.default <- function(model) { } dat <- .extract_features(x, "residuals") - dist_residuals <- as.data.frame(t(stats::predict(classify_distribution, dat, type = "prob"))) - + dist_residuals <- as.data.frame(t(stats::predict( + classify_distribution, + dat, + type = "prob" + ))) # Extract features x <- datawizard::to_numeric( @@ -87,7 +90,11 @@ check_distribution.default <- function(model) { ) dat <- .extract_features(x, "response") - dist_response <- as.data.frame(t(stats::predict(classify_distribution, dat, type = "prob"))) + dist_response <- as.data.frame(t(stats::predict( + classify_distribution, + dat, + type = "prob" + ))) out <- data.frame( Distribution = rownames(dist_response), @@ -174,7 +181,11 @@ check_distribution.numeric <- function(model) { row.names = NULL ) - class(out) <- unique(c("check_distribution_numeric", "see_check_distribution_numeric", class(out))) + class(out) <- unique(c( + "check_distribution_numeric", + "see_check_distribution_numeric", + class(out) + )) attr(out, "data") <- model out diff --git a/R/check_factorstructure.R b/R/check_factorstructure.R index c7c323cbd..2f9fff578 100644 --- a/R/check_factorstructure.R +++ b/R/check_factorstructure.R @@ -78,7 +78,7 @@ #' #' - Bartlett, M. S. (1951). The effect of standardization on a Chi-square #' approximation in factor analysis. Biometrika, 38(3/4), 337-344. - +#' #' - Kaiser, H. F. (1970). A second generation little jiffy. #' Psychometrika, 35(4), 401-415. #' @@ -95,7 +95,12 @@ check_factorstructure <- function(x, n = NULL, ...) { kmo <- check_kmo(x, n, ...) sphericity <- check_sphericity_bartlett(x, n, ...) - res_text <- paste0("\n - Sphericity: ", attributes(sphericity)$text, "\n - KMO: ", attributes(kmo)$text) + res_text <- paste0( + "\n - Sphericity: ", + attributes(sphericity)$text, + "\n - KMO: ", + attributes(kmo)$text + ) if (attributes(kmo)$color == "red" || attributes(sphericity)$color == "red") { color <- "red" diff --git a/R/check_group_variation.R b/R/check_group_variation.R index 56105ce4d..ae6515c2a 100644 --- a/R/check_group_variation.R +++ b/R/check_group_variation.R @@ -149,10 +149,17 @@ check_group_variation.default <- function(x, ...) { by <- insight::find_random(x, split_nested = TRUE, flatten = TRUE) if (is.null(by)) { - insight::format_error("Model is no mixed model. Please provide a mixed model, or a data frame and arguments `select` and `by`.") + insight::format_error( + "Model is no mixed model. Please provide a mixed model, or a data frame and arguments `select` and `by`." + ) } my_data <- insight::get_data(x, source = "mf", verbose = FALSE) - select <- insight::find_predictors(x, effects = "fixed", component = "conditional", flatten = TRUE) + select <- insight::find_predictors( + x, + effects = "fixed", + component = "conditional", + flatten = TRUE + ) check_group_variation(my_data, select = select, by = by, ...) } @@ -160,14 +167,16 @@ check_group_variation.default <- function(x, ...) { #' @rdname check_group_variation #' @export -check_group_variation.data.frame <- function(x, - select = NULL, - by = NULL, - include_by = FALSE, - numeric_as_factor = FALSE, - tolerance_numeric = 1e-4, - tolerance_factor = "crossed", - ...) { +check_group_variation.data.frame <- function( + x, + select = NULL, + by = NULL, + include_by = FALSE, + numeric_as_factor = FALSE, + tolerance_numeric = 1e-4, + tolerance_factor = "crossed", + ... +) { if (inherits(select, "formula")) { select <- all.vars(select) } @@ -287,7 +296,13 @@ summary.check_group_variation <- function(object, flatten = FALSE, ...) { result <- split(object$Variable, object$Group) if (length(result) > 1L) { - txt <- paste0("- ", names(result), ": ", sapply(result, paste0, collapse = ", "), collapse = "\n") + txt <- paste0( + "- ", + names(result), + ": ", + sapply(result, paste0, collapse = ", "), + collapse = "\n" + ) } else { txt <- paste0("- ", paste0(result[[1]], collapse = ", ")) } @@ -360,7 +375,13 @@ summary.check_group_variation <- function(object, flatten = FALSE, ...) { } #' @keywords internals -.check_nested.default <- function(data, by, predictor, tolerance_factor = "crossed", ...) { +.check_nested.default <- function( + data, + by, + predictor, + tolerance_factor = "crossed", + ... +) { tolerance_factor <- insight::validate_argument( tolerance_factor, c("crossed", "balanced") @@ -381,7 +402,8 @@ summary.check_group_variation <- function(object, flatten = FALSE, ...) { f1 <- as.factor(variable) k <- nlevels(f1) sm <- methods::as( - methods::new("ngTMatrix", + methods::new( + "ngTMatrix", i = as.integer(group) - 1L, j = as.integer(f1) - 1L, Dim = c(nlevels(group), k) diff --git a/R/check_heteroscedasticity.R b/R/check_heteroscedasticity.R index 522143552..c5e78c109 100644 --- a/R/check_heteroscedasticity.R +++ b/R/check_heteroscedasticity.R @@ -52,7 +52,10 @@ check_heteroscedasticity.default <- function(x, ...) { if (!info$is_linear) { msg <- "This Breusch-Pagan Test currently only works Gaussian models." if (info$is_count) { - paste0(msg, " You may check your model for overdispersion or zero-inflation instead (see 'check_overdispersion()' and 'check_zeroinflation()').") + paste0( + msg, + " You may check your model for overdispersion or zero-inflation instead (see 'check_overdispersion()' and 'check_zeroinflation()')." + ) } insight::format_alert(msg) return(NULL) @@ -72,7 +75,11 @@ check_heteroscedasticity.default <- function(x, ...) { attr(p.val, "data") <- x attr(p.val, "object_name") <- insight::safe_deparse_symbol(substitute(x)) - class(p.val) <- unique(c("check_heteroscedasticity", "see_check_heteroscedasticity", class(p.val))) + class(p.val) <- unique(c( + "check_heteroscedasticity", + "see_check_heteroscedasticity", + class(p.val) + )) p.val } diff --git a/R/check_htest.R b/R/check_htest.R index 4dadf3a7a..60c176a1b 100644 --- a/R/check_htest.R +++ b/R/check_htest.R @@ -8,9 +8,10 @@ check_normality.htest <- function(x, ...) { } method <- x[["method"]] - - if (grepl("Welch", method, fixed = TRUE) || - grepl("F test to compare two variances", method, fixed = TRUE)) { + if ( + grepl("Welch", method, fixed = TRUE) || + grepl("F test to compare two variances", method, fixed = TRUE) + ) { # sanity check if (!is.numeric(model_data[[2]])) { insight::format_error( @@ -44,7 +45,13 @@ check_normality.htest <- function(x, ...) { m <- stats::lm(d ~ 1) out <- check_normality(m) - } else if (grepl("One-way analysis of means (not assuming equal variances)", method, fixed = TRUE)) { + } else if ( + grepl( + "One-way analysis of means (not assuming equal variances)", + method, + fixed = TRUE + ) + ) { model_data <- split(model_data, model_data[[2]]) outs <- lapply(model_data, function(d) { check_normality(stats::lm(d[[1]] ~ 1)) @@ -61,8 +68,10 @@ check_normality.htest <- function(x, ...) { out <- .MVN_hz(model_data)[["p value"]] class(out) <- c("check_normality", "see_check_normality", "numeric") attr(out, "type") <- "residuals" - } else if (grepl("Pearson's Chi-squared test", method, fixed = TRUE) || - grepl("Chi-squared test for given probabilities", method, fixed = TRUE)) { + } else if ( + grepl("Pearson's Chi-squared test", method, fixed = TRUE) || + grepl("Chi-squared test for given probabilities", method, fixed = TRUE) + ) { out <- c( "5" = all(x$expected >= 5), "10" = all(x$expected >= 10) @@ -92,9 +101,13 @@ check_homogeneity.htest <- function(x, ...) { } method <- x[["method"]] - if (grepl("(not assuming equal variances)", method, fixed = TRUE) || - grepl("Welch", method, fixed = TRUE)) { - insight::format_error("Test does not assume homogeneity. No need to test this assumption.") + if ( + grepl("(not assuming equal variances)", method, fixed = TRUE) || + grepl("Welch", method, fixed = TRUE) + ) { + insight::format_error( + "Test does not assume homogeneity. No need to test this assumption." + ) } if (grepl("Two Sample t-test", method, fixed = TRUE)) { @@ -152,23 +165,31 @@ check_symmetry.htest <- function(x, ...) { # # } - # Print ------------------------------------------------------------------- #' @export print.check_normality_binom <- function(x, ...) { if (x["10"]) { - insight::print_color(insight::format_message( - "OK: All cells in the expected table have more than 10 observations.\n" - ), "green") + insight::print_color( + insight::format_message( + "OK: All cells in the expected table have more than 10 observations.\n" + ), + "green" + ) } else if (x["5"]) { - insight::print_color(insight::format_message( - "Warning: All cells in the expected table have more than 5 observations, but some have less than 10.\n" - ), "yellow") + insight::print_color( + insight::format_message( + "Warning: All cells in the expected table have more than 5 observations, but some have less than 10.\n" + ), + "yellow" + ) } else { - insight::print_color(insight::format_message( - "Warning: Some cells in the expected table have less than 5 observations.\n" - ), "red") + insight::print_color( + insight::format_message( + "Warning: Some cells in the expected table have less than 5 observations.\n" + ), + "red" + ) } invisible(x) } @@ -193,17 +214,30 @@ print.check_normality_binom <- function(x, ...) { dif <- scale(data, scale = FALSE) Dj <- diag(dif %*% solve(S, tol = tol) %*% t(dif)) Y <- data %*% solve(S, tol = tol) %*% t(data) - Djk <- -2 * t(Y) + matrix(diag(t(Y))) %*% matrix(rep(1, n), 1, n) + matrix(rep(1, n), n, 1) %*% diag(t(Y)) + Djk <- -2 * + t(Y) + + matrix(diag(t(Y))) %*% matrix(rep(1, n), 1, n) + + matrix(rep(1, n), n, 1) %*% diag(t(Y)) b <- 1 / (sqrt(2)) * ((2 * p + 1) / 4)^(1 / (p + 4)) * (n^(1 / (p + 4))) if (qr(S)$rank == p) { - HZ <- n * (1 / (n^2) * sum(sum(exp(-(b^2) / 2 * Djk))) - 2 * ((1 + (b^2))^(-p / 2)) * (1 / n) * (sum(exp(-((b^2) / (2 * (1 + (b^2)))) * Dj))) + ((1 + (2 * (b^2)))^(-p / 2))) + HZ <- n * + (1 / + (n^2) * + sum(sum(exp(-(b^2) / 2 * Djk))) - + 2 * + ((1 + (b^2))^(-p / 2)) * + (1 / n) * + (sum(exp(-((b^2) / (2 * (1 + (b^2)))) * Dj))) + + ((1 + (2 * (b^2)))^(-p / 2))) } else { HZ <- n * 4 } wb <- (1 + b^2) * (1 + 3 * b^2) a <- 1 + 2 * b^2 mu <- 1 - a^(-p / 2) * (1 + p * b^2 / a + (p * (p + 2) * (b^4)) / (2 * a^2)) - si2 <- 2 * (1 + 4 * b^2)^(-p / 2) + 2 * a^(-p) * (1 + (2 * p * b^4) / a^2 + (3 * p * (p + 2) * b^8) / (4 * a^4)) - + si2 <- 2 * + (1 + 4 * b^2)^(-p / 2) + + 2 * a^(-p) * (1 + (2 * p * b^4) / a^2 + (3 * p * (p + 2) * b^8) / (4 * a^4)) - 4 * wb^(-p / 2) * (1 + (3 * p * b^4) / (2 * wb) + (p * (p + 2) * b^8) / (2 * wb^2)) pmu <- log(sqrt(mu^4 / (si2 + mu^2))) psi <- sqrt(log((si2 + mu^2) / mu^2)) diff --git a/R/check_itemscale.R b/R/check_itemscale.R index abea3df80..bec10479e 100644 --- a/R/check_itemscale.R +++ b/R/check_itemscale.R @@ -169,11 +169,14 @@ print.check_itemscale <- function(x, digits = 2, ...) { lapply(seq_along(x), function(i) { out <- x[[i]] attr(out, "table_caption") <- c(sprintf("\nComponent %i", i), "red") - attr(out, "table_footer") <- c(sprintf( - "\nMean inter-item-correlation = %.3f Cronbach's alpha = %.3f", - attributes(out)$item_intercorrelation, - attributes(out)$cronbachs_alpha - ), "yellow") + attr(out, "table_footer") <- c( + sprintf( + "\nMean inter-item-correlation = %.3f Cronbach's alpha = %.3f", + attributes(out)$item_intercorrelation, + attributes(out)$cronbachs_alpha + ), + "yellow" + ) out }), diff --git a/R/check_model.R b/R/check_model.R index b6ab64120..952885f7a 100644 --- a/R/check_model.R +++ b/R/check_model.R @@ -194,25 +194,27 @@ check_model <- function(x, ...) { #' @rdname check_model #' @export -check_model.default <- function(x, - panel = TRUE, - check = "all", - detrend = TRUE, - bandwidth = "nrd", - type = "density", - residual_type = NULL, - show_dots = NULL, - size_dot = 2, - size_line = 0.8, - size_title = 12, - size_axis_title = base_size, - base_size = 10, - alpha = 0.2, - alpha_dot = 0.8, - colors = c("#3aaf85", "#1b6ca8", "#cd201f"), - theme = "see::theme_lucid", - verbose = FALSE, - ...) { +check_model.default <- function( + x, + panel = TRUE, + check = "all", + detrend = TRUE, + bandwidth = "nrd", + type = "density", + residual_type = NULL, + show_dots = NULL, + size_dot = 2, + size_line = 0.8, + size_title = 12, + size_axis_title = base_size, + base_size = 10, + alpha = 0.2, + alpha_dot = 0.8, + colors = c("#3aaf85", "#1b6ca8", "#cd201f"), + theme = "see::theme_lucid", + verbose = FALSE, + ... +) { # check model formula if (verbose) { insight::formula_ok(x) @@ -242,9 +244,23 @@ check_model.default <- function(x, if (minfo$is_bayesian) { suppressWarnings(.check_assumptions_stan(x, ...)) } else if (minfo$is_linear) { - suppressWarnings(.check_assumptions_linear(x, minfo, check, residual_type, verbose, ...)) + suppressWarnings(.check_assumptions_linear( + x, + minfo, + check, + residual_type, + verbose, + ... + )) } else { - suppressWarnings(.check_assumptions_glm(x, minfo, check, residual_type, verbose, ...)) + suppressWarnings(.check_assumptions_glm( + x, + minfo, + check, + residual_type, + verbose, + ... + )) }, error = function(e) { e @@ -257,7 +273,11 @@ check_model.default <- function(x, cleaned_string <- gsub(pattern, replacement, assumptions_data$message) insight::format_error( paste("`check_model()` returned following error:", cleaned_string), - paste0("\nIf the error message does not help identifying your problem, another reason why `check_model()` failed might be that models of class `", class(x)[1], "` are not yet supported.") # nolint + paste0( + "\nIf the error message does not help identifying your problem, another reason why `check_model()` failed might be that models of class `", + class(x)[1], + "` are not yet supported." + ) # nolint ) } @@ -271,7 +291,11 @@ check_model.default <- function(x, } # try to find sensible default for "type" argument - suggest_dots <- (minfo$is_bernoulli || minfo$is_count || minfo$is_ordinal || minfo$is_categorical || minfo$is_multinomial) # nolint + suggest_dots <- (minfo$is_bernoulli || + minfo$is_count || + minfo$is_ordinal || + minfo$is_categorical || + minfo$is_multinomial) # nolint if (missing(type) && suggest_dots) { type <- "discrete_interval" } @@ -325,26 +349,29 @@ plot.check_model <- function(x, ...) { ## need to fix this later #' @export -check_model.stanreg <- function(x, - panel = TRUE, - check = "all", - detrend = TRUE, - bandwidth = "nrd", - type = "density", - residual_type = NULL, - show_dots = NULL, - size_dot = 2, - size_line = 0.8, - size_title = 12, - size_axis_title = base_size, - base_size = 10, - alpha = 0.2, - alpha_dot = 0.8, - colors = c("#3aaf85", "#1b6ca8", "#cd201f"), - theme = "see::theme_lucid", - verbose = FALSE, - ...) { - check_model(bayestestR::bayesian_as_frequentist(x), +check_model.stanreg <- function( + x, + panel = TRUE, + check = "all", + detrend = TRUE, + bandwidth = "nrd", + type = "density", + residual_type = NULL, + show_dots = NULL, + size_dot = 2, + size_line = 0.8, + size_title = 12, + size_axis_title = base_size, + base_size = 10, + alpha = 0.2, + alpha_dot = 0.8, + colors = c("#3aaf85", "#1b6ca8", "#cd201f"), + theme = "see::theme_lucid", + verbose = FALSE, + ... +) { + check_model( + bayestestR::bayesian_as_frequentist(x), size_dot = size_dot, size_line = size_line, panel = panel, @@ -371,25 +398,27 @@ check_model.brmsfit <- check_model.stanreg #' @export -check_model.model_fit <- function(x, - panel = TRUE, - check = "all", - detrend = TRUE, - bandwidth = "nrd", - type = "density", - residual_type = NULL, - show_dots = NULL, - size_dot = 2, - size_line = 0.8, - size_title = 12, - size_axis_title = base_size, - base_size = 10, - alpha = 0.2, - alpha_dot = 0.8, - colors = c("#3aaf85", "#1b6ca8", "#cd201f"), - theme = "see::theme_lucid", - verbose = FALSE, - ...) { +check_model.model_fit <- function( + x, + panel = TRUE, + check = "all", + detrend = TRUE, + bandwidth = "nrd", + type = "density", + residual_type = NULL, + show_dots = NULL, + size_dot = 2, + size_line = 0.8, + size_title = 12, + size_axis_title = base_size, + base_size = 10, + alpha = 0.2, + alpha_dot = 0.8, + colors = c("#3aaf85", "#1b6ca8", "#cd201f"), + theme = "see::theme_lucid", + verbose = FALSE, + ... +) { check_model( x$fit, size_dot = size_dot, @@ -414,25 +443,27 @@ check_model.model_fit <- function(x, #' @export -check_model.performance_simres <- function(x, - panel = TRUE, - check = "all", - detrend = TRUE, - bandwidth = "nrd", - type = "density", - residual_type = NULL, - show_dots = NULL, - size_dot = 2, - size_line = 0.8, - size_title = 12, - size_axis_title = base_size, - base_size = 10, - alpha = 0.2, - alpha_dot = 0.8, - colors = c("#3aaf85", "#1b6ca8", "#cd201f"), - theme = "see::theme_lucid", - verbose = FALSE, - ...) { +check_model.performance_simres <- function( + x, + panel = TRUE, + check = "all", + detrend = TRUE, + bandwidth = "nrd", + type = "density", + residual_type = NULL, + show_dots = NULL, + size_dot = 2, + size_line = 0.8, + size_title = 12, + size_axis_title = base_size, + base_size = 10, + alpha = 0.2, + alpha_dot = 0.8, + colors = c("#3aaf85", "#1b6ca8", "#cd201f"), + theme = "see::theme_lucid", + verbose = FALSE, + ... +) { check_model( x$fittedModel, size_dot = size_dot, @@ -461,7 +492,14 @@ check_model.DHARMa <- check_model.performance_simres # compile plots for checks of linear models ------------------------ -.check_assumptions_linear <- function(model, model_info, check = "all", residual_type = "normal", verbose = TRUE, ...) { +.check_assumptions_linear <- function( + model, + model_info, + check = "all", + residual_type = "normal", + verbose = TRUE, + ... +) { dat <- list() # multicollinearity -------------- @@ -471,7 +509,8 @@ check_model.DHARMa <- check_model.performance_simres # Q-Q plot (normality/uniformity of residuals) -------------- if (any(c("all", "qq") %in% check)) { - dat$QQ <- switch(residual_type, + dat$QQ <- switch( + residual_type, simulated = .safe(simulate_residuals(model, ...)), .model_diagnostic_qq(model, model_info = model_info, verbose = verbose) ) @@ -479,7 +518,12 @@ check_model.DHARMa <- check_model.performance_simres # Random Effects Q-Q plot (normality of BLUPs) -------------- if (any(c("all", "reqq") %in% check)) { - dat$REQQ <- .model_diagnostic_ranef_qq(model, level = 0.95, model_info = model_info, verbose = verbose) + dat$REQQ <- .model_diagnostic_ranef_qq( + model, + level = 0.95, + model_info = model_info, + verbose = verbose + ) } # normal-curve plot (normality of residuals) -------------- @@ -521,7 +565,14 @@ check_model.DHARMa <- check_model.performance_simres # compile plots for checks of generalized linear models ------------------------ -.check_assumptions_glm <- function(model, model_info, check = "all", residual_type = "simulated", verbose = TRUE, ...) { +.check_assumptions_glm <- function( + model, + model_info, + check = "all", + residual_type = "simulated", + verbose = TRUE, + ... +) { dat <- list() # multicollinearity -------------- @@ -531,7 +582,8 @@ check_model.DHARMa <- check_model.performance_simres # Q-Q plot (normality/uniformity of residuals) -------------- if (any(c("all", "qq") %in% check)) { - dat$QQ <- switch(residual_type, + dat$QQ <- switch( + residual_type, simulated = .safe(simulate_residuals(model, ...)), .model_diagnostic_qq(model, model_info = model_info, verbose = verbose) ) @@ -544,7 +596,12 @@ check_model.DHARMa <- check_model.performance_simres # Random Effects Q-Q plot (normality of BLUPs) -------------- if (any(c("all", "reqq") %in% check)) { - dat$REQQ <- .model_diagnostic_ranef_qq(model, level = 0.95, model_info = model_info, verbose = verbose) + dat$REQQ <- .model_diagnostic_ranef_qq( + model, + level = 0.95, + model_info = model_info, + verbose = verbose + ) } # outliers -------------- @@ -603,15 +660,22 @@ check_model.DHARMa <- check_model.performance_simres # get samples from posterior and prior - d1 <- d1[, grepl(pattern = "(b_|bs_|bsp_|bcs_)(?!(Intercept|zi_Intercept))(.*)", colnames(d1), perl = TRUE)] - d2 <- d2[, grepl(pattern = "(b_|bs_|bsp_|bcs_)(?!(Intercept|zi_Intercept))(.*)", colnames(d2), perl = TRUE)] + d1 <- d1[, grepl( + pattern = "(b_|bs_|bsp_|bcs_)(?!(Intercept|zi_Intercept))(.*)", + colnames(d1), + perl = TRUE + )] + d2 <- d2[, grepl( + pattern = "(b_|bs_|bsp_|bcs_)(?!(Intercept|zi_Intercept))(.*)", + colnames(d2), + perl = TRUE + )] } else if (inherits(model, c("stanreg", "stanfit"))) { # check if rstanarm can be loaded if (!requireNamespace("rstanarm", quietly = TRUE)) { insight::format_error("Package `rstanarm` needs to be loaded first!") } - # get samples from posterior and prior prior <- suppressWarnings( @@ -627,7 +691,6 @@ check_model.DHARMa <- check_model.performance_simres d1 <- as.data.frame(model) d2 <- as.data.frame(prior) - # remove intercept from output for ridgeline plot. # this would increase the range of the scale too much @@ -647,11 +710,18 @@ check_model.DHARMa <- check_model.performance_simres d2 <- datawizard::data_remove(d2, "sigma") } - d1 <- d1[, grepl(pattern = "^(?!(b\\[\\(Intercept\\)|Sigma\\[))(.*)", colnames(d1), perl = TRUE)] - d2 <- d2[, grepl(pattern = "^(?!(b\\[\\(Intercept\\)|Sigma\\[))(.*)", colnames(d2), perl = TRUE)] + d1 <- d1[, grepl( + pattern = "^(?!(b\\[\\(Intercept\\)|Sigma\\[))(.*)", + colnames(d1), + perl = TRUE + )] + d2 <- d2[, grepl( + pattern = "^(?!(b\\[\\(Intercept\\)|Sigma\\[))(.*)", + colnames(d2), + perl = TRUE + )] } - # grouping variable d1$group <- "Posterior" diff --git a/R/check_multimodal.R b/R/check_multimodal.R index 9d302c931..252c0788d 100644 --- a/R/check_multimodal.R +++ b/R/check_multimodal.R @@ -66,7 +66,9 @@ check_multimodal.data.frame <- function(x, ...) { insight::format_value(rez$df, protect_integers = TRUE), ") = ", insight::format_value(rez$Chisq), - ", ", insight::format_p(rez$p), ").\n" + ", ", + insight::format_p(rez$p), + ").\n" ) color <- "green" } else { @@ -76,12 +78,13 @@ check_multimodal.data.frame <- function(x, ...) { insight::format_value(rez$df, protect_integers = TRUE), ") = ", insight::format_value(rez$Chisq), - ", ", insight::format_p(rez$p), ").\n" + ", ", + insight::format_p(rez$p), + ").\n" ) color <- "yellow" } - attr(rez, "text") <- insight::format_message(msg) attr(rez, "color") <- color attr(rez, "title") <- "Is the data multimodal?" @@ -105,7 +108,9 @@ check_multimodal.numeric <- function(x, ...) { msg, "the distribution is significantly multimodal (excess mass = ", insight::format_value(rez$excess_mass), - ", ", insight::format_p(rez$p), ").\n" + ", ", + insight::format_p(rez$p), + ").\n" ) color <- "green" } else { @@ -113,7 +118,9 @@ check_multimodal.numeric <- function(x, ...) { msg, "the hypothesis of a multimodal distribution cannot be rejected (excess mass = ", insight::format_value(rez$excess_mass), - ", ", insight::format_p(rez$p), ").\n" + ", ", + insight::format_p(rez$p), + ").\n" ) color <- "yellow" } diff --git a/R/check_normality.R b/R/check_normality.R index c3371db31..ef34d5ad9 100644 --- a/R/check_normality.R +++ b/R/check_normality.R @@ -152,7 +152,12 @@ check_normality.numeric <- function(x, ...) { attr(p.val, "data") <- x attr(p.val, "object_name") <- insight::safe_deparse(substitute(x)) attr(p.val, "effects") <- "fixed" - class(p.val) <- unique(c("check_normality", "see_check_normality", "check_normality_numeric", class(p.val))) + class(p.val) <- unique(c( + "check_normality", + "see_check_normality", + "check_normality_numeric", + class(p.val) + )) p.val } @@ -160,7 +165,6 @@ check_normality.numeric <- function(x, ...) { # methods ---------------------- - #' @importFrom stats residuals #' @export residuals.check_normality_numeric <- function(object, ...) { @@ -192,23 +196,39 @@ print.check_normality <- function(x, ...) { for (i in seq_along(x)) { if (x[i] < 0.05) { insight::print_color( - sprintf("Warning: Non-normality for random effects '%s' detected (%s).\n", re_groups[i], pstring[i]), + sprintf( + "Warning: Non-normality for random effects '%s' detected (%s).\n", + re_groups[i], + pstring[i] + ), "red" ) } else { insight::print_color( - sprintf("OK: Random effects '%s' appear as normally distributed (%s).\n", re_groups[i], pstring[i]), + sprintf( + "OK: Random effects '%s' appear as normally distributed (%s).\n", + re_groups[i], + pstring[i] + ), "green" ) } } } else { - if (length(x) > 1 && "units" %in% names(attributes(x))) type <- attributes(x)$units + if (length(x) > 1 && "units" %in% names(attributes(x))) { + type <- attributes(x)$units + } for (i in seq_along(x)) { if (x[i] < 0.05) { - insight::print_color(sprintf("Warning: Non-normality of %s detected (%s).\n", type[i], pstring[i]), "red") + insight::print_color( + sprintf("Warning: Non-normality of %s detected (%s).\n", type[i], pstring[i]), + "red" + ) } else { - insight::print_color(sprintf("OK: %s appear as normally distributed (%s).\n", type[i], pstring[i]), "green") + insight::print_color( + sprintf("OK: %s appear as normally distributed (%s).\n", type[i], pstring[i]), + "green" + ) } } } @@ -278,7 +298,11 @@ check_normality.merMod <- function(x, effects = "fixed", ...) { p.val <- c(p.val, .check_normality(re[[i]][[j]], x, "random effects")) } } - attr(p.val, "re_qq") <- .model_diagnostic_ranef_qq(x, level = 0.95, model_info = info) + attr(p.val, "re_qq") <- .model_diagnostic_ranef_qq( + x, + level = 0.95, + model_info = info + ) attr(p.val, "type") <- "random effects" attr(p.val, "re_groups") <- re_groups } @@ -336,7 +360,10 @@ check_normality.BFBayesFactor <- check_normality.afex_aov if (is.null(ts_result)) { insight::print_color( - sprintf("`check_normality()` does not support models of class `%s`.\n", class(model)[1]), + sprintf( + "`check_normality()` does not support models of class `%s`.\n", + class(model)[1] + ), "red" ) return(NULL) diff --git a/R/check_outliers.R b/R/check_outliers.R index 22c393e3f..df3f407b8 100644 --- a/R/check_outliers.R +++ b/R/check_outliers.R @@ -289,17 +289,17 @@ #' #' - Lüdecke, D., Ben-Shachar, M. S., Patil, I., Waggoner, P., and Makowski, D. #' (2021). performance: An R package for assessment, comparison and testing of -#' statistical models. *Journal of Open Source Software*, *6*(60), 3139. +#' statistical models. Journal of Open Source Software, 6(60), 3139. #' \doi{10.21105/joss.03139} #' #' - Thériault, R., Ben-Shachar, M. S., Patil, I., Lüdecke, D., Wiernik, B. M., #' and Makowski, D. (2023). Check your outliers! An introduction to identifying -#' statistical outliers in R with easystats. *Behavior Research Methods*, 1-11. +#' statistical outliers in R with easystats. Behavior Research Methods, 1-11. #' \doi{10.3758/s13428-024-02356-w} #' #' - Rousseeuw, P. J., and Van Zomeren, B. C. (1990). Unmasking multivariate -#' outliers and leverage points. *Journal of the American Statistical -#' association*, *85*(411), 633-639. +#' outliers and leverage points. Journal of the American Statistical +#' association, 85(411), 633-639. #' #' @examples #' data <- mtcars # Size nrow(data) = 32 @@ -372,25 +372,49 @@ check_outliers.character <- function(x, ...) { #' @rdname check_outliers #' @export -check_outliers.default <- function(x, - method = c("cook", "pareto"), - threshold = NULL, - ID = NULL, - verbose = TRUE, - ...) { +check_outliers.default <- function( + x, + method = c("cook", "pareto"), + threshold = NULL, + ID = NULL, + verbose = TRUE, + ... +) { # Check args if (all(method == "all")) { method <- c( - "zscore_robust", "iqr", "ci", "cook", "pareto", "mahalanobis", - "mahalanobis_robust", "mcd", "ics", "optics", "lof" + "zscore_robust", + "iqr", + "ci", + "cook", + "pareto", + "mahalanobis", + "mahalanobis_robust", + "mcd", + "ics", + "optics", + "lof" ) } method <- match.arg( method, c( - "zscore", "zscore_robust", "iqr", "ci", "hdi", "eti", "bci", "cook", - "pareto", "mahalanobis", "mahalanobis_robust", "mcd", "ics", "optics", "lof" + "zscore", + "zscore_robust", + "iqr", + "ci", + "hdi", + "eti", + "bci", + "cook", + "pareto", + "mahalanobis", + "mahalanobis_robust", + "mcd", + "ics", + "optics", + "lof" ), several.ok = TRUE ) @@ -402,7 +426,15 @@ check_outliers.default <- function(x, my_data <- insight::get_data(x, verbose = FALSE) # sanity check for date, POSIXt and difftime variables - if (any(vapply(my_data, inherits, FUN.VALUE = logical(1), what = c("Date", "POSIXt", "difftime"))) && verbose) { + if ( + any(vapply( + my_data, + inherits, + FUN.VALUE = logical(1), + what = c("Date", "POSIXt", "difftime") + )) && + verbose + ) { insight::format_alert( paste( "Date variables are not supported for outliers detection. These will be ignored.", @@ -444,7 +476,11 @@ check_outliers.default <- function(x, } if (!missing(ID) && verbose) { - insight::format_warning(paste0("ID argument not supported for model objects of class `", class(x)[1], "`.")) + insight::format_warning(paste0( + "ID argument not supported for model objects of class `", + class(x)[1], + "`." + )) } # Others @@ -467,18 +503,18 @@ check_outliers.default <- function(x, threshold = thresholds$cook )$data_cook - my_df <- datawizard::data_merge(list(my_df, data_cook), - join = "full", - by = "Row" - ) + my_df <- datawizard::data_merge(list(my_df, data_cook), join = "full", by = "Row") count.table <- datawizard::data_filter( - data_cook, "Outlier_Cook > 0.5" + data_cook, + "Outlier_Cook > 0.5" ) count.table <- datawizard::data_remove( - count.table, "Cook", - regex = TRUE, as_data_frame = TRUE + count.table, + "Cook", + regex = TRUE, + as_data_frame = TRUE ) if (nrow(count.table) >= 1) { @@ -507,18 +543,18 @@ check_outliers.default <- function(x, threshold = thresholds$pareto )$data_pareto - my_df <- datawizard::data_merge(list(my_df, data_pareto), - join = "full", - by = "Row" - ) + my_df <- datawizard::data_merge(list(my_df, data_pareto), join = "full", by = "Row") count.table <- datawizard::data_filter( - data_pareto, "Outlier_Pareto > 0.5" + data_pareto, + "Outlier_Pareto > 0.5" ) count.table <- datawizard::data_remove( - count.table, "Pareto", - regex = TRUE, as_data_frame = TRUE + count.table, + "Pareto", + regex = TRUE, + as_data_frame = TRUE ) if (nrow(count.table) >= 1) { @@ -540,7 +576,8 @@ check_outliers.default <- function(x, method <- method[method != "pareto"] } - outlier_count$all <- datawizard::convert_na_to(outlier_count$all, + outlier_count$all <- datawizard::convert_na_to( + outlier_count$all, replace_num = 0, replace_char = "0", replace_fac = 0 @@ -581,7 +618,10 @@ check_outliers.default <- function(x, attr(outlier, "threshold") <- thresholds attr(outlier, "method") <- method attr(outlier, "text_size") <- 3 - attr(outlier, "influential_obs") <- .safe(.model_diagnostic_outlier(x, threshold = unlist(thresholds))) # nolint + attr(outlier, "influential_obs") <- .safe(.model_diagnostic_outlier( + x, + threshold = unlist(thresholds) + )) # nolint attr(outlier, "variables") <- "(Whole model)" attr(outlier, "raw_data") <- my_data attr(outlier, "outlier_var") <- outlier_var @@ -593,7 +633,6 @@ check_outliers.default <- function(x, # Methods ----------------------------------------------------------------- - #' @export as.data.frame.check_outliers <- function(x, ...) { attributes(x)$data @@ -622,14 +661,22 @@ print.check_outliers <- function(x, ...) { method = method, thresholds = unlist(thresholds) ) - method.thresholds <- paste0(method.thresholds$method, " (", - method.thresholds$thresholds, ")", + method.thresholds <- paste0( + method.thresholds$method, + " (", + method.thresholds$thresholds, + ")", collapse = ", " ) method.univariate <- c( - "zscore", "zscore_robust", "iqr", "ci", - "eti", "hdi", "bci" + "zscore", + "zscore_robust", + "iqr", + "ci", + "eti", + "hdi", + "bci" ) vars <- toString(attr(x, "variables")) @@ -638,11 +685,10 @@ print.check_outliers <- function(x, ...) { if (identical(method, "Residual check")) { var.plural <- "correlation between" } else { - var.plural <- ifelse(length(attr(x, "variables")) > 1, - "variables", "variable" - ) + var.plural <- ifelse(length(attr(x, "variables")) > 1, "variables", "variable") } - method.plural <- ifelse(length(thresholds) > 1, + method.plural <- ifelse( + length(thresholds) > 1, "methods and thresholds", "method and threshold" ) @@ -658,55 +704,73 @@ print.check_outliers <- function(x, ...) { if (length(outliers) >= 1) { outlier.count <- attr(x, "outlier_count") o <- toString(outliers) - insight::print_color(insight::format_message( - sprintf( - "%i %s detected: %s %s.", length(outliers), - outlier.plural, case.plural, o - ), - sprintf( - "- Based on the following %s: %s.", - method.plural, method.thresholds + insight::print_color( + insight::format_message( + sprintf( + "%i %s detected: %s %s.", + length(outliers), + outlier.plural, + case.plural, + o + ), + sprintf( + "- Based on the following %s: %s.", + method.plural, + method.thresholds + ), + sprintf("- For %s: %s.\n", var.plural, vars), + indent = "" ), - sprintf("- For %s: %s.\n", var.plural, vars), - indent = "" - ), color = "yellow") + color = "yellow" + ) if (length(method) > 1) { insight::print_color( c( "\nNote: Outliers were classified as such by", "at least half of the selected methods. \n" - ), "yellow" + ), + "yellow" ) } - if ((isTRUE(nrow(outlier.count$all) > 0) || isTRUE(attributes(x)$grouped)) && - (length(method) > 1 || all(method %in% method.univariate))) { - cat(long_dash, insight::format_message( - "\nThe following observations were considered outliers for two or more", - "variables by at least one of the selected methods:\n\n" - )) - ifelse(isTRUE(attributes(x)$grouped), + if ( + (isTRUE(nrow(outlier.count$all) > 0) || isTRUE(attributes(x)$grouped)) && + (length(method) > 1 || all(method %in% method.univariate)) + ) { + cat( + long_dash, + insight::format_message( + "\nThe following observations were considered outliers for two or more", + "variables by at least one of the selected methods:\n\n" + ) + ) + ifelse( + isTRUE(attributes(x)$grouped), print(lapply(outlier.count, function(x) x$all)), print(outlier.count$all) ) } if (length(method) == 1 && all(method %in% method.univariate)) { - cat(long_dash, "Outliers per variable (", method, - "): \n\n", - sep = "" - ) - ifelse(isTRUE(attributes(x)$grouped), + cat(long_dash, "Outliers per variable (", method, "): \n\n", sep = "") + ifelse( + isTRUE(attributes(x)$grouped), print(vars.outliers), print(vars.outliers[[1]]) ) } } else { insight::print_color( - sprintf("OK: No outliers detected. + sprintf( + "OK: No outliers detected. - Based on the following %s: %s. -- For %s: %s\n\n", method.plural, method.thresholds, var.plural, vars), +- For %s: %s\n\n", + method.plural, + method.thresholds, + var.plural, + vars + ), "green" ) } @@ -739,9 +803,18 @@ print.check_outliers_metafor <- function(x, ...) { } else { o <- datawizard::text_concatenate(paste0(outliers, " (", studies, ")")) } - insight::print_color(insight::format_message( - sprintf("%i %s detected: %s %s.\n", length(outliers), outlier.plural, case.plural, o) - ), "yellow") + insight::print_color( + insight::format_message( + sprintf( + "%i %s detected: %s %s.\n", + length(outliers), + outlier.plural, + case.plural, + o + ) + ), + "yellow" + ) } else { insight::print_color("OK: No outliers detected.\n", "green") } @@ -768,14 +841,27 @@ print.check_outliers_metagen <- function(x, ...) { if (all(as.character(studies[outliers_fixed]) == as.character(outliers_fixed))) { o <- datawizard::text_concatenate(outliers_fixed) } else { - o <- datawizard::text_concatenate(paste0(outliers_fixed, " (", studies[outliers_fixed], ")")) + o <- datawizard::text_concatenate(paste0( + outliers_fixed, + " (", + studies[outliers_fixed], + ")" + )) } - insight::print_color(insight::format_message( - sprintf("- %i %s in fixed effects detected: %s %s.\n", length(outliers_fixed), outlier.plural, case.plural, o) - ), "yellow") + insight::print_color( + insight::format_message( + sprintf( + "- %i %s in fixed effects detected: %s %s.\n", + length(outliers_fixed), + outlier.plural, + case.plural, + o + ) + ), + "yellow" + ) } - if (length(outliers_random) > 1) { outlier.plural <- "outliers" case.plural <- "cases" @@ -788,14 +874,28 @@ print.check_outliers_metagen <- function(x, ...) { if (all(as.character(studies[outliers_random]) == as.character(outliers_random))) { o <- datawizard::text_concatenate(outliers_random) } else { - o <- datawizard::text_concatenate(paste0(outliers_random, " (", studies[outliers_random], ")")) + o <- datawizard::text_concatenate(paste0( + outliers_random, + " (", + studies[outliers_random], + ")" + )) } if (length(outliers_fixed) >= 1) { cat("\n") } - insight::print_color(insight::format_message( - sprintf("- %i %s in random effects detected: %s %s.\n", length(outliers_random), outlier.plural, case.plural, o) - ), "yellow") + insight::print_color( + insight::format_message( + sprintf( + "- %i %s in random effects detected: %s %s.\n", + length(outliers_random), + outlier.plural, + case.plural, + o + ) + ), + "yellow" + ) } if (!length(outliers_random) && !length(outliers_fixed)) { @@ -917,31 +1017,24 @@ check_outliers.item_omega <- check_outliers.parameters_efa #' @rdname check_outliers #' @export -check_outliers.numeric <- function(x, - method = "zscore_robust", - threshold = NULL, - ...) { +check_outliers.numeric <- function(x, method = "zscore_robust", threshold = NULL, ...) { x <- as.data.frame(x) names(x) <- datawizard::text_remove(sys.call()[2], "()") - check_outliers(x, - method = method, - threshold = threshold, - ... - ) + check_outliers(x, method = method, threshold = threshold, ...) } #' @rdname check_outliers #' @export -check_outliers.data.frame <- function(x, - method = "mahalanobis", - threshold = NULL, - ID = NULL, - ...) { +check_outliers.data.frame <- function( + x, + method = "mahalanobis", + threshold = NULL, + ID = NULL, + ... +) { # Preserve ID column if desired - ID.names <- switch(!is.null(ID), - x[ID] - ) + ID.names <- switch(!is.null(ID), x[ID]) # Remove non-numerics my_data <- x @@ -950,16 +1043,40 @@ check_outliers.data.frame <- function(x, # Check args if (all(method == "all")) { method <- c( - "zscore_robust", "iqr", "ci", "cook", "pareto", "mahalanobis", - "mahalanobis_robust", "mcd", "ics", "optics", "lof" + "zscore_robust", + "iqr", + "ci", + "cook", + "pareto", + "mahalanobis", + "mahalanobis_robust", + "mcd", + "ics", + "optics", + "lof" ) } - method <- match.arg(method, c( - "zscore", "zscore_robust", "iqr", "ci", "hdi", - "eti", "bci", "cook", "pareto", "mahalanobis", - "mahalanobis_robust", "mcd", "ics", "optics", - "lof" - ), several.ok = TRUE) + method <- match.arg( + method, + c( + "zscore", + "zscore_robust", + "iqr", + "ci", + "hdi", + "eti", + "bci", + "cook", + "pareto", + "mahalanobis", + "mahalanobis_robust", + "mcd", + "ics", + "optics", + "lof" + ), + several.ok = TRUE + ) # Thresholds if (is.null(threshold)) { @@ -1017,21 +1134,20 @@ check_outliers.data.frame <- function(x, # Combine outlier frequency table if (length(outlier_count) > 1 && !is.null(ID)) { - outlier_count$all <- datawizard::data_merge(outlier_count, + outlier_count$all <- datawizard::data_merge( + outlier_count, join = "full", by = c("Row", ID) ) } else if (length(outlier_count) > 1) { - outlier_count$all <- datawizard::data_merge(outlier_count, - join = "full", - by = "Row" - ) + outlier_count$all <- datawizard::data_merge(outlier_count, join = "full", by = "Row") } else if (length(outlier_count) == 1) { outlier_count$all <- outlier_count[[1]] } else { outlier_count$all <- data.frame() } - outlier_count$all <- datawizard::convert_na_to(outlier_count$all, + outlier_count$all <- datawizard::convert_na_to( + outlier_count$all, replace_num = 0, replace_char = "0", replace_fac = 0 @@ -1075,7 +1191,9 @@ check_outliers.data.frame <- function(x, x[x[[Outlier_method]] >= 0.5, ] }) outlier.list <- outlier.list[vapply(outlier.list, nrow, numeric(1)) > 0] - outlier.list <- lapply(outlier.list, datawizard::data_remove, + outlier.list <- lapply( + outlier.list, + datawizard::data_remove, Outlier_method, as_data_frame = TRUE ) @@ -1107,13 +1225,16 @@ check_outliers.data.frame <- function(x, # Z-score if ("zscore" %in% method) { - out <- c(out, .check_outliers_zscore( - x, - threshold = thresholds$zscore, - robust = FALSE, - method = "max", - ID.names = ID.names - )) + out <- c( + out, + .check_outliers_zscore( + x, + threshold = thresholds$zscore, + robust = FALSE, + method = "max", + ID.names = ID.names + ) + ) # Outliers per variable zscore.var <- lapply( @@ -1130,22 +1251,30 @@ check_outliers.data.frame <- function(x, } if ("zscore_robust" %in% method) { - out <- c(out, .check_outliers_zscore( + out <- c( + out, + .check_outliers_zscore( + x, + threshold = thresholds$zscore_robust, + robust = TRUE, + method = "max", + ID.names = ID.names + ) + ) + + # Outliers per variable + zscore_robust.var <- lapply( x, + .check_outliers_zscore, threshold = thresholds$zscore_robust, robust = TRUE, method = "max", ID.names = ID.names - )) - - # Outliers per variable - zscore_robust.var <- lapply(x, .check_outliers_zscore, - threshold = thresholds$zscore_robust, - robust = TRUE, method = "max", ID.names = ID.names ) outlier_var$zscore_robust <- process_outlier_list( - zscore_robust.var, "Outlier_Zscore_robust" + zscore_robust.var, + "Outlier_Zscore_robust" ) outlier_count$zscore_robust <- count_outlier_table( outlier_var$zscore_robust @@ -1154,12 +1283,15 @@ check_outliers.data.frame <- function(x, # IQR if ("iqr" %in% method) { - out <- c(out, .check_outliers_iqr( - x, - threshold = thresholds$iqr, - method = "tukey", - ID.names = ID.names - )) + out <- c( + out, + .check_outliers_iqr( + x, + threshold = thresholds$iqr, + method = "tukey", + ID.names = ID.names + ) + ) # Outliers per variable iqr.var <- lapply(x, function(x) { @@ -1179,12 +1311,15 @@ check_outliers.data.frame <- function(x, # CI if (any(c("ci", "hdi", "eti", "bci") %in% method)) { for (i in method[method %in% c("ci", "hdi", "eti", "bci")]) { - out <- c(out, .check_outliers_ci( - x, - threshold = thresholds[i], - method = i, - ID.names = ID.names - )) + out <- c( + out, + .check_outliers_ci( + x, + threshold = thresholds[i], + method = i, + ID.names = ID.names + ) + ) # Outliers per variable loop.var <- lapply(x, function(x) { @@ -1198,7 +1333,8 @@ check_outliers.data.frame <- function(x, }) outlier_var[[i]] <- process_outlier_list( - loop.var, paste0("Outlier_", i) + loop.var, + paste0("Outlier_", i) ) outlier_count[[i]] <- count_outlier_table(outlier_var[[i]]) } @@ -1206,20 +1342,26 @@ check_outliers.data.frame <- function(x, # Mahalanobis if ("mahalanobis" %in% method) { - out <- c(out, .check_outliers_mahalanobis( - x, - threshold = thresholds$mahalanobis, - ID.names = ID.names, - ... - )) + out <- c( + out, + .check_outliers_mahalanobis( + x, + threshold = thresholds$mahalanobis, + ID.names = ID.names, + ... + ) + ) count.table <- datawizard::data_filter( - out$data_mahalanobis, "Outlier_Mahalanobis > 0.5" + out$data_mahalanobis, + "Outlier_Mahalanobis > 0.5" ) count.table <- datawizard::data_remove( - count.table, "Mahalanobis", - regex = TRUE, as_data_frame = TRUE + count.table, + "Mahalanobis", + regex = TRUE, + as_data_frame = TRUE ) if (nrow(count.table) >= 1) { @@ -1231,19 +1373,25 @@ check_outliers.data.frame <- function(x, # Robust Mahalanobis if ("mahalanobis_robust" %in% method) { - out <- c(out, .check_outliers_mahalanobis_robust( - x, - threshold = thresholds$mahalanobis_robust, - ID.names = ID.names - )) + out <- c( + out, + .check_outliers_mahalanobis_robust( + x, + threshold = thresholds$mahalanobis_robust, + ID.names = ID.names + ) + ) count.table <- datawizard::data_filter( - out$data_mahalanobis_robust, "Outlier_Mahalanobis_robust > 0.5" + out$data_mahalanobis_robust, + "Outlier_Mahalanobis_robust > 0.5" ) count.table <- datawizard::data_remove( - count.table, "Mahalanobis", - regex = TRUE, as_data_frame = TRUE + count.table, + "Mahalanobis", + regex = TRUE, + as_data_frame = TRUE ) if (nrow(count.table) >= 1) { @@ -1255,20 +1403,26 @@ check_outliers.data.frame <- function(x, # MCD if ("mcd" %in% method) { - out <- c(out, .check_outliers_mcd( - x, - threshold = thresholds$mcd, - ID.names = ID.names, - ... - )) + out <- c( + out, + .check_outliers_mcd( + x, + threshold = thresholds$mcd, + ID.names = ID.names, + ... + ) + ) count.table <- datawizard::data_filter( - out$data_mcd, "Outlier_MCD > 0.5" + out$data_mcd, + "Outlier_MCD > 0.5" ) count.table <- datawizard::data_remove( - count.table, "MCD", - regex = TRUE, as_data_frame = TRUE + count.table, + "MCD", + regex = TRUE, + as_data_frame = TRUE ) if (nrow(count.table) >= 1) { @@ -1280,21 +1434,27 @@ check_outliers.data.frame <- function(x, # ICS if ("ics" %in% method) { - out <- c(out, .check_outliers_ics( - x, - threshold = thresholds$ics, - ID.names = ID.names - )) + out <- c( + out, + .check_outliers_ics( + x, + threshold = thresholds$ics, + ID.names = ID.names + ) + ) # make sure we have valid results if (!is.null(out)) { count.table <- datawizard::data_filter( - out$data_ics, "Outlier_ICS > 0.5" + out$data_ics, + "Outlier_ICS > 0.5" ) count.table <- datawizard::data_remove( - count.table, "ICS", - regex = TRUE, as_data_frame = TRUE + count.table, + "ICS", + regex = TRUE, + as_data_frame = TRUE ) if (nrow(count.table) >= 1) { @@ -1307,20 +1467,26 @@ check_outliers.data.frame <- function(x, # OPTICS if ("optics" %in% method) { - out <- c(out, .check_outliers_optics( - x, - threshold = thresholds$optics, - ID.names = ID.names, - xi = thresholds$optics_xi - )) + out <- c( + out, + .check_outliers_optics( + x, + threshold = thresholds$optics, + ID.names = ID.names, + xi = thresholds$optics_xi + ) + ) count.table <- datawizard::data_filter( - out$data_optics, "Outlier_OPTICS > 0.5" + out$data_optics, + "Outlier_OPTICS > 0.5" ) count.table <- datawizard::data_remove( - count.table, "OPTICS", - regex = TRUE, as_data_frame = TRUE + count.table, + "OPTICS", + regex = TRUE, + as_data_frame = TRUE ) if (nrow(count.table) >= 1) { @@ -1337,19 +1503,25 @@ check_outliers.data.frame <- function(x, # Local Outlier Factor if ("lof" %in% method) { - out <- c(out, .check_outliers_lof( - x, - threshold = thresholds$lof, - ID.names = ID.names - )) + out <- c( + out, + .check_outliers_lof( + x, + threshold = thresholds$lof, + ID.names = ID.names + ) + ) count.table <- datawizard::data_filter( - out$data_lof, "Outlier_LOF > 0.5" + out$data_lof, + "Outlier_LOF > 0.5" ) count.table <- datawizard::data_remove( - count.table, "LOF", - regex = TRUE, as_data_frame = TRUE + count.table, + "LOF", + regex = TRUE, + as_data_frame = TRUE ) if (nrow(count.table) >= 1) { @@ -1364,11 +1536,13 @@ check_outliers.data.frame <- function(x, #' @export -check_outliers.grouped_df <- function(x, - method = "mahalanobis", - threshold = NULL, - ID = NULL, - ...) { +check_outliers.grouped_df <- function( + x, + method = "mahalanobis", + threshold = NULL, + ID = NULL, + ... +) { info <- attributes(x) # poorman < 0.8.0? @@ -1399,13 +1573,16 @@ check_outliers.grouped_df <- function(x, out <- c(out, outliers_subset) thresholds[[paste0("group_", i)]] <- attributes(outliers_subset)$threshold outlier_var[[i]] <- lapply( - attributes(outliers_subset)$outlier_var, lapply, function(y) { + attributes(outliers_subset)$outlier_var, + lapply, + function(y) { y$Row <- rows[which(seq_along(rows) %in% y$Row)] y } ) outlier_count[[i]] <- lapply( - attributes(outliers_subset)$outlier_count, function(y) { + attributes(outliers_subset)$outlier_count, + function(y) { y$Row <- rows[which(seq_along(rows) %in% y$Row)] y } @@ -1449,15 +1626,17 @@ check_outliers.grouped_df <- function(x, #' @export -check_outliers.BFBayesFactor <- function(x, - ID = NULL, - ...) { +check_outliers.BFBayesFactor <- function(x, ID = NULL, ...) { if (!insight::is_model(x)) { insight::format_error("Collinearity only applicable to regression models.") } if (!missing(ID)) { - insight::format_warning(paste0("ID argument not supported for objects of class `", class(x)[1], "`.")) + insight::format_warning(paste0( + "ID argument not supported for objects of class `", + class(x)[1], + "`." + )) } d <- insight::get_predictors(x) @@ -1468,11 +1647,7 @@ check_outliers.BFBayesFactor <- function(x, #' @export -check_outliers.gls <- function(x, - method = "pareto", - threshold = NULL, - ID = NULL, - ...) { +check_outliers.gls <- function(x, method = "pareto", threshold = NULL, ID = NULL, ...) { if (!missing(ID)) { insight::format_warning( paste0("ID argument not supported for objects of class `", class(x)[1], "`.") @@ -1500,11 +1675,13 @@ check_outliers.fixest <- check_outliers.gls #' @export -check_outliers.fixest_multi <- function(x, - method = "pareto", - threshold = NULL, - ID = NULL, - ...) { +check_outliers.fixest_multi <- function( + x, + method = "pareto", + threshold = NULL, + ID = NULL, + ... +) { lapply(x, check_outliers.fixest) } @@ -1584,16 +1761,36 @@ check_outliers.metabin <- check_outliers.metagen #' @rdname check_outliers #' @export -check_outliers.performance_simres <- function(x, type = "default", iterations = 100, alternative = "two.sided", ...) { +check_outliers.performance_simres <- function( + x, + type = "default", + iterations = 100, + alternative = "two.sided", + ... +) { type <- insight::validate_argument(type, c("default", "binomial", "bootstrap")) - alternative <- insight::validate_argument(alternative, c("two.sided", "greater", "less")) + alternative <- insight::validate_argument( + alternative, + c("two.sided", "greater", "less") + ) insight::check_if_installed("DHARMa") - result <- DHARMa::testOutliers(x, type = type, nBoot = iterations, alternative = alternative, plot = FALSE, ...) + result <- DHARMa::testOutliers( + x, + type = type, + nBoot = iterations, + alternative = alternative, + plot = FALSE, + ... + ) outlier <- list( Coefficient = as.vector(result$estimate), - Expected = as.numeric(gsub("(.*)\\(expected: (\\d.*)\\)", "\\2", names(result$estimate))), + Expected = as.numeric(gsub( + "(.*)\\(expected: (\\d.*)\\)", + "\\2", + names(result$estimate) + )), CI_low = result$conf.int[1], CI_high = result$conf.int[2], p_value = result$p.value @@ -1608,7 +1805,6 @@ check_outliers.DHARMa <- check_outliers.performance_simres # Thresholds -------------------------------------------------------------- - .check_outliers_thresholds <- function(x) { suppressWarnings(.check_outliers_thresholds_nowarn(x)) } @@ -1638,11 +1834,13 @@ check_outliers.DHARMa <- check_outliers.performance_simres # utilities -------------------- -.check_outliers_zscore <- function(x, - threshold = stats::qnorm(p = 1 - 0.001 / 2), - robust = TRUE, - method = "max", - ID.names = NULL) { +.check_outliers_zscore <- function( + x, + threshold = stats::qnorm(p = 1 - 0.001 / 2), + robust = TRUE, + method = "max", + ID.names = NULL +) { if (threshold < 1) { insight::format_error( "The `threshold` argument must be one or greater for method `zscore`." @@ -1685,8 +1883,10 @@ check_outliers.DHARMa <- check_outliers.performance_simres if (isTRUE(robust)) { names(output) <- paste0(names(output), "_robust") output$data_zscore_robust <- datawizard::data_addsuffix( - output$data_zscore_robust, "_robust", - select = "Zscore$", regex = TRUE + output$data_zscore_robust, + "_robust", + select = "Zscore$", + regex = TRUE ) } @@ -1694,10 +1894,7 @@ check_outliers.DHARMa <- check_outliers.performance_simres } -.check_outliers_iqr <- function(x, - threshold = 1.7, - method = "tukey", - ID.names = NULL) { +.check_outliers_iqr <- function(x, threshold = 1.7, method = "tukey", ID.names = NULL) { d <- data.frame(Row = seq_len(nrow(as.data.frame(x)))) Distance_IQR <- d @@ -1705,7 +1902,8 @@ check_outliers.DHARMa <- check_outliers.performance_simres v <- x[, col] if (method == "tukey") { - iqr <- stats::quantile(v, 0.75, na.rm = TRUE) - stats::quantile(v, 0.25, na.rm = TRUE) + iqr <- stats::quantile(v, 0.75, na.rm = TRUE) - + stats::quantile(v, 0.25, na.rm = TRUE) } else { iqr <- stats::IQR(v, na.rm = TRUE) } @@ -1730,13 +1928,21 @@ check_outliers.DHARMa <- check_outliers.performance_simres # out$Distance_IQR <- Distance_IQR - out$Distance_IQR <- vapply(as.data.frame(t(Distance_IQR)), function(x) { - ifelse(all(is.na(x)), NA_real_, max(x, na.rm = TRUE)) - }, numeric(1)) + out$Distance_IQR <- vapply( + as.data.frame(t(Distance_IQR)), + function(x) { + ifelse(all(is.na(x)), NA_real_, max(x, na.rm = TRUE)) + }, + numeric(1) + ) - out$Outlier_IQR <- vapply(as.data.frame(t(d)), function(x) { - ifelse(all(is.na(x)), NA_real_, max(x, na.rm = TRUE)) - }, numeric(1)) + out$Outlier_IQR <- vapply( + as.data.frame(t(d)), + function(x) { + ifelse(all(is.na(x)), NA_real_, max(x, na.rm = TRUE)) + }, + numeric(1) + ) list( data_iqr = out, @@ -1745,10 +1951,7 @@ check_outliers.DHARMa <- check_outliers.performance_simres } -.check_outliers_ci <- function(x, - threshold = 1 - 0.001, - method = "ci", - ID.names = NULL) { +.check_outliers_ci <- function(x, threshold = 1 - 0.001, method = "ci", ID.names = NULL) { # Run through columns d <- data.frame(Row = seq_len(nrow(x))) Distance_CI <- d @@ -1795,9 +1998,7 @@ check_outliers.DHARMa <- check_outliers.performance_simres } -.check_outliers_cook <- function(x, - threshold = NULL, - ID.names = NULL) { +.check_outliers_cook <- function(x, threshold = NULL, ID.names = NULL) { # Compute d <- unname(stats::cooks.distance(x)) out <- data.frame(Row = seq_along(d)) @@ -1832,12 +2033,15 @@ check_outliers.DHARMa <- check_outliers.performance_simres } -.check_outliers_mahalanobis <- function(x, - threshold = stats::qchisq( - p = 1 - 0.001, df = ncol(x) - ), - ID.names = NULL, - ...) { +.check_outliers_mahalanobis <- function( + x, + threshold = stats::qchisq( + p = 1 - 0.001, + df = ncol(x) + ), + ID.names = NULL, + ... +) { if (anyNA(x) || any(with(x, x == Inf))) { insight::format_error("Missing or infinite values are not allowed.") } @@ -1849,7 +2053,12 @@ check_outliers.DHARMa <- check_outliers.performance_simres } # Compute - out$Distance_Mahalanobis <- stats::mahalanobis(x, center = colMeans(x), cov = stats::cov(x), ...) + out$Distance_Mahalanobis <- stats::mahalanobis( + x, + center = colMeans(x), + cov = stats::cov(x), + ... + ) # Filter out$Outlier_Mahalanobis <- as.numeric(out$Distance_Mahalanobis > threshold) @@ -1862,11 +2071,14 @@ check_outliers.DHARMa <- check_outliers.performance_simres # Bigutils not yet fully available on CRAN -.check_outliers_mahalanobis_robust <- function(x, - threshold = stats::qchisq( - p = 1 - 0.001, df = ncol(x) - ), - ID.names = NULL) { +.check_outliers_mahalanobis_robust <- function( + x, + threshold = stats::qchisq( + p = 1 - 0.001, + df = ncol(x) + ), + ID.names = NULL +) { out <- data.frame(Row = seq_len(nrow(x))) if (!is.null(ID.names)) { @@ -1891,12 +2103,14 @@ check_outliers.DHARMa <- check_outliers.performance_simres } -.check_outliers_mcd <- function(x, - threshold = stats::qchisq(p = 1 - 0.001, df = ncol(x)), - percentage_central = 0.75, - ID.names = NULL, - verbose = TRUE, - ...) { +.check_outliers_mcd <- function( + x, + threshold = stats::qchisq(p = 1 - 0.001, df = ncol(x)), + percentage_central = 0.75, + ID.names = NULL, + verbose = TRUE, + ... +) { out <- data.frame(Row = seq_len(nrow(x))) if (!is.null(ID.names)) { @@ -1934,10 +2148,7 @@ check_outliers.DHARMa <- check_outliers.performance_simres } -.check_outliers_ics <- function(x, - threshold = 0.001, - ID.names = NULL, - ...) { +.check_outliers_ics <- function(x, threshold = 0.001, ID.names = NULL, ...) { out <- data.frame(Row = seq_len(nrow(x))) if (!is.null(ID.names)) { @@ -1986,9 +2197,18 @@ check_outliers.DHARMa <- check_outliers.performance_simres if (is.null(outliers)) { if (ncol(x) == 1) { - insight::print_color("At least two numeric predictors are required to detect outliers.\n", "red") + insight::print_color( + "At least two numeric predictors are required to detect outliers.\n", + "red" + ) } else { - insight::print_color(sprintf("`check_outliers()` does not support models of class `%s`.\n", class(x)[1]), "red") + insight::print_color( + sprintf( + "`check_outliers()` does not support models of class `%s`.\n", + class(x)[1] + ), + "red" + ) } return(NULL) } @@ -2011,10 +2231,7 @@ check_outliers.DHARMa <- check_outliers.performance_simres } -.check_outliers_optics <- function(x, - threshold = NULL, - ID.names = NULL, - xi = 0.05) { +.check_outliers_optics <- function(x, threshold = NULL, ID.names = NULL, xi = 0.05) { out <- data.frame(Row = seq_len(nrow(x))) if (!is.null(ID.names)) { @@ -2075,10 +2292,7 @@ check_outliers.DHARMa <- check_outliers.performance_simres # ) # } - -.check_outliers_lof <- function(x, - threshold = 0.001, - ID.names = NULL) { +.check_outliers_lof <- function(x, threshold = 0.001, ID.names = NULL) { if (threshold < 0 || threshold > 1) { insight::format_error( "The `threshold` argument must be between 0 and 1 for method `lof`." @@ -2113,7 +2327,11 @@ check_outliers.DHARMa <- check_outliers.performance_simres #' @export check_outliers.glmmTMB <- function(x, ...) { - insight::format_alert(paste0("`check_outliers()` does not yet support models of class `", class(x)[1], "`.")) + insight::format_alert(paste0( + "`check_outliers()` does not yet support models of class `", + class(x)[1], + "`." + )) NULL } diff --git a/R/model_performance.R b/R/model_performance.R index c5de60d6c..814668948 100644 --- a/R/model_performance.R +++ b/R/model_performance.R @@ -53,7 +53,10 @@ print.performance_model <- function(x, digits = 3, layout = "horizontal", ...) { # switch to vertical layout if (layout == "vertical") { - formatted_table <- datawizard::rownames_as_column(as.data.frame(t(formatted_table)), "Metric") + formatted_table <- datawizard::rownames_as_column( + as.data.frame(t(formatted_table)), + "Metric" + ) colnames(formatted_table)[2] <- "Value" } diff --git a/R/model_performance.bayesian.R b/R/model_performance.bayesian.R index 1a2d6d509..346c2ebf4 100644 --- a/R/model_performance.bayesian.R +++ b/R/model_performance.bayesian.R @@ -71,7 +71,11 @@ model_performance.stanreg <- function(model, metrics = "all", verbose = TRUE, .. metrics[tolower(metrics) == "log_loss"] <- "LOGLOSS" } - all_metrics <- c("LOOIC", "WAIC", "R2", "R2_adjusted", "ICC", "RMSE", "SIGMA", "LOGLOSS", "SCORE") + # fmt: skip + all_metrics <- c( + "LOOIC", "WAIC", "R2", "R2_adjusted", "ICC", "RMSE", "SIGMA", "LOGLOSS", + "SCORE" + ) if (all(metrics == "all")) { metrics <- all_metrics @@ -79,7 +83,6 @@ model_performance.stanreg <- function(model, metrics = "all", verbose = TRUE, .. metrics <- c("LOOIC", "WAIC", "R2", "RMSE") } - metrics <- toupper(.check_bad_metrics(metrics, all_metrics, verbose)) algorithm <- insight::find_algorithm(model) @@ -194,8 +197,12 @@ model_performance.stanreg <- function(model, metrics = "all", verbose = TRUE, .. if (("SCORE" %in% metrics) && (mi$is_binomial || mi$is_count)) { .scoring_rules <- .safe(performance_score(model, verbose = verbose)) if (!is.null(.scoring_rules)) { - if (!is.na(.scoring_rules$logarithmic)) out$Score_log <- .scoring_rules$logarithmic - if (!is.na(.scoring_rules$spherical)) out$Score_spherical <- .scoring_rules$spherical + if (!is.na(.scoring_rules$logarithmic)) { + out$Score_log <- .scoring_rules$logarithmic + } + if (!is.na(.scoring_rules$spherical)) { + out$Score_spherical <- .scoring_rules$spherical + } } } @@ -220,19 +227,20 @@ model_performance.stanmvreg <- model_performance.stanreg #' @export #' @inheritParams r2_bayes #' @rdname model_performance.stanreg -model_performance.BFBayesFactor <- function(model, - metrics = "all", - verbose = TRUE, - average = FALSE, - prior_odds = NULL, - ...) { +model_performance.BFBayesFactor <- function( + model, + metrics = "all", + verbose = TRUE, + average = FALSE, + prior_odds = NULL, + ... +) { all_metrics <- c("R2", "SIGMA") if (all(metrics == "all")) { metrics <- all_metrics } - metrics <- toupper(.check_bad_metrics(metrics, all_metrics, verbose)) # check for valid BFBayesFactor object @@ -257,7 +265,6 @@ model_performance.BFBayesFactor <- function(model, out <- append(out, as.list(r2_df)) } - if ("SIGMA" %in% toupper(metrics)) { sig <- suppressMessages( .get_sigma_bfbayesfactor( @@ -270,7 +277,6 @@ model_performance.BFBayesFactor <- function(model, out$Sigma <- bayestestR::point_estimate(sig, "median")[[1]] } - out <- as.data.frame(out) row.names(out) <- NULL @@ -283,8 +289,12 @@ model_performance.BFBayesFactor <- function(model, # helper ------------------- - -.get_sigma_bfbayesfactor <- function(model, average = FALSE, prior_odds = NULL, verbose = TRUE) { +.get_sigma_bfbayesfactor <- function( + model, + average = FALSE, + prior_odds = NULL, + verbose = TRUE +) { if (average) { return(.get_sigma_bfbayesfactor_model_average(model, prior_odds = prior_odds)) } @@ -323,7 +333,6 @@ model_performance.BFBayesFactor <- function(model, params <- lapply(params, data.frame) - # Compute posterior model probabilities if (!is.null(prior_odds)) { prior_odds <- c(1, prior_odds) diff --git a/R/model_performance.rma.R b/R/model_performance.rma.R index 2390c25e3..0b587018b 100644 --- a/R/model_performance.rma.R +++ b/R/model_performance.rma.R @@ -60,7 +60,13 @@ #' model <- metafor::rma(yi, vi, data = dat, method = "REML") #' model_performance(model) #' @export -model_performance.rma <- function(model, metrics = "all", estimator = "ML", verbose = TRUE, ...) { +model_performance.rma <- function( + model, + metrics = "all", + estimator = "ML", + verbose = TRUE, + ... +) { if (all(metrics == "all")) { metrics <- c("AIC", "BIC", "I2", "H2", "TAU2", "COCHRANSQ", "OMNIBUS", "R2") } else if (all(metrics == "common")) { diff --git a/R/model_performance_default.R b/R/model_performance_default.R index 2da3edab8..eaf783f09 100644 --- a/R/model_performance_default.R +++ b/R/model_performance_default.R @@ -7,6 +7,7 @@ model_performance.default <- function(model, metrics = "all", verbose = TRUE, .. } # all available options... + # fmt: skip all_metrics <- c("AIC", "BIC", "R2", "R2_adj", "RMSE", "SIGMA", "LOGLOSS", "PCP", "SCORE") if (all(metrics == "all")) { @@ -15,12 +16,15 @@ model_performance.default <- function(model, metrics = "all", verbose = TRUE, .. metrics <- c("AIC", "BIC", "R2", "R2_adj", "RMSE") } - metrics <- .check_bad_metrics(metrics, all_metrics, verbose) if (!insight::is_model(model) || !insight::is_model_supported(model)) { if (isTRUE(verbose)) { - insight::format_warning(paste0("Objects of class `", class(model)[1], "` are not supported model objects.")) + insight::format_warning(paste0( + "Objects of class `", + class(model)[1], + "` are not supported model objects." + )) } return(NULL) } diff --git a/R/performance_accuracy.R b/R/performance_accuracy.R index ed9252ab0..75a4f5aa1 100644 --- a/R/performance_accuracy.R +++ b/R/performance_accuracy.R @@ -35,12 +35,14 @@ #' model <- glm(vs ~ wt + mpg, data = mtcars, family = "binomial") #' performance_accuracy(model) #' @export -performance_accuracy <- function(model, - method = "cv", - k = 5, - n = 1000, - ci = 0.95, - verbose = TRUE) { +performance_accuracy <- function( + model, + method = "cv", + k = 5, + n = 1000, + ci = 0.95, + verbose = TRUE +) { method <- insight::validate_argument(method, c("cv", "boot")) # get formula from model fit @@ -72,17 +74,25 @@ performance_accuracy <- function(model, model_upd }) - predictions <- Map(function(.x, .y) { - stats::predict(.y, newdata = model_data[.x, ]) - }, bootstr, models) + predictions <- Map( + function(.x, .y) { + stats::predict(.y, newdata = model_data[.x, ]) + }, + bootstr, + models + ) response <- lapply(bootstr, function(.x) { as.data.frame(model_data[.x, ])[[resp.name]] }) - accuracy <- mapply(function(.x, .y) { - stats::cor(.x, .y, use = "pairwise.complete.obs") - }, predictions, response) + accuracy <- mapply( + function(.x, .y) { + stats::cor(.x, .y, use = "pairwise.complete.obs") + }, + predictions, + response + ) } else { # accuracy linear models with cross validation @@ -96,17 +106,25 @@ performance_accuracy <- function(model, # stats::lm(formula, data = model_data[.x$train, ]) }) - predictions <- Map(function(.x, .y) { - stats::predict(.y, newdata = model_data[.x$test, ]) - }, cv, models) + predictions <- Map( + function(.x, .y) { + stats::predict(.y, newdata = model_data[.x$test, ]) + }, + cv, + models + ) response <- lapply(cv, function(.x) { as.data.frame(model_data[.x$test, ])[[resp.name]] }) - accuracy <- mapply(function(.x, .y) { - stats::cor(.x, .y, use = "pairwise.complete.obs") - }, predictions, response) + accuracy <- mapply( + function(.x, .y) { + stats::cor(.x, .y, use = "pairwise.complete.obs") + }, + predictions, + response + ) } } else if (info$is_binomial) { measure <- "Area under Curve" @@ -125,18 +143,26 @@ performance_accuracy <- function(model, model_upd }) - predictions <- Map(function(.x, .y) { - stats::predict(.y, newdata = model_data[.x, ], type = "link") - }, bootstr, models) + predictions <- Map( + function(.x, .y) { + stats::predict(.y, newdata = model_data[.x, ], type = "link") + }, + bootstr, + models + ) response <- lapply(bootstr, function(.x) { .recode_to_zero(as.data.frame(model_data[.x, ])[[resp.name]]) }) - accuracy <- mapply(function(.x, .y) { - roc <- performance_roc(x = .x, predictions = .y) - bayestestR::area_under_curve(roc$Specificity, roc$Sensitivity) - }, response, predictions) + accuracy <- mapply( + function(.x, .y) { + roc <- performance_roc(x = .x, predictions = .y) + bayestestR::area_under_curve(roc$Specificity, roc$Sensitivity) + }, + response, + predictions + ) } else { # accuracy linear models with cross validation cv <- .crossv_kfold(model_data, k = k) @@ -149,18 +175,26 @@ performance_accuracy <- function(model, # stats::glm(formula, data = model_data[.x$train, ], family = stats::binomial(link = "logit")) }) - predictions <- Map(function(.x, .y) { - stats::predict(.y, newdata = model_data[.x$test, ], type = "link") - }, cv, models) + predictions <- Map( + function(.x, .y) { + stats::predict(.y, newdata = model_data[.x$test, ], type = "link") + }, + cv, + models + ) response <- lapply(cv, function(.x) { .recode_to_zero(as.data.frame(model_data[.x$test, ])[[resp.name]]) }) - accuracy <- mapply(function(.x, .y) { - roc <- performance_roc(x = .x, predictions = .y) - bayestestR::area_under_curve(roc$Specificity, roc$Sensitivity) - }, response, predictions) + accuracy <- mapply( + function(.x, .y) { + roc <- performance_roc(x = .x, predictions = .y) + bayestestR::area_under_curve(roc$Specificity, roc$Sensitivity) + }, + response, + predictions + ) } if (anyNA(accuracy)) { diff --git a/R/r2_nakagawa.R b/R/r2_nakagawa.R index 03fcb092f..ed75033df 100644 --- a/R/r2_nakagawa.R +++ b/R/r2_nakagawa.R @@ -90,17 +90,19 @@ #' r2_nakagawa(model) #' r2_nakagawa(model, by_group = TRUE) #' @export -r2_nakagawa <- function(model, - by_group = FALSE, - tolerance = 1e-8, - ci = NULL, - iterations = 100, - ci_method = NULL, - null_model = NULL, - approximation = "lognormal", - model_component = NULL, - verbose = TRUE, - ...) { +r2_nakagawa <- function( + model, + by_group = FALSE, + tolerance = 1e-8, + ci = NULL, + iterations = 100, + ci_method = NULL, + null_model = NULL, + approximation = "lognormal", + model_component = NULL, + verbose = TRUE, + ... +) { # calculate random effect variances vars <- .compute_random_vars( model, @@ -123,11 +125,15 @@ r2_nakagawa <- function(model, if (isTRUE(by_group)) { # with random slopes, explained variance is inaccurate if (!is.null(insight::find_random_slopes(model)) && verbose) { - insight::format_warning("Model contains random slopes. Explained variance by levels is not accurate.") + insight::format_warning( + "Model contains random slopes. Explained variance by levels is not accurate." + ) } if (!is.null(ci) && !is.na(ci) && verbose) { - insight::format_warning("Confidence intervals are not yet supported for `by_group = TRUE`.") + insight::format_warning( + "Confidence intervals are not yet supported for `by_group = TRUE`." + ) } # null-model @@ -147,7 +153,8 @@ r2_nakagawa <- function(model, group_names <- insight::find_random(model, split_nested = TRUE, flatten = TRUE) # compute r2 by level - r2_random <- 1 - (vars$var.intercept[group_names] / vars_null$var.intercept[group_names]) + r2_random <- 1 - + (vars$var.intercept[group_names] / vars_null$var.intercept[group_names]) r2_fixed <- 1 - (vars$var.residual / vars_null$var.residual) out <- data.frame( @@ -162,13 +169,18 @@ r2_nakagawa <- function(model, if (insight::is_empty_object(vars$var.random) || is.na(vars$var.random)) { if (verbose) { # if no random effect variance, return simple R2 - insight::print_color("Random effect variances not available. Returned R2 does not account for random effects.\n", "red") # nolint + insight::print_color( + "Random effect variances not available. Returned R2 does not account for random effects.\n", + "red" + ) # nolint } r2_marginal <- vars$var.fixed / (vars$var.fixed + vars$var.residual) r2_conditional <- NA } else { - r2_marginal <- vars$var.fixed / (vars$var.fixed + vars$var.random + vars$var.residual) - r2_conditional <- (vars$var.fixed + vars$var.random) / (vars$var.fixed + vars$var.random + vars$var.residual) + r2_marginal <- vars$var.fixed / + (vars$var.fixed + vars$var.random + vars$var.residual) + r2_conditional <- (vars$var.fixed + vars$var.random) / + (vars$var.fixed + vars$var.random + vars$var.residual) } names(r2_conditional) <- "Conditional R2" @@ -266,10 +278,20 @@ print.r2_nakagawa <- function(x, digits = 3, ...) { # add CI if (length(x$R2_conditional) == 3) { - out[1] <- .add_r2_ci_to_print(out[1], x$R2_conditional[2], x$R2_conditional[3], digits = digits) + out[1] <- .add_r2_ci_to_print( + out[1], + x$R2_conditional[2], + x$R2_conditional[3], + digits = digits + ) } if (length(x$R2_marginal) == 3) { - out[2] <- .add_r2_ci_to_print(out[2], x$R2_marginal[2], x$R2_marginal[3], digits = digits) + out[2] <- .add_r2_ci_to_print( + out[2], + x$R2_marginal[2], + x$R2_marginal[3], + digits = digits + ) } # separate lines for multiple R2 @@ -301,7 +323,8 @@ print.r2_nakagawa <- function(x, digits = 3, ...) { } else { c( vars$var.fixed / (vars$var.fixed + vars$var.random + vars$var.residual), - (vars$var.fixed + vars$var.random) / (vars$var.fixed + vars$var.random + vars$var.residual) + (vars$var.fixed + vars$var.random) / + (vars$var.fixed + vars$var.random + vars$var.residual) ) } } @@ -322,14 +345,17 @@ print.r2_nakagawa <- function(x, digits = 3, ...) { } else { c( vars$var.fixed / (vars$var.fixed + vars$var.random + vars$var.residual), - (vars$var.fixed + vars$var.random) / (vars$var.fixed + vars$var.random + vars$var.residual) + (vars$var.fixed + vars$var.random) / + (vars$var.fixed + vars$var.random + vars$var.residual) ) } } # main bootstrap function .bootstrap_r2_nakagawa <- function(model, iterations, tolerance, ci_method = NULL, ...) { - if (inherits(model, c("merMod", "lmerMod", "glmmTMB")) && !identical(ci_method, "boot")) { + if ( + inherits(model, c("merMod", "lmerMod", "glmmTMB")) && !identical(ci_method, "boot") + ) { result <- .do_lme4_bootmer( model, .boot_r2_fun_lme4, diff --git a/man/check_distribution.Rd b/man/check_distribution.Rd index ade233871..50684a91f 100644 --- a/man/check_distribution.Rd +++ b/man/check_distribution.Rd @@ -26,11 +26,11 @@ following): \code{"bernoulli"}, \code{"beta"}, \code{"beta-binomial"}, \code{"bi \code{"inverse-gamma"}, \code{"lognormal"}, \code{"normal"}, \code{"negative binomial"}, \code{"negative binomial (zero-inflated)"}, \code{"pareto"}, \code{"poisson"}, \code{"poisson (zero-inflated)"}, \code{"tweedie"}, \code{"uniform"} and \code{"weibull"}. -\cr \cr + Note the similarity between certain distributions according to shape, skewness, etc. Thus, the predicted distribution may not be perfectly representing the distributional family of the underlying fitted model, or the response value. -\cr \cr + There is a \code{plot()} method, which shows the probabilities of all predicted distributions, however, only if the probability is greater than zero. } @@ -38,7 +38,7 @@ distributions, however, only if the probability is greater than zero. This function is somewhat experimental and might be improved in future releases. The final decision on the model-family should also be based on theoretical aspects and other information about the data and the model. -\cr \cr + There is also a \href{https://easystats.github.io/see/articles/performance.html}{\code{plot()}-method} implemented in the diff --git a/man/check_outliers.Rd b/man/check_outliers.Rd index db5f0a377..f3adce703 100644 --- a/man/check_outliers.Rd +++ b/man/check_outliers.Rd @@ -386,15 +386,15 @@ In 2008 Eighth IEEE International Conference on Data Mining (pp. 413-422). IEEE. \item Lüdecke, D., Ben-Shachar, M. S., Patil, I., Waggoner, P., and Makowski, D. (2021). performance: An R package for assessment, comparison and testing of -statistical models. \emph{Journal of Open Source Software}, \emph{6}(60), 3139. +statistical models. Journal of Open Source Software, 6(60), 3139. \doi{10.21105/joss.03139} \item Thériault, R., Ben-Shachar, M. S., Patil, I., Lüdecke, D., Wiernik, B. M., and Makowski, D. (2023). Check your outliers! An introduction to identifying -statistical outliers in R with easystats. \emph{Behavior Research Methods}, 1-11. +statistical outliers in R with easystats. Behavior Research Methods, 1-11. \doi{10.3758/s13428-024-02356-w} \item Rousseeuw, P. J., and Van Zomeren, B. C. (1990). Unmasking multivariate -outliers and leverage points. \emph{Journal of the American Statistical -association}, \emph{85}(411), 633-639. +outliers and leverage points. Journal of the American Statistical +association, 85(411), 633-639. } } \seealso{ From c4be179f5a39f622f0faa153fd8421cf22459117 Mon Sep 17 00:00:00 2001 From: Daniel Date: Wed, 8 Oct 2025 11:40:13 +0200 Subject: [PATCH 08/12] fix --- R/check_autocorrelation.R | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/R/check_autocorrelation.R b/R/check_autocorrelation.R index 96472e0f9..82d59f37f 100644 --- a/R/check_autocorrelation.R +++ b/R/check_autocorrelation.R @@ -56,14 +56,22 @@ check_autocorrelation.default <- function(x, nsim = 1000, ...) { } +#' @rdname check_autocorrelation #' @export -check_autocorrelation.performance_simres <- function(x, ...) { +check_autocorrelation.performance_simres <- function(x, time = NULL, ...) { insight::check_if_installed("DHARMa") + if (is.null(time)) { + insight::format_warning( + "Data are assumed to be ordered by time. If this is not the case, please provide a `time` argument." + ) + time <- seq_along(x$scaledResiduals) + } + # Use DHARMa's temporal autocorrelation test # This requires the residuals to be ordered by time # DHARMa::testTemporalAutocorrelation expects a DHARMa object - result <- DHARMa::testTemporalAutocorrelation(x, plot = FALSE, ...) + result <- DHARMa::testTemporalAutocorrelation(x, time = time, plot = FALSE, ...) # Extract p-value from the result p.val <- result$p.value From b9724d44be5c2a631e9d6e0c7eb0608477ded54c Mon Sep 17 00:00:00 2001 From: Daniel Date: Wed, 8 Oct 2025 11:41:30 +0200 Subject: [PATCH 09/12] rd --- R/check_autocorrelation.R | 5 +++-- man/check_autocorrelation.Rd | 9 +++++++-- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/R/check_autocorrelation.R b/R/check_autocorrelation.R index 82d59f37f..ae3ca5c48 100644 --- a/R/check_autocorrelation.R +++ b/R/check_autocorrelation.R @@ -6,9 +6,10 @@ #' #' @param x A model object, or an object returned by `simulate_residuals()`. #' @param nsim Number of simulations for the Durbin-Watson-Test. +#' @param time A vector with time values to specify the temporal order of the data. +#' Only used if `x` is an object returned by `simulate_residuals()` or by `DHARMa`. #' @param ... Currently not used for models. For simulated residuals, arguments are -#' passed to `DHARMa::testTemporalAutocorrelation()`, which can include `time` (a -#' vector with time values) to specify the temporal order of the data. +#' passed to `DHARMa::testTemporalAutocorrelation()`. #' #' @return Invisibly returns the p-value of the test statistics. A p-value < 0.05 #' indicates autocorrelated residuals. diff --git a/man/check_autocorrelation.Rd b/man/check_autocorrelation.Rd index 7ba5e2805..c9bc79ba6 100644 --- a/man/check_autocorrelation.Rd +++ b/man/check_autocorrelation.Rd @@ -3,20 +3,25 @@ \name{check_autocorrelation} \alias{check_autocorrelation} \alias{check_autocorrelation.default} +\alias{check_autocorrelation.performance_simres} \title{Check model for independence of residuals.} \usage{ check_autocorrelation(x, ...) \method{check_autocorrelation}{default}(x, nsim = 1000, ...) + +\method{check_autocorrelation}{performance_simres}(x, time = NULL, ...) } \arguments{ \item{x}{A model object, or an object returned by \code{simulate_residuals()}.} \item{...}{Currently not used for models. For simulated residuals, arguments are -passed to \code{DHARMa::testTemporalAutocorrelation()}, which can include \code{time} (a -vector with time values) to specify the temporal order of the data.} +passed to \code{DHARMa::testTemporalAutocorrelation()}.} \item{nsim}{Number of simulations for the Durbin-Watson-Test.} + +\item{time}{A vector with time values to specify the temporal order of the data. +Only used if \code{x} is an object returned by \code{simulate_residuals()} or by \code{DHARMa}.} } \value{ Invisibly returns the p-value of the test statistics. A p-value < 0.05 From 46f791c0ad872513836ea062b8f6224fe21f39d7 Mon Sep 17 00:00:00 2001 From: Daniel Date: Wed, 8 Oct 2025 11:43:44 +0200 Subject: [PATCH 10/12] fix test --- tests/testthat/test-check_autocorrelation_simres.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-check_autocorrelation_simres.R b/tests/testthat/test-check_autocorrelation_simres.R index 8a1bef33a..9c58e1153 100644 --- a/tests/testthat/test-check_autocorrelation_simres.R +++ b/tests/testthat/test-check_autocorrelation_simres.R @@ -35,13 +35,15 @@ test_that("check_autocorrelation.DHARMa works", { set.seed(123) simres <- DHARMa::simulateResiduals(m, plot = FALSE) + expect_warning(check_autocorrelation(simres), regex = "Data are assumed") set.seed(123) - out <- check_autocorrelation(simres) + expect_silent({ + out <- check_autocorrelation(simres, time = seq_along(simres$scaledResiduals)) + }) # Should return a p-value expect_type(out, "double") expect_s3_class(out, "check_autocorrelation") - # P-value should be between 0 and 1 - expect_true(out >= 0 && out <= 1) + expect_equal(as.vector(out), 0.4163168, tolerance = 1e-3, ignore_attr = TRUE) }) From eb02e37ae7b33c0a4b159ea3f20e152320ee54f6 Mon Sep 17 00:00:00 2001 From: Daniel Date: Wed, 8 Oct 2025 11:52:15 +0200 Subject: [PATCH 11/12] fix --- tests/testthat/test-check_autocorrelation_simres.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-check_autocorrelation_simres.R b/tests/testthat/test-check_autocorrelation_simres.R index 9c58e1153..fa2479032 100644 --- a/tests/testthat/test-check_autocorrelation_simres.R +++ b/tests/testthat/test-check_autocorrelation_simres.R @@ -14,7 +14,9 @@ test_that("check_autocorrelation works with simulated residuals", { # Check autocorrelation set.seed(123) - out <- check_autocorrelation(simres) + expect_warning({ + out <- check_autocorrelation(simres) + }) # Should return a p-value expect_type(out, "double") From 04afa5d10134df19e2ef055312a85d41835b52b8 Mon Sep 17 00:00:00 2001 From: Daniel Date: Wed, 8 Oct 2025 12:36:16 +0200 Subject: [PATCH 12/12] air --- R/check_homogeneity.R | 38 +- R/check_model_diagnostics.R | 94 +++- R/check_predictions.R | 138 +++-- R/check_residuals.R | 26 +- R/check_singularity.R | 6 +- R/check_sphericity.R | 14 +- R/check_symmetry.R | 10 +- R/compare_performance.R | 101 +++- R/cronbachs_alpha.R | 4 +- R/display.R | 8 +- R/format.R | 7 +- R/get_gradients.R | 21 +- R/helpers.R | 7 +- R/icc.R | 113 ++-- R/item_difficulty.R | 28 +- R/item_discrimination.R | 42 +- R/item_omega.R | 52 +- R/item_reliability.R | 13 +- R/model_performance.bife.R | 8 +- R/model_performance.ivreg.R | 20 +- R/model_performance.kmeans.R | 7 +- R/model_performance.lavaan.R | 43 +- R/model_performance.lm.R | 59 +- R/model_performance.mixed.R | 37 +- R/model_performance.psych.R | 55 +- R/performance_aicc.R | 60 +- R/performance_cv.R | 127 +++-- R/performance_logloss.R | 8 +- R/performance_mse.R | 4 +- R/performance_pcp.R | 64 ++- R/performance_reliability.R | 14 +- R/performance_rmse.R | 32 +- R/performance_roc.R | 21 +- R/performance_rse.R | 5 +- R/performance_score.R | 57 +- R/print-methods.R | 45 +- R/print_md.R | 69 ++- R/r2.R | 82 ++- R/r2_bayes.R | 40 +- R/r2_ci.R | 27 +- R/r2_coxsnell.R | 29 +- R/r2_efron.R | 7 +- R/r2_ferarri.R | 1 - R/r2_loo.R | 4 +- R/r2_mcfadden.R | 19 +- R/r2_mckelvey.R | 10 +- R/r2_mlm.R | 9 +- R/r2_nagelkerke.R | 24 +- R/r2_xu.R | 4 +- R/residuals.R | 7 +- R/simulate_residuals.R | 17 +- R/test_bf.R | 15 +- R/test_likelihoodratio.R | 63 ++- R/test_performance.R | 76 ++- R/test_vuong.R | 34 +- R/test_wald.R | 18 +- R/zzz-deprecated-check_heterogeneity_bias.R | 49 +- WIP/generate_distribution.R | 43 +- WIP/r2mlm_init.R | 14 +- WIP/r2mlm_test.R | 34 +- WIP/r2mlm_utils.R | 19 - WIP/test-model_performance.survey.R | 9 +- tests/testthat/test-binned_residuals.R | 427 ++++++++++++-- tests/testthat/test-check_collinearity.R | 94 +++- tests/testthat/test-check_convergence.R | 4 +- tests/testthat/test-check_dag.R | 19 +- tests/testthat/test-check_distribution.R | 72 ++- tests/testthat/test-check_group_variation.R | 144 ++++- tests/testthat/test-check_homogeneity.R | 19 +- tests/testthat/test-check_itemscale.R | 14 +- tests/testthat/test-check_model.R | 129 ++++- tests/testthat/test-check_normality.R | 14 +- tests/testthat/test-check_outliers.R | 96 +++- tests/testthat/test-check_predictions.R | 254 +++++++-- tests/testthat/test-check_residuals.R | 14 +- tests/testthat/test-check_singularity.R | 3 +- tests/testthat/test-check_sphericity.R | 11 +- tests/testthat/test-compare_performance.R | 87 ++- tests/testthat/test-coxph.R | 7 +- tests/testthat/test-cronbachs_alpha.R | 12 +- tests/testthat/test-glmmPQL.R | 18 +- tests/testthat/test-icc.R | 31 +- tests/testthat/test-item_difficulty.R | 4 +- tests/testthat/test-item_discrimination.R | 31 +- tests/testthat/test-mclogit.R | 6 +- .../testthat/test-model_performance-various.R | 13 +- .../test-model_performance.bayesian.R | 45 +- .../testthat/test-model_performance.kmeans.R | 10 +- .../testthat/test-model_performance.lavaan.R | 29 +- tests/testthat/test-model_performance.lm.R | 30 +- .../testthat/test-model_performance.merMod.R | 30 +- tests/testthat/test-model_performance.psych.R | 12 +- tests/testthat/test-model_performance.rma.R | 62 ++- tests/testthat/test-nestedLogit.R | 10 +- tests/testthat/test-performance_reliability.R | 1 - tests/testthat/test-performance_roc.R | 97 +++- tests/testthat/test-pkg-fixest.R | 6 +- tests/testthat/test-pkg-ivreg.R | 5 +- tests/testthat/test-r2.R | 6 +- tests/testthat/test-r2_bayes.R | 7 +- tests/testthat/test-r2_coxsnell.R | 6 +- tests/testthat/test-r2_ferrari.R | 14 +- tests/testthat/test-r2_kullback.R | 6 +- tests/testthat/test-r2_mcfadden.R | 3 +- tests/testthat/test-r2_nagelkerke.R | 19 +- tests/testthat/test-r2_nakagawa.R | 522 ++++++++++++++++-- tests/testthat/test-rmse.R | 6 +- tests/testthat/test-roc.R | 6 +- tests/testthat/test-test_likelihoodratio.R | 15 +- tests/testthat/test-test_performance.R | 6 +- 110 files changed, 3560 insertions(+), 1027 deletions(-) diff --git a/R/check_homogeneity.R b/R/check_homogeneity.R index b06e4f434..43a7f205f 100644 --- a/R/check_homogeneity.R +++ b/R/check_homogeneity.R @@ -71,14 +71,18 @@ check_homogeneity.default <- function(x, method = "bartlett", ...) { ) if (is.null(check)) { - insight::print_color("'check_homogeneity()' cannot perform check for normality. Please specify the 'method'-argument for the test of equal variances.\n", "red") # nolint + insight::print_color( + "'check_homogeneity()' cannot perform check for normality. Please specify the 'method'-argument for the test of equal variances.\n", + "red" + ) # nolint return(NULL) } method <- ifelse(check < 0.05, "fligner", "bartlett") } - if (method == "fligner") { # nolint + if (method == "fligner") { + # nolint r <- stats::fligner.test(f, data = insight::get_data(x, verbose = FALSE)) p.val <- r$p.value } else if (method == "bartlett") { @@ -90,8 +94,8 @@ check_homogeneity.default <- function(x, method = "bartlett", ...) { p.val <- r$`Pr(>F)` } - - method.string <- switch(method, + method.string <- switch( + method, bartlett = "Bartlett Test", fligner = "Fligner-Killeen Test", levene = "Levene's Test" @@ -115,9 +119,23 @@ print.check_homogeneity <- function(x, ...) { insight::format_warning(paste0("Could not perform ", method.string, ".")) invisible(NULL) } else if (x < 0.05) { - insight::print_color(sprintf("Warning: Variances differ between groups (%s, p = %.3f).\n", method.string, x), "red") + insight::print_color( + sprintf( + "Warning: Variances differ between groups (%s, p = %.3f).\n", + method.string, + x + ), + "red" + ) } else { - insight::print_color(sprintf("OK: There is not clear evidence for different variances across groups (%s, p = %.3f).\n", method.string, x), "green") # nolint + insight::print_color( + sprintf( + "OK: There is not clear evidence for different variances across groups (%s, p = %.3f).\n", + method.string, + x + ), + "green" + ) # nolint } invisible(x) } @@ -138,11 +156,15 @@ check_homogeneity.afex_aov <- function(x, method = "levene", ...) { insight::check_if_installed("car") if (tolower(method) != "levene") { - insight::format_alert("Only Levene's test for homogeneity supported for `afex_aov()`.") + insight::format_alert( + "Only Levene's test for homogeneity supported for `afex_aov()`." + ) } if (length(attr(x, "between")) == 0) { - insight::format_error("Levene test is only aplicable to ANOVAs with between-subjects factors.") + insight::format_error( + "Levene test is only aplicable to ANOVAs with between-subjects factors." + ) } long_data <- x$data$long # Use this to also get id column diff --git a/R/check_model_diagnostics.R b/R/check_model_diagnostics.R index f6dd7cde2..9791ac01f 100644 --- a/R/check_model_diagnostics.R +++ b/R/check_model_diagnostics.R @@ -66,7 +66,10 @@ return(NULL) } - if (inherits(model, c("glm", "glmerMod")) || (inherits(model, "glmmTMB") && isFALSE(model_info$is_linear))) { + if ( + inherits(model, c("glm", "glmerMod")) || + (inherits(model, "glmmTMB") && isFALSE(model_info$is_linear)) + ) { fitted_ <- stats::qnorm((stats::ppoints(length(res_)) + 1) / 2) } else { fitted_ <- stats::fitted(model) @@ -89,7 +92,12 @@ # prepare data for random effects QQ plot ---------------------------------- -.model_diagnostic_ranef_qq <- function(model, level = 0.95, model_info = NULL, verbose = TRUE) { +.model_diagnostic_ranef_qq <- function( + model, + level = 0.95, + model_info = NULL, + verbose = TRUE +) { # check if we have mixed model if (is.null(model_info) || !model_info$is_mixed) { return(NULL) @@ -110,7 +118,6 @@ } ) - se <- tryCatch( suppressWarnings(lapply(re, function(.x) { pv <- attr(.x, var_attr, exact = TRUE) @@ -124,28 +131,34 @@ if (is.null(se)) { if (verbose) { - insight::format_alert("Could not compute standard errors from random effects for diagnostic plot.") + insight::format_alert( + "Could not compute standard errors from random effects for diagnostic plot." + ) } return(NULL) } - - Map(function(.re, .se) { - ord <- unlist(lapply(.re, order)) + rep((0:(ncol(.re) - 1)) * nrow(.re), each = nrow(.re)) - - df.y <- unlist(.re)[ord] - df.ci <- stats::qnorm((1 + level) / 2) * .se[ord] - - data.frame( - x = rep(stats::qnorm(stats::ppoints(nrow(.re))), ncol(.re)), - y = df.y, - conf.low = df.y - df.ci, - conf.high = df.y + df.ci, - facet = gl(ncol(.re), nrow(.re), labels = names(.re)), - stringsAsFactors = FALSE, - row.names = NULL - ) - }, re, se) + Map( + function(.re, .se) { + ord <- unlist(lapply(.re, order)) + + rep((0:(ncol(.re) - 1)) * nrow(.re), each = nrow(.re)) + + df.y <- unlist(.re)[ord] + df.ci <- stats::qnorm((1 + level) / 2) * .se[ord] + + data.frame( + x = rep(stats::qnorm(stats::ppoints(nrow(.re))), ncol(.re)), + y = df.y, + conf.low = df.y - df.ci, + conf.high = df.y + df.ci, + facet = gl(ncol(.re), nrow(.re), labels = names(.re)), + stringsAsFactors = FALSE, + row.names = NULL + ) + }, + re, + se + ) } @@ -163,7 +176,11 @@ } dat <- as.data.frame(bayestestR::estimate_density(r)) - dat$curve <- stats::dnorm(seq(min(dat$x), max(dat$x), length.out = nrow(dat)), mean(r), stats::sd(r)) + dat$curve <- stats::dnorm( + seq(min(dat$x), max(dat$x), length.out = nrow(dat)), + mean(r), + stats::sd(r) + ) dat } @@ -198,7 +215,9 @@ ) plot_data$Index <- seq_len(nrow(plot_data)) plot_data$Influential <- "OK" - plot_data$Influential[abs(plot_data$Cooks_Distance) >= max(cook_levels)] <- "Influential" + plot_data$Influential[ + abs(plot_data$Cooks_Distance) >= max(cook_levels) + ] <- "Influential" attr(plot_data, "cook_levels") <- cook_levels attr(plot_data, "n_params") <- n_params @@ -304,7 +323,8 @@ d$V <- insight::get_sigma(model)^2 * stats::family(model)$variance(predicted) } else { # for nbinom2, "sigma()" has "inverse meaning" (see #654) - d$V <- (1 / insight::get_sigma(model)^2) * stats::family(model)$variance(predicted) + d$V <- (1 / insight::get_sigma(model)^2) * + stats::family(model)$variance(predicted) } } else { ## FIXME: this is not correct for glm.nb models? @@ -332,7 +352,10 @@ } d$Prob <- stats::predict(model, type = ptype) d$Disp <- insight::get_sigma(model) - d$V <- predicted * (1 + predicted / d$Disp) * (1 - d$Prob) * (1 + predicted * (1 + predicted / d$Disp) * d$Prob) # nolint + d$V <- predicted * + (1 + predicted / d$Disp) * + (1 - d$Prob) * + (1 + predicted * (1 + predicted / d$Disp) * d$Prob) # nolint } # data for zero-inflated negative binomial models with dispersion @@ -345,7 +368,10 @@ } d$Prob <- stats::predict(model, type = ptype) d$Disp <- stats::predict(model, type = "disp") - d$V <- predicted * (1 + predicted / d$Disp) * (1 - d$Prob) * (1 + predicted * (1 + predicted / d$Disp) * d$Prob) # nolint + d$V <- predicted * + (1 + predicted / d$Disp) * + (1 - d$Prob) * + (1 + predicted * (1 + predicted / d$Disp) * d$Prob) # nolint } d @@ -376,7 +402,8 @@ d$V <- insight::get_sigma(model)^2 * stats::family(model)$variance(d$Predicted) } else { # for nbinom2, "sigma()" has "inverse meaning" (see #654) - d$V <- (1 / insight::get_sigma(model)^2) * stats::family(model)$variance(d$Predicted) + d$V <- (1 / insight::get_sigma(model)^2) * + stats::family(model)$variance(d$Predicted) } } else { ## FIXME: this is not correct for glm.nb models? @@ -415,7 +442,10 @@ } d$Prob <- stats::predict(model, type = ptype) d$Disp <- insight::get_sigma(model) - d$V <- d$Predicted * (1 + d$Predicted / d$Disp) * (1 - d$Prob) * (1 + d$Predicted * (1 + d$Predicted / d$Disp) * d$Prob) # nolint + d$V <- d$Predicted * + (1 + d$Predicted / d$Disp) * + (1 - d$Prob) * + (1 + d$Predicted * (1 + d$Predicted / d$Disp) * d$Prob) # nolint d$StdRes <- insight::get_residuals(model, type = "pearson") } @@ -431,7 +461,10 @@ } d$Prob <- stats::predict(model, type = ptype) d$Disp <- stats::predict(model, type = "disp") - d$V <- d$Predicted * (1 + d$Predicted / d$Disp) * (1 - d$Prob) * (1 + d$Predicted * (1 + d$Predicted / d$Disp) * d$Prob) # nolint + d$V <- d$Predicted * + (1 + d$Predicted / d$Disp) * + (1 - d$Prob) * + (1 + d$Predicted * (1 + d$Predicted / d$Disp) * d$Prob) # nolint d$StdRes <- insight::get_residuals(model, type = "pearson") } @@ -446,7 +479,8 @@ return(1) } betad <- model$fit$par["betadisp"] - switch(faminfo$family, + switch( + faminfo$family, gaussian = exp(0.5 * betad), Gamma = exp(-0.5 * betad), exp(betad) diff --git a/R/check_predictions.R b/R/check_predictions.R index c26b94ead..2fc30f844 100644 --- a/R/check_predictions.R +++ b/R/check_predictions.R @@ -98,14 +98,16 @@ check_predictions <- function(object, ...) { #' @rdname check_predictions #' @export -check_predictions.default <- function(object, - iterations = 50, - check_range = FALSE, - re_formula = NULL, - bandwidth = "nrd", - type = "density", - verbose = TRUE, - ...) { +check_predictions.default <- function( + object, + iterations = 50, + check_range = FALSE, + re_formula = NULL, + bandwidth = "nrd", + type = "density", + verbose = TRUE, + ... +) { .is_model_valid(object) # check_predictions() can't handle exotic formula notation if (verbose) { @@ -120,7 +122,11 @@ check_predictions.default <- function(object, minfo <- insight::model_info(object, verbose = FALSE) # try to find sensible default for "type" argument - suggest_dots <- (minfo$is_bernoulli || minfo$is_count || minfo$is_ordinal || minfo$is_categorical || minfo$is_multinomial) # nolint + suggest_dots <- (minfo$is_bernoulli || + minfo$is_count || + minfo$is_ordinal || + minfo$is_categorical || + minfo$is_multinomial) # nolint if (missing(type) && suggest_dots) { type <- "discrete_interval" } @@ -146,19 +152,25 @@ check_predictions.default <- function(object, #' @export -check_predictions.stanreg <- function(object, - iterations = 50, - check_range = FALSE, - re_formula = NULL, - bandwidth = "nrd", - type = "density", - verbose = TRUE, - ...) { +check_predictions.stanreg <- function( + object, + iterations = 50, + check_range = FALSE, + re_formula = NULL, + bandwidth = "nrd", + type = "density", + verbose = TRUE, + ... +) { # retrieve model information minfo <- insight::model_info(object, verbose = FALSE) # try to find sensible default for "type" argument - suggest_dots <- (minfo$is_bernoulli || minfo$is_count || minfo$is_ordinal || minfo$is_categorical || minfo$is_multinomial) # nolint + suggest_dots <- (minfo$is_bernoulli || + minfo$is_count || + minfo$is_ordinal || + minfo$is_categorical || + minfo$is_multinomial) # nolint if (missing(type) && suggest_dots) { type <- "discrete_interval" } @@ -170,10 +182,7 @@ check_predictions.stanreg <- function(object, ) # convert to type-argument for pp_check - pp_type <- switch(type, - density = "dens", - "bars" - ) + pp_type <- switch(type, density = "dens", "bars") insight::check_if_installed( "bayesplot", @@ -184,9 +193,13 @@ check_predictions.stanreg <- function(object, resp_string <- insight::find_terms(object)$response if (inherits(object, "brmsfit")) { - out <- as.data.frame(bayesplot::pp_check(object, type = pp_type, ndraws = iterations, ...)$data) + out <- as.data.frame( + bayesplot::pp_check(object, type = pp_type, ndraws = iterations, ...)$data + ) } else { - out <- as.data.frame(bayesplot::pp_check(object, type = pp_type, nreps = iterations, ...)$data) + out <- as.data.frame( + bayesplot::pp_check(object, type = pp_type, nreps = iterations, ...)$data + ) } # bring data into shape, like we have for other models with `check_predictions()` @@ -228,13 +241,15 @@ check_predictions.brmsfit <- check_predictions.stanreg #' @export -check_predictions.BFBayesFactor <- function(object, - iterations = 50, - check_range = FALSE, - re_formula = NULL, - bandwidth = "nrd", - verbose = TRUE, - ...) { +check_predictions.BFBayesFactor <- function( + object, + iterations = 50, + check_range = FALSE, + re_formula = NULL, + bandwidth = "nrd", + verbose = TRUE, + ... +) { everything_we_need <- .get_bfbf_predictions(object, iterations = iterations) y <- everything_we_need[["y"]] @@ -265,21 +280,25 @@ pp_check.BFBayesFactor <- check_predictions.BFBayesFactor #' @export check_predictions.lme <- function(object, ...) { - insight::format_error("`check_predictions()` does currently not work for models of class `lme`.") + insight::format_error( + "`check_predictions()` does currently not work for models of class `lme`." + ) } # pp-check functions ------------------------------------- -pp_check.lm <- function(object, - iterations = 50, - check_range = FALSE, - re_formula = NULL, - bandwidth = "nrd", - type = "density", - verbose = TRUE, - model_info = NULL, - ...) { +pp_check.lm <- function( + object, + iterations = 50, + check_range = FALSE, + re_formula = NULL, + bandwidth = "nrd", + type = "density", + verbose = TRUE, + model_info = NULL, + ... +) { # we need the formula and the response values to check for matrix responses # or proportions in binomial models model_response <- insight::find_response(object, combine = TRUE) @@ -287,7 +306,17 @@ pp_check.lm <- function(object, # if we have a matrix-response, continue here... if (grepl("^cbind\\((.*)\\)", model_response) || is.matrix(response_values)) { - return(pp_check.glm(object, iterations, check_range, re_formula, bandwidth, type, verbose, model_info, ...)) + return(pp_check.glm( + object, + iterations, + check_range, + re_formula, + bandwidth, + type, + verbose, + model_info, + ... + )) } # else, proceed as usual @@ -341,14 +370,19 @@ pp_check.lm <- function(object, pattern <- "^(scale|exp|expm1|log|log1p|log10|log2|sqrt)" # check for transformed response, and backtransform simulations - if (!is.null(resp_string) && length(resp_string) == 1 && grepl(paste0(pattern, "\\("), resp_string)) { + if ( + !is.null(resp_string) && + length(resp_string) == 1 && + grepl(paste0(pattern, "\\("), resp_string) + ) { out <- .backtransform_sims(out, resp_string) } # sanity check - do we have a ratio or similar? if (is.data.frame(response)) { # get response data, evaluate formula - response <- eval(str2lang(insight::find_response(object)), + response <- eval( + str2lang(insight::find_response(object)), envir = insight::get_response(object) ) } @@ -462,7 +496,7 @@ pp_check.glm <- function( } -# styler: off +# fmt: skip pp_check.glmmTMB <- pp_check.glm.nb <- pp_check.lme <- @@ -475,7 +509,6 @@ pp_check.glmmTMB <- pp_check.vlm <- pp_check.wbm <- pp_check.lm -# styler: on #' @rawNamespace @@ -493,10 +526,8 @@ pp_check.glmmTMB <- #' S3method(bayesplot::pp_check, wbm) #' S3method(bayesplot::pp_check, BFBayesFactor) - # methods ----------------------- - #' @export print.performance_pp_check <- function(x, verbose = TRUE, ...) { original <- x$y @@ -533,7 +564,8 @@ print.performance_pp_check <- function(x, verbose = TRUE, ...) { ifelse(length(missing_levs) == 1, " ", "s "), paste0("'", missing_levs, "'", collapse = ", "), " from original data is not included in the replicated data." - ), "Model may not capture the variation of the data." + ), + "Model may not capture the variation of the data." ), "red" ) @@ -564,10 +596,14 @@ plot.performance_pp_check <- function(x, ...) { } else if (grepl("log(", resp_string, fixed = TRUE)) { # exceptions: log(x+1) or log(1+x) # 1. try: log(x + number) - plus_minus <- .safe(eval(parse(text = gsub("log\\(([^,\\+)]*)(.*)\\)", "\\2", resp_string)))) + plus_minus <- .safe(eval(parse( + text = gsub("log\\(([^,\\+)]*)(.*)\\)", "\\2", resp_string) + ))) # 2. try: log(number + x) if (is.null(plus_minus)) { - plus_minus <- .safe(eval(parse(text = gsub("log\\(([^,\\+)]*)(.*)\\)", "\\1", resp_string)))) + plus_minus <- .safe(eval(parse( + text = gsub("log\\(([^,\\+)]*)(.*)\\)", "\\1", resp_string) + ))) } if (is.null(plus_minus) || !is.numeric(plus_minus)) { sims[] <- lapply(sims, exp) diff --git a/R/check_residuals.R b/R/check_residuals.R index 0b3a59a24..fdbdaf792 100644 --- a/R/check_residuals.R +++ b/R/check_residuals.R @@ -57,12 +57,18 @@ check_residuals <- function(x, ...) { #' @rdname check_residuals #' @export -check_residuals.default <- function(x, alternative = "two.sided", - distribution = "punif", ...) { +check_residuals.default <- function( + x, + alternative = "two.sided", + distribution = "punif", + ... +) { if (insight::is_model(x)) { check_residuals(simulate_residuals(x, ...), alternative = alternative) } else { - insight::format_error("`check_residuals()` only works with objects supported by `simulate_residuals()` or `DHARMa::simulateResiduals()`.") # nolint + insight::format_error( + "`check_residuals()` only works with objects supported by `simulate_residuals()` or `DHARMa::simulateResiduals()`." + ) # nolint } } @@ -89,8 +95,12 @@ check_residuals.item_omega <- function(x, ...) { #' @export -check_residuals.performance_simres <- function(x, alternative = "two.sided", - distribution = "punif", ...) { +check_residuals.performance_simres <- function( + x, + alternative = "two.sided", + distribution = "punif", + ... +) { alternative <- insight::validate_argument( alternative, c("two.sided", "less", "greater") @@ -126,14 +136,16 @@ print.check_residuals <- function(x, ...) { if (x < 0.05) { insight::print_color( sprintf( - "Warning: Non-uniformity of simulated residuals detected (%s).\n", pstring + "Warning: Non-uniformity of simulated residuals detected (%s).\n", + pstring ), "red" ) } else { insight::print_color( sprintf( - "OK: Simulated residuals appear as uniformly distributed (%s).\n", pstring + "OK: Simulated residuals appear as uniformly distributed (%s).\n", + pstring ), "green" ) diff --git a/R/check_singularity.R b/R/check_singularity.R index 9d8c1b430..b80fe7256 100644 --- a/R/check_singularity.R +++ b/R/check_singularity.R @@ -152,7 +152,8 @@ check_singularity.merMod <- function(x, tolerance = 1e-5, check = "model", ...) FUN.VALUE = logical(1) ) - switch(check, + switch( + check, model = any(unlist(result, use.names = FALSE)), insight::compact_list(result) ) @@ -185,7 +186,8 @@ check_singularity.glmmTMB <- function(x, tolerance = 1e-5, check = "model", ...) names(result[[component]]) <- re_names } - switch(check, + switch( + check, model = any(unlist(result, use.names = FALSE)), insight::compact_list(result) ) diff --git a/R/check_sphericity.R b/R/check_sphericity.R index ed412c5f4..12983bbbb 100644 --- a/R/check_sphericity.R +++ b/R/check_sphericity.R @@ -28,7 +28,11 @@ check_sphericity <- function(x, ...) { #' @export check_sphericity.default <- function(x, ...) { - insight::format_error(paste0("Test not supported yet for object of class `", class(x)[1], "`.")) + insight::format_error(paste0( + "Test not supported yet for object of class `", + class(x)[1], + "`." + )) } @@ -36,7 +40,9 @@ check_sphericity.default <- function(x, ...) { #' @export plot.check_sphericity <- function(x, ...) { - insight::format_warning("There is currently no `plot()` method for `check_sphericity()`.") + insight::format_warning( + "There is currently no `plot()` method for `check_sphericity()`." + ) } @@ -78,7 +84,9 @@ check_sphericity.Anova.mlm <- function(x, ...) { #' @export check_sphericity.afex_aov <- function(x, ...) { if (length(attr(x, "within")) == 0) { - insight::format_error("Mauchly Test of Sphericity is only aplicable to ANOVAs with within-subjects factors.") + insight::format_error( + "Mauchly Test of Sphericity is only aplicable to ANOVAs with within-subjects factors." + ) } check_sphericity.Anova.mlm(x, ...) diff --git a/R/check_symmetry.R b/R/check_symmetry.R index dbe77dac9..ec90f45fc 100644 --- a/R/check_symmetry.R +++ b/R/check_symmetry.R @@ -39,9 +39,15 @@ check_symmetry.numeric <- function(x, ...) { print.check_symmetry <- function(x, ...) { pstring <- insight::format_p(x) if (x < 0.05) { - insight::print_color(sprintf("Warning: Non-symmetry detected (%s).\n", pstring), "red") + insight::print_color( + sprintf("Warning: Non-symmetry detected (%s).\n", pstring), + "red" + ) } else { - insight::print_color(sprintf("OK: Data appears symmetrical (%s).\n", pstring), "green") + insight::print_color( + sprintf("OK: Data appears symmetrical (%s).\n", pstring), + "green" + ) } return(invisible(x)) } diff --git a/R/compare_performance.R b/R/compare_performance.R index 9ba561a3b..5c4a3aea9 100644 --- a/R/compare_performance.R +++ b/R/compare_performance.R @@ -84,15 +84,26 @@ #' compare_performance(m1, m2, m3) #' @inheritParams model_performance.lm #' @export -compare_performance <- function(..., metrics = "all", rank = FALSE, estimator = "ML", verbose = TRUE) { +compare_performance <- function( + ..., + metrics = "all", + rank = FALSE, + estimator = "ML", + verbose = TRUE +) { # process input model_objects <- insight::ellipsis_info(..., only_models = TRUE) # ensure proper object names - model_objects <- .check_objectnames(model_objects, sapply(match.call(expand.dots = FALSE)[["..."]], as.character)) + model_objects <- .check_objectnames( + model_objects, + sapply(match.call(expand.dots = FALSE)[["..."]], as.character) + ) # drop unsupport models - supported_models <- sapply(model_objects, function(i) insight::is_model_supported(i) | inherits(i, "lavaan")) + supported_models <- sapply(model_objects, function(i) { + insight::is_model_supported(i) | inherits(i, "lavaan") + }) object_names <- names(model_objects) if (!all(supported_models)) { @@ -105,13 +116,31 @@ compare_performance <- function(..., metrics = "all", rank = FALSE, estimator = } # iterate over all models, i.e. model-performance for each model - m <- mapply(function(.x, .y) { - dat <- model_performance(.x, metrics = metrics, estimator = estimator, verbose = FALSE) - model_name <- gsub("\"", "", insight::safe_deparse(.y), fixed = TRUE) - perf_df <- data.frame(Name = model_name, Model = class(.x)[1], dat, stringsAsFactors = FALSE) - attributes(perf_df) <- c(attributes(perf_df), attributes(dat)[!names(attributes(dat)) %in% c("names", "row.names", "class")]) - perf_df - }, model_objects, object_names, SIMPLIFY = FALSE) + m <- mapply( + function(.x, .y) { + dat <- model_performance( + .x, + metrics = metrics, + estimator = estimator, + verbose = FALSE + ) + model_name <- gsub("\"", "", insight::safe_deparse(.y), fixed = TRUE) + perf_df <- data.frame( + Name = model_name, + Model = class(.x)[1], + dat, + stringsAsFactors = FALSE + ) + attributes(perf_df) <- c( + attributes(perf_df), + attributes(dat)[!names(attributes(dat)) %in% c("names", "row.names", "class")] + ) + perf_df + }, + model_objects, + object_names, + SIMPLIFY = FALSE + ) attri <- lapply(m, function(x) { attri <- attributes(x) @@ -182,15 +211,17 @@ compare_performance <- function(..., metrics = "all", rank = FALSE, estimator = } # for REML fits, warn user - if (isTRUE(verbose) && - # only warn for REML fit - identical(estimator, "REML") && - # only for IC comparison - any(grepl("(AIC|BIC)", names(dfs))) && - # only when mixed models are involved, others probably don't have problems with REML fit - any(sapply(model_objects, insight::is_mixed_model)) && - # only if not all models have same fixed effects (else, REML is ok) - !isTRUE(attributes(model_objects)$same_fixef)) { + if ( + isTRUE(verbose) && + # only warn for REML fit + identical(estimator, "REML") && + # only for IC comparison + any(grepl("(AIC|BIC)", names(dfs))) && + # only when mixed models are involved, others probably don't have problems with REML fit + any(sapply(model_objects, insight::is_mixed_model)) && + # only if not all models have same fixed effects (else, REML is ok) + !isTRUE(attributes(model_objects)$same_fixef) + ) { insight::format_alert( "Information criteria (like AIC) are based on REML fits (i.e. `estimator=\"REML\"`).", "Please note that information criteria are probably not directly comparable and that it is not recommended comparing models with different fixed effects in such cases." @@ -212,19 +243,37 @@ print.compare_performance <- function(x, digits = 3, layout = "horizontal", ...) formatted_table <- format(x = x, digits = digits, format = "text", ...) if ("Performance_Score" %in% colnames(formatted_table)) { - footer <- c(sprintf("\nModel `%s` (of class `%s`) performed best with an overall performance score of %s.", formatted_table$Model[1], formatted_table$Type[1], formatted_table$Performance_Score[1]), "yellow") + footer <- c( + sprintf( + "\nModel `%s` (of class `%s`) performed best with an overall performance score of %s.", + formatted_table$Model[1], + formatted_table$Type[1], + formatted_table$Performance_Score[1] + ), + "yellow" + ) } else { footer <- NULL } # switch to vertical layout if (layout == "vertical") { - formatted_table <- datawizard::rownames_as_column(as.data.frame(t(formatted_table)), "Metric") + formatted_table <- datawizard::rownames_as_column( + as.data.frame(t(formatted_table)), + "Metric" + ) formatted_table <- datawizard::row_to_colnames(formatted_table) colnames(formatted_table)[1] <- "Metric" } - cat(insight::export_table(x = formatted_table, digits = digits, format = "text", caption = table_caption, footer = footer, ...)) + cat(insight::export_table( + x = formatted_table, + digits = digits, + format = "text", + caption = table_caption, + footer = footer, + ... + )) invisible(x) } @@ -247,7 +296,9 @@ plot.compare_performance <- function(x, ...) { } # set reference for Bayes factors to 1 - if ("BF" %in% colnames(x)) x$BF[is.na(x$BF)] <- 1 + if ("BF" %in% colnames(x)) { + x$BF[is.na(x$BF)] <- 1 + } # don't include test statistic in ranking x$p_CochransQ <- NULL @@ -276,7 +327,9 @@ plot.compare_performance <- function(x, ...) { # normalize indices, for comparison out[] <- lapply(out, function(i) { - if (is.numeric(i)) i <- .normalize_vector(i) + if (is.numeric(i)) { + i <- .normalize_vector(i) + } i }) diff --git a/R/cronbachs_alpha.R b/R/cronbachs_alpha.R index 30329c0ab..1f21e7d40 100644 --- a/R/cronbachs_alpha.R +++ b/R/cronbachs_alpha.R @@ -58,7 +58,9 @@ cronbachs_alpha.data.frame <- function(x, verbose = TRUE, ...) { } # Compute Cronbach's Alpha - dim(.data)[2] / (dim(.data)[2] - 1) * (1 - sum(apply(.data, 2, stats::var)) / stats::var(rowSums(.data))) + dim(.data)[2] / + (dim(.data)[2] - 1) * + (1 - sum(apply(.data, 2, stats::var)) / stats::var(rowSums(.data))) } diff --git a/R/display.R b/R/display.R index 7fd87639e..6be043a7c 100644 --- a/R/display.R +++ b/R/display.R @@ -36,7 +36,13 @@ #' mp <- model_performance(model) #' display(mp) #' @export -display.performance_model <- function(object, format = "markdown", digits = 2, caption = NULL, ...) { +display.performance_model <- function( + object, + format = "markdown", + digits = 2, + caption = NULL, + ... +) { format <- .display_default_format(format) if (format %in% c("html", "tt")) { print_html( diff --git a/R/format.R b/R/format.R index 36a3b2cd7..23dd81864 100644 --- a/R/format.R +++ b/R/format.R @@ -9,7 +9,12 @@ format.compare_performance <- function(x, digits = 2, ...) { # format weighted ICs weighted_ics <- endsWith(colnames(x), "_wt") if (any(weighted_ics)) { - x[weighted_ics] <- lapply(x[weighted_ics], insight::format_bf, name = NULL, exact = TRUE) + x[weighted_ics] <- lapply( + x[weighted_ics], + insight::format_bf, + name = NULL, + exact = TRUE + ) } if ("BF" %in% colnames(x)) { diff --git a/R/get_gradients.R b/R/get_gradients.R index 4aa017dc4..085740399 100644 --- a/R/get_gradients.R +++ b/R/get_gradients.R @@ -24,7 +24,11 @@ }, error = function(e) { insight::format_error( - paste0("Could not compute gradients from a model object of class `", class(x)[1], "`."), + paste0( + "Could not compute gradients from a model object of class `", + class(x)[1], + "`." + ), "Please try a different test-function, or file an issue at {.url https://github.com/easystats/performance/issues}." ) } @@ -33,26 +37,31 @@ .get_gradients.lmerMod <- function(x, ...) { - insight::get_residuals(x) * insight::get_weights(x, null_as_ones = TRUE) * insight::get_modelmatrix(x) + insight::get_residuals(x) * + insight::get_weights(x, null_as_ones = TRUE) * + insight::get_modelmatrix(x) } .get_gradients.glmerMod <- function(x, ...) { - w <- as.vector(insight::get_residuals(x, "working")) * insight::get_weights(x, "working") + w <- as.vector(insight::get_residuals(x, "working")) * + insight::get_weights(x, "working") w * insight::get_modelmatrix(x) / insight::get_auxiliary(x, type = "dispersion") } .get_gradients.glmmTMB <- function(x, ...) { if (insight::model_info(x)$is_linear) { - insight::get_residuals(x) * insight::get_weights(x, null_as_ones = TRUE) * insight::get_modelmatrix(x) + insight::get_residuals(x) * + insight::get_weights(x, null_as_ones = TRUE) * + insight::get_modelmatrix(x) } else { - w <- as.vector(insight::get_residuals(x)) * insight::get_weights(x, null_as_ones = TRUE) + w <- as.vector(insight::get_residuals(x)) * + insight::get_weights(x, null_as_ones = TRUE) w * insight::get_modelmatrix(x) / insight::get_auxiliary(x, type = "dispersion") } } - # .get_gradients.lm <- .get_gradients.lmer # # .get_gradients.glm <- function(x, ...) { diff --git a/R/helpers.R b/R/helpers.R index 5c4d97b03..96feb19a4 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -22,7 +22,12 @@ out <- .adjust_ic_jacobian(x, stats::BIC(x)[["BIC"]]) } else { out <- .safe( - stats::BIC(insight::get_loglikelihood(x, check_response = TRUE, REML = REML, verbose = FALSE)) + stats::BIC(insight::get_loglikelihood( + x, + check_response = TRUE, + REML = REML, + verbose = FALSE + )) ) # when `get_loglikelihood()` does not work, `stats::BIC` sometimes still works (e.g., `fixest`) if (is.null(out)) { diff --git a/R/icc.R b/R/icc.R index 937e47568..25493cf55 100644 --- a/R/icc.R +++ b/R/icc.R @@ -172,17 +172,19 @@ #' ) #' icc(model, by_group = TRUE) #' @export -icc <- function(model, - by_group = FALSE, - tolerance = 1e-05, - ci = NULL, - iterations = 100, - ci_method = NULL, - null_model = NULL, - approximation = "lognormal", - model_component = NULL, - verbose = TRUE, - ...) { +icc <- function( + model, + by_group = FALSE, + tolerance = 1e-05, + ci = NULL, + iterations = 100, + ci_method = NULL, + null_model = NULL, + approximation = "lognormal", + model_component = NULL, + verbose = TRUE, + ... +) { # special handling for smicd::semLme() if (inherits(model, "sem") && inherits(model, "lme")) { return(model$icc) @@ -233,13 +235,14 @@ icc <- function(model, } if (!is.null(ci) && !is.na(ci) && verbose) { - insight::format_alert("Confidence intervals are not yet supported for `by_group = TRUE`.") + insight::format_alert( + "Confidence intervals are not yet supported for `by_group = TRUE`." + ) } # icc per group factor with reference to overall model icc_overall <- vars$var.intercept / (vars$var.random + vars$var.residual) - out <- data.frame( Group = names(icc_overall), ICC = unname(icc_overall), @@ -267,7 +270,8 @@ icc <- function(model, } else { # Calculate ICC values icc_adjusted <- vars$var.random / (vars$var.random + vars$var.residual) - icc_unadjusted <- vars$var.random / (vars$var.fixed + vars$var.random + vars$var.residual) + icc_unadjusted <- vars$var.random / + (vars$var.fixed + vars$var.random + vars$var.residual) out <- data.frame( ICC_adjusted = icc_adjusted, @@ -313,9 +317,18 @@ icc <- function(model, } } out_ci <- data.frame( - ICC_adjusted = c(CI_low = icc_ci_adjusted$CI_low, CI_high = icc_ci_adjusted$CI_high), - ICC_conditional = c(CI_low = icc_ci_unadjusted$CI_low, CI_high = icc_ci_unadjusted$CI_high), - ICC_unadjusted = c(CI_low = icc_ci_unadjusted$CI_low, CI_high = icc_ci_unadjusted$CI_high) + ICC_adjusted = c( + CI_low = icc_ci_adjusted$CI_low, + CI_high = icc_ci_adjusted$CI_high + ), + ICC_conditional = c( + CI_low = icc_ci_unadjusted$CI_low, + CI_high = icc_ci_unadjusted$CI_high + ), + ICC_unadjusted = c( + CI_low = icc_ci_unadjusted$CI_low, + CI_high = icc_ci_unadjusted$CI_high + ) ) out <- rbind(out, out_ci) attr(out, "ci") <- ci @@ -329,11 +342,13 @@ icc <- function(model, #' @rdname icc #' @export -variance_decomposition <- function(model, - re_formula = NULL, - robust = TRUE, - ci = 0.95, - ...) { +variance_decomposition <- function( + model, + re_formula = NULL, + robust = TRUE, + ci = 0.95, + ... +) { if (!inherits(model, "brmsfit")) { insight::format_error("Only models from package `brms` are supported.") } @@ -369,7 +384,13 @@ variance_decomposition <- function(model, var_icc <- var_rand_intercept / var_total var_residual <- var_total - var_rand_intercept - ci_icc <- rev(1 - stats::quantile(var_rand_intercept / var_total, probs = c((1 - ci) / 2, (1 + ci) / 2))) + ci_icc <- rev( + 1 - + stats::quantile( + var_rand_intercept / var_total, + probs = c((1 - ci) / 2, (1 + ci) / 2) + ) + ) result <- structure( class = "icc_decomposed", @@ -424,10 +445,20 @@ print.icc <- function(x, digits = 3, ...) { # add CI if (length(x$ICC_adjusted) == 3) { - out[1] <- .add_r2_ci_to_print(out[1], x$ICC_adjusted[2], x$ICC_adjusted[3], digits = digits) + out[1] <- .add_r2_ci_to_print( + out[1], + x$ICC_adjusted[2], + x$ICC_adjusted[3], + digits = digits + ) } if (length(x$ICC_unadjusted) == 3) { - out[2] <- .add_r2_ci_to_print(out[2], x$ICC_unadjusted[2], x$ICC_unadjusted[3], digits = digits) + out[2] <- .add_r2_ci_to_print( + out[2], + x$ICC_unadjusted[2], + x$ICC_unadjusted[3], + digits = digits + ) } # separate lines for multiple R2 @@ -479,7 +510,10 @@ print.icc_decomposed <- function(x, digits = 2, ...) { ci.icc.hi )) - cat(insight::print_color("\n## Variances of Posterior Predicted Distribution\n", "blue")) + cat(insight::print_color( + "\n## Variances of Posterior Predicted Distribution\n", + "blue" + )) null.model <- sprintf("%.*f", digits, attr(x, "var_rand_intercept", exact = TRUE)) @@ -544,17 +578,20 @@ print.icc_decomposed <- function(x, digits = 2, ...) { # helper ----------------- -.compute_random_vars <- function(model, - tolerance, - components = c("var.fixed", "var.random", "var.residual"), - name_fun = "icc()", - name_full = "ICC", - null_model = NULL, - model_component = NULL, - approximation = "lognormal", - verbose = TRUE) { +.compute_random_vars <- function( + model, + tolerance, + components = c("var.fixed", "var.random", "var.residual"), + name_fun = "icc()", + name_full = "ICC", + null_model = NULL, + model_component = NULL, + approximation = "lognormal", + verbose = TRUE +) { vars <- tryCatch( - insight::get_variance(model, + insight::get_variance( + model, name_fun = name_fun, name_full = name_full, tolerance = tolerance, @@ -663,7 +700,9 @@ print.icc_decomposed <- function(x, digits = 2, ...) { # main function for bootstrapping .bootstrap_icc <- function(model, iterations, tolerance, ci_method = NULL, ...) { - if (inherits(model, c("merMod", "lmerMod", "glmmTMB")) && !identical(ci_method, "boot")) { + if ( + inherits(model, c("merMod", "lmerMod", "glmmTMB")) && !identical(ci_method, "boot") + ) { result <- .do_lme4_bootmer( model, .boot_icc_fun_lme4, diff --git a/R/item_difficulty.R b/R/item_difficulty.R index 262ca19df..1f12e7641 100644 --- a/R/item_difficulty.R +++ b/R/item_difficulty.R @@ -43,19 +43,25 @@ item_difficulty <- function(x, maximum_value = NULL) { if (is.null(maximum_value)) { maximum_value <- suppressWarnings(max(vapply(x, max, numeric(1L), na.rm = TRUE))) } else if (!is.na(maximum_value) && !is.numeric(maximum_value)) { - insight::format_error("`maximum_value` must be a numeric value, indicating the maximum value of an item.") + insight::format_error( + "`maximum_value` must be a numeric value, indicating the maximum value of an item." + ) } - d <- vapply(x, function(.x) { - # general maximum value, or per-item maximum value? - if (is.na(maximum_value)) { - max_val <- max(.x, na.rm = TRUE) - } else { - max_val <- maximum_value - } - .x <- .x[!is.na(.x)] - round(sum(.x) / (max_val * length(.x)), 2) - }, numeric(1)) + d <- vapply( + x, + function(.x) { + # general maximum value, or per-item maximum value? + if (is.na(maximum_value)) { + max_val <- max(.x, na.rm = TRUE) + } else { + max_val <- maximum_value + } + .x <- .x[!is.na(.x)] + round(sum(.x) / (max_val * length(.x)), 2) + }, + numeric(1) + ) # ideal item item_difficulty fun.diff.ideal <- function(.x) { diff --git a/R/item_discrimination.R b/R/item_discrimination.R index f3542cf3b..3b9a83487 100644 --- a/R/item_discrimination.R +++ b/R/item_discrimination.R @@ -70,7 +70,12 @@ #' item_discrimination(x) #' item_totalcor(x) #' @export -item_discrimination <- function(x, standardize = FALSE, corrected = TRUE, verbose = TRUE) { +item_discrimination <- function( + x, + standardize = FALSE, + corrected = TRUE, + verbose = TRUE +) { # check param if (!is.matrix(x) && !is.data.frame(x)) { insight::format_alert("`x` needs to be a data frame or matrix.") @@ -90,21 +95,27 @@ item_discrimination <- function(x, standardize = FALSE, corrected = TRUE, verbos x <- .std(x) } # calculate corrected total-item correlation - id <- vapply(seq_len(ncol(x)), function(i) { - if (corrected) { - # compute item discrimination (corrected item-total correlation) - score <- rowSums(x[, -i]) - } else { - # compute item-total correlation - score <- rowSums(x) - } - stats::cor(x[, i], score, use = "pairwise.complete.obs") - }, numeric(1)) + id <- vapply( + seq_len(ncol(x)), + function(i) { + if (corrected) { + # compute item discrimination (corrected item-total correlation) + score <- rowSums(x[, -i]) + } else { + # compute item-total correlation + score <- rowSums(x) + } + stats::cor(x[, i], score, use = "pairwise.complete.obs") + }, + numeric(1) + ) # check for negative discrimination values. Tell user that item might need # to be reverse coded if (any(id < 0) && verbose) { - insight::format_alert("Some of the values are negative. Maybe affected items need to be reverse-coded, e.g. using `datawizard::reverse()`.") + insight::format_alert( + "Some of the values are negative. Maybe affected items need to be reverse-coded, e.g. using `datawizard::reverse()`." + ) } out <- data.frame( @@ -127,7 +138,12 @@ item_discrimination <- function(x, standardize = FALSE, corrected = TRUE, verbos #' @export item_totalcor <- function(x, standardize = FALSE, corrected = FALSE, verbose = TRUE) { # alias for item_discrimination, but corrected is FALSE by default - item_discrimination(x, standardize = standardize, corrected = corrected, verbose = verbose) + item_discrimination( + x, + standardize = standardize, + corrected = corrected, + verbose = verbose + ) } diff --git a/R/item_omega.R b/R/item_omega.R index 3f9aa4839..d2693353f 100644 --- a/R/item_omega.R +++ b/R/item_omega.R @@ -67,13 +67,15 @@ item_omega <- function(x, ...) { #' @rdname item_omega #' @export -item_omega.data.frame <- function(x, - n = "auto", - rotation = "oblimin", - factor_method = "minres", - poly_cor = FALSE, - verbose = TRUE, - ...) { +item_omega.data.frame <- function( + x, + n = "auto", + rotation = "oblimin", + factor_method = "minres", + poly_cor = FALSE, + verbose = TRUE, + ... +) { insight::check_if_installed(c("psych", "parameters")) # remove missings @@ -104,8 +106,20 @@ item_omega.data.frame <- function(x, ) out <- data.frame( - Statistic = c("Alpha", "G.6", "Omega (hierarchical)", "Omega (asymptotic H)", "Omega (total)"), - Coefficient = c(model$alpha, model$G6, model$omega_h, model$omega.lim, model$omega.tot), + Statistic = c( + "Alpha", + "G.6", + "Omega (hierarchical)", + "Omega (asymptotic H)", + "Omega (total)" + ), + Coefficient = c( + model$alpha, + model$G6, + model$omega_h, + model$omega.lim, + model$omega.tot + ), stringsAsFactors = FALSE ) @@ -122,14 +136,16 @@ item_omega.data.frame <- function(x, #' @rdname item_omega #' @export -item_omega.matrix <- function(x, - n = "auto", - rotation = "oblimin", - factor_method = "minres", - n_obs = NULL, - poly_cor = FALSE, - verbose = TRUE, - ...) { +item_omega.matrix <- function( + x, + n = "auto", + rotation = "oblimin", + factor_method = "minres", + n_obs = NULL, + poly_cor = FALSE, + verbose = TRUE, + ... +) { # validate n_obs if (!is.null(n_obs) && (!is.numeric(n_obs) || n_obs <= 0 || n_obs %% 1 != 0)) { insight::format_error( @@ -166,7 +182,6 @@ item_omega.matrix <- function(x, # methods ------------------------------------------------ - #' @export summary.item_omega <- function(object, ...) { insight::check_if_installed("parameters") @@ -205,7 +220,6 @@ as.double.item_omega <- function(x, ...) { # helper ------------------------------------------------ - .get_n_factors <- function(x, n = NULL, rotation, ...) { insight::check_if_installed("parameters") if (is.null(n) || n == "auto") { diff --git a/R/item_reliability.R b/R/item_reliability.R index a51585fad..5784b8b4d 100644 --- a/R/item_reliability.R +++ b/R/item_reliability.R @@ -120,11 +120,14 @@ print.item_reliability <- function(x, ...) { # add attributes for table caption and footer attr(out, "table_caption") <- c("# Item Reliability", "blue") - attr(out, "table_footer") <- c(sprintf( - "\nMean inter-item-correlation = %.3f Cronbach's alpha = %.3f", - attributes(out)$item_intercorrelation, - attributes(out)$cronbachs_alpha - ), "yellow") + attr(out, "table_footer") <- c( + sprintf( + "\nMean inter-item-correlation = %.3f Cronbach's alpha = %.3f", + attributes(out)$item_intercorrelation, + attributes(out)$cronbachs_alpha + ), + "yellow" + ) cat(insight::export_table(out, ...)) invisible(x) diff --git a/R/model_performance.bife.R b/R/model_performance.bife.R index 633c91cbe..b1d294d58 100644 --- a/R/model_performance.bife.R +++ b/R/model_performance.bife.R @@ -11,7 +11,6 @@ model_performance.bife <- function(model, metrics = "all", verbose = TRUE, ...) metrics <- c("AIC", "R2") } - metrics <- .check_bad_metrics(metrics, all_metrics, verbose) info <- insight::model_info(model) @@ -31,7 +30,12 @@ model_performance.bife <- function(model, metrics = "all", verbose = TRUE, ...) .logloss <- performance_logloss(model, verbose = verbose) if (!is.na(.logloss)) out$Log_loss <- .logloss } - if (("PCP" %in% toupper(metrics)) && info$is_binomial && !info$is_multinomial && !info$is_ordinal) { + if ( + ("PCP" %in% toupper(metrics)) && + info$is_binomial && + !info$is_multinomial && + !info$is_ordinal + ) { out$PCP <- performance_pcp(model, verbose = verbose)$pcp_model } diff --git a/R/model_performance.ivreg.R b/R/model_performance.ivreg.R index 02a4bdf13..41f327017 100644 --- a/R/model_performance.ivreg.R +++ b/R/model_performance.ivreg.R @@ -14,8 +14,15 @@ #' @export model_performance.ivreg <- function(model, metrics = "all", verbose = TRUE, ...) { all_metrics <- c( - "AIC", "BIC", "R2", "R2_adj", "RMSE", "SIGMA", "Sargan", - "Wu_Hausman", "weak_instruments" + "AIC", + "BIC", + "R2", + "R2_adj", + "RMSE", + "SIGMA", + "Sargan", + "Wu_Hausman", + "weak_instruments" ) if (all(metrics == "all")) { @@ -24,7 +31,6 @@ model_performance.ivreg <- function(model, metrics = "all", verbose = TRUE, ...) metrics <- c("AIC", "BIC", "R2", "R2_adj", "RMSE") } - metrics <- .check_bad_metrics(metrics, all_metrics, verbose) # the lm-method does not accept ivreg-specific metrics @@ -57,8 +63,12 @@ model_performance.ivreg <- function(model, metrics = "all", verbose = TRUE, ...) # remove NA columns completed_tests <- intersect( c( - "Sargan", "Sargan_p", "Wu_Hausman", "Wu_Hausman_p", - "weak_instruments", "weak_instruments_p" + "Sargan", + "Sargan_p", + "Wu_Hausman", + "Wu_Hausman_p", + "weak_instruments", + "weak_instruments_p" ), colnames(out) ) diff --git a/R/model_performance.kmeans.R b/R/model_performance.kmeans.R index 888cfc139..c0b27c273 100644 --- a/R/model_performance.kmeans.R +++ b/R/model_performance.kmeans.R @@ -16,7 +16,12 @@ model_performance.kmeans <- function(model, verbose = TRUE, ...) { out <- as.data.frame(model[c("totss", "tot.withinss", "betweenss", "iter")]) - colnames(out) <- c("Sum_Squares_Total", "Sum_Squares_Within", "Sum_Squares_Between", "Iterations") + colnames(out) <- c( + "Sum_Squares_Total", + "Sum_Squares_Within", + "Sum_Squares_Between", + "Iterations" + ) row.names(out) <- NULL class(out) <- c("performance_model", class(out)) diff --git a/R/model_performance.lavaan.R b/R/model_performance.lavaan.R index a5a05e51b..8ba065443 100644 --- a/R/model_performance.lavaan.R +++ b/R/model_performance.lavaan.R @@ -104,10 +104,31 @@ model_performance.lavaan <- function(model, metrics = "all", verbose = TRUE, ... # All possible metrics that this function can return. all_metric_names <- c( - "Chi2", "Chi2_df", "p_Chi2", "Baseline", "Baseline_df", "p_Baseline", "GFI", - "AGFI", "NFI", "NNFI", "CFI", "RMSEA", "RMSEA_CI_low", "RMSEA_CI_high", - "p_RMSEA", "RMR", "SRMR", "RFI", "PNFI", "IFI", "RNI", "Loglikelihood", - "AIC", "BIC", "BIC_adjusted" + "Chi2", + "Chi2_df", + "p_Chi2", + "Baseline", + "Baseline_df", + "p_Baseline", + "GFI", + "AGFI", + "NFI", + "NNFI", + "CFI", + "RMSEA", + "RMSEA_CI_low", + "RMSEA_CI_high", + "p_RMSEA", + "RMR", + "SRMR", + "RFI", + "PNFI", + "IFI", + "RNI", + "Loglikelihood", + "AIC", + "BIC", + "BIC_adjusted" ) # extract valid column names based on metrics @@ -122,7 +143,10 @@ model_performance.lavaan <- function(model, metrics = "all", verbose = TRUE, ... if (isTRUE(verbose)) { measures <- as.data.frame(t(as.data.frame(lavaan::fitmeasures(model, ...)))) } else { - measures <- as.data.frame(t(as.data.frame(suppressWarnings(lavaan::fitmeasures(model, ...))))) + measures <- as.data.frame(t(as.data.frame(suppressWarnings(lavaan::fitmeasures( + model, + ... + ))))) } row.names(measures) <- NULL @@ -156,7 +180,9 @@ model_performance.lavaan <- function(model, metrics = "all", verbose = TRUE, ... ) } else { if (verbose) { - insight::format_warning("This lavaan model did not converge, no performance indices can be computed. Returning `NA`.") + insight::format_warning( + "This lavaan model did not converge, no performance indices can be computed. Returning `NA`." + ) } out <- as.data.frame(stats::setNames( rep(list(NA), length(out_names)), @@ -180,7 +206,10 @@ model_performance.blavaan <- function(model, metrics = "all", verbose = TRUE, .. measures <- as.data.frame(t(as.data.frame(lavaan::fitmeasures(model, ...)))) fitind <- summary(blavaan::blavFitIndices(model)) } else { - measures <- as.data.frame(t(as.data.frame(suppressWarnings(lavaan::fitmeasures(model, ...))))) + measures <- as.data.frame(t(as.data.frame(suppressWarnings(lavaan::fitmeasures( + model, + ... + ))))) fitind <- suppressWarnings(summary(blavaan::blavFitIndices(model))) } diff --git a/R/model_performance.lm.R b/R/model_performance.lm.R index 592bc44bb..1c9c6c5dd 100644 --- a/R/model_performance.lm.R +++ b/R/model_performance.lm.R @@ -45,7 +45,18 @@ model_performance.lm <- function(model, metrics = "all", verbose = TRUE, ...) { } # all available options... - all_metrics <- c("AIC", "AICc", "BIC", "R2", "R2_adj", "RMSE", "SIGMA", "LOGLOSS", "PCP", "SCORE") + all_metrics <- c( + "AIC", + "AICc", + "BIC", + "R2", + "R2_adj", + "RMSE", + "SIGMA", + "LOGLOSS", + "PCP", + "SCORE" + ) if (all(metrics == "all")) { metrics <- all_metrics @@ -58,7 +69,6 @@ model_performance.lm <- function(model, metrics = "all", verbose = TRUE, ...) { insight::formula_ok(model) } - metrics <- .check_bad_metrics(metrics, all_metrics, verbose) info <- suppressWarnings(insight::model_info(model, verbose = FALSE)) @@ -105,7 +115,12 @@ model_performance.lm <- function(model, metrics = "all", verbose = TRUE, ...) { if ("R2_within_adjusted" %in% names(R2)) { out$R2_within_adjusted <- R2$R2_within_adjusted } - if (!any(c("R2", "R2_adj", "R2_adjusted", "R2_within", "R2_within_adjusted") %in% names(R2))) { + if ( + !any( + c("R2", "R2_adj", "R2_adjusted", "R2_within", "R2_within_adjusted") %in% + names(R2) + ) + ) { out <- c(out, R2) } } @@ -134,29 +149,40 @@ model_performance.lm <- function(model, metrics = "all", verbose = TRUE, ...) { } # SCORE ------------- - if (("SCORE" %in% toupper(metrics)) && (isTRUE(info$is_binomial) || isTRUE(info$is_count))) { + if ( + ("SCORE" %in% toupper(metrics)) && (isTRUE(info$is_binomial) || isTRUE(info$is_count)) + ) { .scoring_rules <- .safe(performance_score(model, verbose = verbose)) if (!is.null(.scoring_rules)) { - if (!is.na(.scoring_rules$logarithmic)) out$Score_log <- .scoring_rules$logarithmic - if (!is.na(.scoring_rules$spherical)) out$Score_spherical <- .scoring_rules$spherical + if (!is.na(.scoring_rules$logarithmic)) { + out$Score_log <- .scoring_rules$logarithmic + } + if (!is.na(.scoring_rules$spherical)) { + out$Score_spherical <- .scoring_rules$spherical + } } } # PCP ------------- - if (("PCP" %in% toupper(metrics)) && - isTRUE(info$is_binomial) && - isFALSE(info$is_multinomial) && - isFALSE(info$is_ordinal)) { + if ( + ("PCP" %in% toupper(metrics)) && + isTRUE(info$is_binomial) && + isFALSE(info$is_multinomial) && + isFALSE(info$is_ordinal) + ) { out$PCP <- .safe(performance_pcp(model, verbose = verbose)$pcp_model) } - out <- as.data.frame(insight::compact_list(out, remove_na = TRUE), check.names = FALSE) # check if model was actually supported... if (nrow(out) == 0 || ncol(out) == 0) { if (isTRUE(verbose)) { - insight::format_warning(paste0("Models of class `", class(model)[1], "` are not yet supported.")) + insight::format_warning(paste0( + "Models of class `", + class(model)[1], + "` are not yet supported." + )) } return(NULL) } @@ -267,7 +293,13 @@ 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, ...) + mp <- lapply( + model$models, + model_performance.lm, + metrics = metrics, + verbose = verbose, + ... + ) out <- cbind( data.frame(Response = names(mp), stringsAsFactors = FALSE), do.call(rbind, mp) @@ -320,7 +352,6 @@ model_performance.model_fit <- model_performance.logitor # other models ------------------------------- - #' @export model_performance.mlogit <- function(model, metrics = "all", verbose = TRUE, ...) { if (requireNamespace("mlogit", quietly = TRUE)) { diff --git a/R/model_performance.mixed.R b/R/model_performance.mixed.R index ba72a5a01..8e0fe0e7a 100644 --- a/R/model_performance.mixed.R +++ b/R/model_performance.mixed.R @@ -39,11 +39,13 @@ #' model <- lme4::lmer(Petal.Length ~ Sepal.Length + (1 | Species), data = iris) #' model_performance(model) #' @export -model_performance.merMod <- function(model, - metrics = "all", - estimator = "REML", - verbose = TRUE, - ...) { +model_performance.merMod <- function( + model, + metrics = "all", + estimator = "REML", + verbose = TRUE, + ... +) { if (any(tolower(metrics) == "log_loss")) { metrics[tolower(metrics) == "log_loss"] <- "LOGLOSS" } @@ -57,7 +59,6 @@ model_performance.merMod <- function(model, metrics <- c("AIC", "BIC", "R2", "ICC", "RMSE") } - metrics <- .check_bad_metrics(metrics, all_metrics, verbose) # check model formula @@ -105,7 +106,9 @@ model_performance.merMod <- function(model, if (("SCORE" %in% toupper(metrics)) && (mi$is_binomial || mi$is_count)) { .scoring_rules <- performance_score(model, verbose = verbose) - if (!is.na(.scoring_rules$logarithmic)) out$Score_log <- .scoring_rules$logarithmic + if (!is.na(.scoring_rules$logarithmic)) { + out$Score_log <- .scoring_rules$logarithmic + } if (!is.na(.scoring_rules$spherical)) out$Score_spherical <- .scoring_rules$spherical } @@ -139,10 +142,7 @@ model_performance.glmmTMB <- model_performance.merMod #' @export -model_performance.mixor <- function(model, - metrics = "all", - verbose = TRUE, - ...) { +model_performance.mixor <- function(model, metrics = "all", verbose = TRUE, ...) { if (any(tolower(metrics) == "log_loss")) { metrics[tolower(metrics) == "log_loss"] <- "LOGLOSS" } @@ -160,12 +160,21 @@ model_performance.mixor <- function(model, if ("BIC" %in% metrics) { out$BIC <- .get_BIC(model) } - if (("LOGLOSS" %in% metrics) && mi$is_binomial && !mi$is_ordinal && !mi$is_multinomial) { + if ( + ("LOGLOSS" %in% metrics) && mi$is_binomial && !mi$is_ordinal && !mi$is_multinomial + ) { out$Log_loss <- performance_logloss(model, verbose = verbose) } - if (("SCORE" %in% metrics) && (mi$is_binomial || mi$is_count) && !mi$is_ordinal && !mi$is_multinomial) { + if ( + ("SCORE" %in% metrics) && + (mi$is_binomial || mi$is_count) && + !mi$is_ordinal && + !mi$is_multinomial + ) { .scoring_rules <- performance_score(model, verbose = verbose) - if (!is.na(.scoring_rules$logarithmic)) out$Score_log <- .scoring_rules$logarithmic + if (!is.na(.scoring_rules$logarithmic)) { + out$Score_log <- .scoring_rules$logarithmic + } if (!is.na(.scoring_rules$spherical)) out$Score_spherical <- .scoring_rules$spherical } diff --git a/R/model_performance.psych.R b/R/model_performance.psych.R index b7a428110..6ef95f082 100644 --- a/R/model_performance.psych.R +++ b/R/model_performance.psych.R @@ -64,7 +64,12 @@ model_performance.fa <- function(model, metrics = "all", verbose = TRUE, ...) { model_performance.principal <- model_performance.fa #' @export -model_performance.parameters_efa <- function(model, metrics = "all", verbose = TRUE, ...) { +model_performance.parameters_efa <- function( + model, + metrics = "all", + verbose = TRUE, + ... +) { model_performance(attributes(model)$model, metrics = metrics, verbose = verbose, ...) } @@ -80,23 +85,26 @@ model_performance.omega <- function(model, metrics = "all", verbose = TRUE, ...) } # generate statistics for n-factor solution and g-model - out <- do.call(rbind, lapply(list(model$schmid, model$gstats), function(stats) { - data.frame( - Chi2 = ifelse(is.null(stats$STATISTIC), NA_real_, stats$STATISTIC), - df = ifelse(is.null(stats$dof), NA_real_, stats$dof), - p_Chi2 = ifelse(is.null(stats$PVAL), NA_real_, stats$PVAL), - RMSA = ifelse(is.null(stats$rms), NA_real_, stats$rms), - RMSA_corrected = ifelse(is.null(stats$crms), NA_real_, stats$crms), - TLI = ifelse(is.null(stats$TLI), NA_real_, stats$TLI), - RMSEA = ifelse(is.null(stats$RMSEA), NA_real_, stats$RMSEA[1]), - RMSEA_CI = ifelse(is.null(stats$RMSEA), NA_real_, 0.9), - RMSEA_CI_low = ifelse(is.null(stats$RMSEA), NA_real_, stats$RMSEA[2]), - RMSEA_CI_high = ifelse(is.null(stats$RMSEA), NA_real_, stats$RMSEA[3]), - BIC = ifelse(is.null(stats$BIC), NA_real_, stats$BIC), - R2 = ifelse(is.null(stats$R2), NA_real_, stats$R2), - Correlation = ifelse(is.null(stats$R2), NA_real_, sqrt(abs(stats$R2))) - ) - })) + out <- do.call( + rbind, + lapply(list(model$schmid, model$gstats), function(stats) { + data.frame( + Chi2 = ifelse(is.null(stats$STATISTIC), NA_real_, stats$STATISTIC), + df = ifelse(is.null(stats$dof), NA_real_, stats$dof), + p_Chi2 = ifelse(is.null(stats$PVAL), NA_real_, stats$PVAL), + RMSA = ifelse(is.null(stats$rms), NA_real_, stats$rms), + RMSA_corrected = ifelse(is.null(stats$crms), NA_real_, stats$crms), + TLI = ifelse(is.null(stats$TLI), NA_real_, stats$TLI), + RMSEA = ifelse(is.null(stats$RMSEA), NA_real_, stats$RMSEA[1]), + RMSEA_CI = ifelse(is.null(stats$RMSEA), NA_real_, 0.9), + RMSEA_CI_low = ifelse(is.null(stats$RMSEA), NA_real_, stats$RMSEA[2]), + RMSEA_CI_high = ifelse(is.null(stats$RMSEA), NA_real_, stats$RMSEA[3]), + BIC = ifelse(is.null(stats$BIC), NA_real_, stats$BIC), + R2 = ifelse(is.null(stats$R2), NA_real_, stats$R2), + Correlation = ifelse(is.null(stats$R2), NA_real_, sqrt(abs(stats$R2))) + ) + }) + ) # bind first column, to indicate component out <- cbind( @@ -119,7 +127,12 @@ model_performance.omega <- function(model, metrics = "all", verbose = TRUE, ...) attr(out, "n") <- n_factors attr(out, "model") <- model - class(out) <- unique(c("performance_omega", "performance_fa", "performance_model", class(out))) + class(out) <- unique(c( + "performance_omega", + "performance_fa", + "performance_model", + class(out) + )) out } @@ -136,7 +149,9 @@ print.performance_omega <- function(x, ...) { insight::print_color( insight::format_message(sprintf( "\nCompare the model fit of the %i-factor solution with the g-only model. If the g-model has smaller RMSA and RMSEA then your items are more likely to describe a single unidimensional construct. If the %i-factor model has smaller RMSA and RMSEA then your construct is more likely to be made up of %i sub-constructs.", - n, n, n + n, + n, + n )), "yellow" ) diff --git a/R/performance_aicc.R b/R/performance_aicc.R index 443bf62c9..05228b669 100644 --- a/R/performance_aicc.R +++ b/R/performance_aicc.R @@ -88,7 +88,9 @@ performance_aic.default <- function(x, estimator = "ML", verbose = TRUE, ...) { # check ML estimator REML <- identical(estimator, "REML") - if (isTRUE(list(...)$REML)) REML <- TRUE + if (isTRUE(list(...)$REML)) { + REML <- TRUE + } # special handling for tweedie if (info$family == "Tweedie") { @@ -97,7 +99,12 @@ performance_aic.default <- function(x, estimator = "ML", verbose = TRUE, ...) { } else { # all other models... aic <- .safe( - stats::AIC(insight::get_loglikelihood(x, check_response = TRUE, REML = REML, verbose = verbose)) + stats::AIC(insight::get_loglikelihood( + x, + check_response = TRUE, + REML = REML, + verbose = verbose + )) ) # when `get_loglikelihood()` does not work, `stats::AIC` sometimes still works (e.g., `fixest`) if (is.null(aic)) { @@ -110,26 +117,33 @@ performance_aic.default <- function(x, estimator = "ML", verbose = TRUE, ...) { # mixed models ------------------------------------ - #' @rdname performance_aicc #' @export performance_aic.lmerMod <- function(x, estimator = "REML", verbose = TRUE, ...) { REML <- identical(estimator, "REML") - if (isFALSE(list(...)$REML)) REML <- FALSE + if (isFALSE(list(...)$REML)) { + REML <- FALSE + } if (isFALSE(as.logical(x@devcomp$dims[["REML"]])) && isTRUE(REML) && verbose) { - insight::format_alert("Model was not fitted with REML, however, `estimator = \"REML\"`. Set `estimator = \"ML\"` to obtain identical results as from `AIC()`.") # nolint + insight::format_alert( + "Model was not fitted with REML, however, `estimator = \"REML\"`. Set `estimator = \"ML\"` to obtain identical results as from `AIC()`." + ) # nolint } .safe( - stats::AIC(insight::get_loglikelihood(x, check_response = TRUE, REML = REML, verbose = verbose)) + stats::AIC(insight::get_loglikelihood( + x, + check_response = TRUE, + REML = REML, + verbose = verbose + )) ) } # VGAM models ------------------------------------ - #' @export performance_aic.vgam <- function(x, ...) { insight::check_if_installed("VGAM") @@ -162,22 +176,22 @@ performance_aic.logitor <- function(x, ...) { # styler: off #' @export -performance_aic.logitmfx <- performance_aic.logitor +performance_aic.logitmfx <- performance_aic.logitor #' @export -performance_aic.probitmfx <- performance_aic.logitor +performance_aic.probitmfx <- performance_aic.logitor #' @export -performance_aic.negbinirr <- performance_aic.logitor +performance_aic.negbinirr <- performance_aic.logitor #' @export -performance_aic.negbinmfx <- performance_aic.logitor +performance_aic.negbinmfx <- performance_aic.logitor #' @export -performance_aic.betaor <- performance_aic.logitor +performance_aic.betaor <- performance_aic.logitor #' @export -performance_aic.betamfx <- performance_aic.logitor +performance_aic.betamfx <- performance_aic.logitor #' @export performance_aic.poissonirr <- performance_aic.logitor @@ -201,20 +215,23 @@ performance_aic.bayesx <- function(x, ...) { #' @export AIC.bife <- function(object, ..., k = 2) { - -2 * as.numeric(insight::get_loglikelihood(object)) + k * insight::get_df(object, type = "model") + -2 * + as.numeric(insight::get_loglikelihood(object)) + + k * insight::get_df(object, type = "model") } # AICc ------------------------------------------ - #' @export performance_aicc.default <- function(x, estimator = "ML", ...) { .is_model_valid(x) # check ML estimator REML <- identical(estimator, "REML") - if (isTRUE(list(...)$REML)) REML <- TRUE + if (isTRUE(list(...)$REML)) { + REML <- TRUE + } n <- suppressWarnings(insight::n_obs(x)) ll <- insight::get_loglikelihood(x, check_response = TRUE, REML = REML, verbose = TRUE) @@ -227,7 +244,9 @@ performance_aicc.default <- function(x, estimator = "ML", ...) { #' @export performance_aicc.lmerMod <- function(x, estimator = "REML", ...) { REML <- identical(estimator, "REML") - if (isFALSE(list(...)$REML)) REML <- FALSE + if (isFALSE(list(...)$REML)) { + REML <- FALSE + } n <- suppressWarnings(insight::n_obs(x)) ll <- insight::get_loglikelihood(x, check_response = TRUE, REML = REML, verbose = TRUE) @@ -266,11 +285,14 @@ performance_aicc.rma <- function(x, ...) { # jacobian / derivate for log models and other transformations ---------------- - # this function adjusts any IC for models with transformed response variables .adjust_ic_jacobian <- function(model, ic) { response_transform <- insight::find_transformation(model) - if (!is.null(ic) && !is.null(response_transform) && !identical(response_transform, "identity")) { + if ( + !is.null(ic) && + !is.null(response_transform) && + !identical(response_transform, "identity") + ) { adjustment <- .safe(insight::get_loglikelihood_adjustment( model, insight::get_weights(model, remove_na = TRUE) diff --git a/R/performance_cv.R b/R/performance_cv.R index 31ad998aa..59bf423df 100644 --- a/R/performance_cv.R +++ b/R/performance_cv.R @@ -35,15 +35,17 @@ #' performance_cv(model) #' #' @export -performance_cv <- function(model, - data = NULL, - method = "holdout", - metrics = "all", - prop = 0.30, - k = 5, - stack = TRUE, - verbose = TRUE, - ...) { +performance_cv <- function( + model, + data = NULL, + method = "holdout", + metrics = "all", + prop = 0.30, + k = 5, + stack = TRUE, + verbose = TRUE, + ... +) { if (all(metrics == "all")) { metrics <- c("MSE", "RMSE", "R2") } else if (all(metrics == "common")) { @@ -69,18 +71,30 @@ performance_cv <- function(model, test_pred <- insight::get_predicted(model, ci = NULL, data = data) test_resd <- test_resp - test_pred } else if (method == "holdout") { - train_i <- sample.int(nrow(model_data), size = round((1 - prop) * nrow(model_data)), replace = FALSE) + train_i <- sample.int( + nrow(model_data), + size = round((1 - prop) * nrow(model_data)), + replace = FALSE + ) model_upd <- stats::update(model, data = model_data[train_i, ]) test_resp <- model_data[-train_i, resp.name] - test_pred <- insight::get_predicted(model_upd, ci = NULL, data = model_data[-train_i, ]) + test_pred <- insight::get_predicted( + model_upd, + ci = NULL, + data = model_data[-train_i, ] + ) test_resd <- test_resp - test_pred } else if (method == "loo" && !info$is_bayesian) { model_response <- insight::get_response(model) - MSE <- mean(insight::get_residuals(model, weighted = TRUE)^2 / - (1 - stats::hatvalues(model))^2) + MSE <- mean( + insight::get_residuals(model, weighted = TRUE)^2 / + (1 - stats::hatvalues(model))^2 + ) mean(test_resd^2, na.rm = TRUE) RMSE <- sqrt(MSE) - R2 <- 1 - MSE / (mean(model_response^2, na.rm = TRUE) - mean(model_response, na.rm = TRUE)^2) + R2 <- 1 - + MSE / + (mean(model_response^2, na.rm = TRUE) - mean(model_response, na.rm = TRUE)^2) out <- data.frame(MSE = MSE, RMSE = RMSE, R2 = R2) } else { # Manual method for LOO, use this for non-linear and Bayesian models @@ -95,19 +109,27 @@ performance_cv <- function(model, k <- nrow(model_data) } if (k > nrow(model_data)) { - message(insight::color_text(insight::format_message( - "Requested number of folds (k) larger than the sample size.", - "'k' set equal to the sample size (leave-one-out [LOO])." - ), color = "yellow")) + message(insight::color_text( + insight::format_message( + "Requested number of folds (k) larger than the sample size.", + "'k' set equal to the sample size (leave-one-out [LOO])." + ), + color = "yellow" + )) k <- nrow(model_data) } cv_folds <- .crossv_kfold(model_data, k = k) models_upd <- lapply(cv_folds, function(.x) { stats::update(model, data = model_data[.x$train, ]) }) - test_pred <- mapply(function(.x, .y) { - insight::get_predicted(.y, ci = NULL, data = model_data[.x$test, ]) - }, cv_folds, models_upd, SIMPLIFY = FALSE) + test_pred <- mapply( + function(.x, .y) { + insight::get_predicted(.y, ci = NULL, data = model_data[.x$test, ]) + }, + cv_folds, + models_upd, + SIMPLIFY = FALSE + ) test_resp <- lapply(cv_folds, function(.x) { as.data.frame(model_data[.x$test, ])[[resp.name]] }) @@ -124,17 +146,27 @@ performance_cv <- function(model, R2 <- 1 - MSE / mean((test_resp - mean(test_resp, na.rm = TRUE))^2, na.rm = TRUE) out <- data.frame(MSE = MSE, RMSE = RMSE, R2 = R2) } else { - test_resd <- mapply(function(.x, .y) { - .x - .y - }, test_resp, test_pred, SIMPLIFY = FALSE) + test_resd <- mapply( + function(.x, .y) { + .x - .y + }, + test_resp, + test_pred, + SIMPLIFY = FALSE + ) MSEs <- sapply(test_resd, function(x) mean(x^2, na.rm = TRUE)) RMSEs <- sqrt(MSEs) - resp_vars <- sapply(test_resp, function(x) mean((x - mean(x, na.rm = TRUE))^2, na.rm = TRUE)) + resp_vars <- sapply(test_resp, function(x) { + mean((x - mean(x, na.rm = TRUE))^2, na.rm = TRUE) + }) R2s <- 1 - MSEs / resp_vars out <- data.frame( - MSE = mean(MSEs), MSE_SE = stats::sd(MSEs), - RMSE = mean(RMSEs), RMSE_SE = stats::sd(RMSEs), - R2 = mean(R2s), R2_SE = stats::sd(R2s) + MSE = mean(MSEs), + MSE_SE = stats::sd(MSEs), + RMSE = mean(RMSEs), + RMSE_SE = stats::sd(RMSEs), + R2 = mean(R2s), + R2_SE = stats::sd(R2s) ) } @@ -144,14 +176,17 @@ performance_cv <- function(model, attr(out, "prop") <- if (method == "holdout") prop missing_metrics <- setdiff(metrics, c("MSE", "RMSE", "R2")) if (length(missing_metrics)) { - message(insight::colour_text(insight::format_message( - paste0( - "Metric", - ifelse(length(missing_metrics) > 1, "s '", " '"), - paste0(missing_metrics, collapse = "', '"), - "' not yet supported." - ) - ), colour = "red")) + message(insight::colour_text( + insight::format_message( + paste0( + "Metric", + ifelse(length(missing_metrics) > 1, "s '", " '"), + paste0(missing_metrics, collapse = "', '"), + "' not yet supported." + ) + ), + colour = "red" + )) } class(out) <- c("performance_cv", "data.frame") return(out) @@ -171,7 +206,8 @@ performance_cv <- function(model, #' @export print.performance_cv <- function(x, digits = 2, ...) { - method <- switch(attr(x, "method"), + method <- switch( + attr(x, "method"), holdout = paste0( insight::format_value(attr(x, "prop"), as_percent = TRUE, digits = 0), " holdout" @@ -181,18 +217,23 @@ print.performance_cv <- function(x, digits = 2, ...) { ) formatted_table <- format( - x = x, digits = digits, format = "text", + x = x, + digits = digits, + format = "text", ... ) cat(insight::export_table( x = formatted_table, digits = digits, format = "text", - caption = c(paste0( - "# Cross-validation performance (", - method, - " method)" - ), "blue"), + caption = c( + paste0( + "# Cross-validation performance (", + method, + " method)" + ), + "blue" + ), ... )) invisible(x) diff --git a/R/performance_logloss.R b/R/performance_logloss.R index a8042d942..b4003cd81 100644 --- a/R/performance_logloss.R +++ b/R/performance_logloss.R @@ -36,7 +36,9 @@ performance_logloss.default <- function(model, verbose = TRUE, ...) { ll <- suppressWarnings(mean(log(1 - abs(resp - stats::fitted(model))) * -1)) if (is.na(ll)) { - if (verbose) insight::print_color("Can't calculate log-loss.\n", "red") + if (verbose) { + insight::print_color("Can't calculate log-loss.\n", "red") + } return(NA) } @@ -51,7 +53,9 @@ performance_logloss.brmsfit <- function(model, verbose = TRUE, ...) { ll <- suppressWarnings(mean(log(1 - abs(resp - yhat)) * -1)) if (is.na(ll)) { - if (verbose) insight::print_color("Can't calculate log-loss.\n", "red") + if (verbose) { + insight::print_color("Can't calculate log-loss.\n", "red") + } return(NA) } diff --git a/R/performance_mse.R b/R/performance_mse.R index 9d3c9d239..df5a30554 100644 --- a/R/performance_mse.R +++ b/R/performance_mse.R @@ -52,7 +52,9 @@ performance_mse.default <- function(model, verbose = TRUE, ...) { # for multivariate response models... if (is.data.frame(res)) { if (verbose) { - insight::format_warning("Multiple response variables detected. Cannot reliably compute (R)MSE.") + insight::format_warning( + "Multiple response variables detected. Cannot reliably compute (R)MSE." + ) } return(NA) } diff --git a/R/performance_pcp.R b/R/performance_pcp.R index 355880b54..7ae735279 100644 --- a/R/performance_pcp.R +++ b/R/performance_pcp.R @@ -50,10 +50,7 @@ #' performance_pcp(m) #' performance_pcp(m, method = "Gelman-Hill") #' @export -performance_pcp <- function(model, - ci = 0.95, - method = "Herron", - verbose = TRUE) { +performance_pcp <- function(model, ci = 0.95, method = "Herron", verbose = TRUE) { # fix special cases if (inherits(model, c("model_fit", "logitor", "logitmfx", "probitmfx"))) { model <- model$fit @@ -66,13 +63,20 @@ performance_pcp <- function(model, mi <- insight::model_info(model, verbose = verbose) if (!mi$is_binomial) { - insight::format_error("`performance_pcp()` only works for models with binary outcome.") + insight::format_error( + "`performance_pcp()` only works for models with binary outcome." + ) } resp <- insight::get_response(model, verbose = verbose) if (!is.null(ncol(resp)) && ncol(resp) > 1) { - if (verbose) insight::print_color("`performance_pcp()` only works for models with binary response values.\n", "red") + if (verbose) { + insight::print_color( + "`performance_pcp()` only works for models with binary response values.\n", + "red" + ) + } return(NULL) } @@ -91,9 +95,22 @@ performance_pcp <- function(model, #' @export print.performance_pcp <- function(x, digits = 2, ...) { - insight::print_color("# Percentage of Correct Predictions from Logistic Regression Model\n\n", "blue") - cat(sprintf(" Full model: %.2f%% [%.2f%% - %.2f%%]\n", 100 * x$pcp_model, 100 * x$model_ci_low, 100 * x$model_ci_high)) - cat(sprintf(" Null model: %.2f%% [%.2f%% - %.2f%%]\n", 100 * x$pcp_m0, 100 * x$null_ci_low, 100 * x$null_ci_high)) + insight::print_color( + "# Percentage of Correct Predictions from Logistic Regression Model\n\n", + "blue" + ) + cat(sprintf( + " Full model: %.2f%% [%.2f%% - %.2f%%]\n", + 100 * x$pcp_model, + 100 * x$model_ci_low, + 100 * x$model_ci_high + )) + cat(sprintf( + " Null model: %.2f%% [%.2f%% - %.2f%%]\n", + 100 * x$pcp_m0, + 100 * x$null_ci_low, + 100 * x$null_ci_high + )) insight::print_color("\n# Likelihood-Ratio-Test\n\n", "blue") @@ -148,23 +165,32 @@ as.data.frame.performance_pcp <- function(x, row.names = NULL, ...) { pcp_null <- 1 - mean((pr_null > 0.5 & y_null == 0) | (pr_null <= 0.5 & y_null == 1)) } - lrt.p <- 1 - stats::pchisq( - q = model$null.deviance - model$deviance, - df = model$df.null - model$df.residual, - lower.tail = TRUE - ) + lrt.p <- 1 - + stats::pchisq( + q = model$null.deviance - model$deviance, + df = model$df.null - model$df.residual, + lower.tail = TRUE + ) - lrt.chisq <- 2 * abs(insight::get_loglikelihood(model, verbose = verbose) - insight::get_loglikelihood(m0, verbose = verbose)) + lrt.chisq <- 2 * + abs( + insight::get_loglikelihood(model, verbose = verbose) - + insight::get_loglikelihood(m0, verbose = verbose) + ) structure( class = "performance_pcp", list( pcp_model = pcp_full, - model_ci_low = pcp_full - stats::qnorm((1 + ci) / 2) * sqrt(pcp_full * (1 - pcp_full) / n_full), - model_ci_high = pcp_full + stats::qnorm((1 + ci) / 2) * sqrt(pcp_full * (1 - pcp_full) / n_full), + model_ci_low = pcp_full - + stats::qnorm((1 + ci) / 2) * sqrt(pcp_full * (1 - pcp_full) / n_full), + model_ci_high = pcp_full + + stats::qnorm((1 + ci) / 2) * sqrt(pcp_full * (1 - pcp_full) / n_full), pcp_m0 = pcp_null, - null_ci_low = pcp_null - stats::qnorm((1 + ci) / 2) * sqrt(pcp_null * (1 - pcp_null) / n_null), - null_ci_high = pcp_null + stats::qnorm((1 + ci) / 2) * sqrt(pcp_null * (1 - pcp_null) / n_null), + null_ci_low = pcp_null - + stats::qnorm((1 + ci) / 2) * sqrt(pcp_null * (1 - pcp_null) / n_null), + null_ci_high = pcp_null + + stats::qnorm((1 + ci) / 2) * sqrt(pcp_null * (1 - pcp_null) / n_null), lrt_chisq = as.vector(lrt.chisq), lrt_df_error = model$df.null - model$df.residual, lrt_p = lrt.p diff --git a/R/performance_reliability.R b/R/performance_reliability.R index 4e5bcb9fa..f21b98d15 100644 --- a/R/performance_reliability.R +++ b/R/performance_reliability.R @@ -206,7 +206,6 @@ performance_reliability.default <- function(x, ...) { # d-vour ------------------------------------------------------------------ - #' @rdname performance_reliability #' @export performance_dvour <- function(x, ...) { @@ -254,7 +253,9 @@ performance_dvour.estimate_grouplevel <- function(x, ...) { } # Compute reliability - if (!"Component" %in% names(x)) x$Component <- "TEMP" + if (!"Component" %in% names(x)) { + x$Component <- "TEMP" + } reliability <- data.frame() @@ -262,7 +263,9 @@ performance_dvour.estimate_grouplevel <- function(x, ...) { for (grp in unique(x$Group)) { for (param in unique(x$Parameter)) { d <- x[x$Component == comp & x$Group == grp & x$Parameter == param, ] - if (nrow(d) == 0) next + if (nrow(d) == 0) { + next + } # Store group-level results rez <- data.frame( @@ -288,7 +291,10 @@ performance_dvour.estimate_grouplevel <- function(x, ...) { } # Clean-up output - if (insight::has_single_value(reliability$Component, remove_na = TRUE) && unique(reliability$Component) == "TEMP") { + if ( + insight::has_single_value(reliability$Component, remove_na = TRUE) && + unique(reliability$Component) == "TEMP" + ) { reliability$Component <- NULL } diff --git a/R/performance_rmse.R b/R/performance_rmse.R index 2e98d5514..14b7b174a 100644 --- a/R/performance_rmse.R +++ b/R/performance_rmse.R @@ -30,13 +30,15 @@ #' # normalized RMSE #' performance_rmse(m, normalized = TRUE) #' @export -performance_rmse <- function(model, - normalized = FALSE, - ci = NULL, - iterations = 100, - ci_method = NULL, - verbose = TRUE, - ...) { +performance_rmse <- function( + model, + normalized = FALSE, + ci = NULL, + iterations = 100, + ci_method = NULL, + verbose = TRUE, + ... +) { tryCatch( { out <- .calculate_rmse(model, normalized, verbose) @@ -140,11 +142,21 @@ print.performance_rmse <- function(x, ...) { .calculate_rmse(model = fit, normalized = normalized) } -.bootstrap_rmse <- function(model, iterations = 100, normalized = FALSE, ci_method = NULL, ...) { - if (inherits(model, c("merMod", "lmerMod", "glmmTMB")) && !identical(ci_method, "boot")) { +.bootstrap_rmse <- function( + model, + iterations = 100, + normalized = FALSE, + ci_method = NULL, + ... +) { + if ( + inherits(model, c("merMod", "lmerMod", "glmmTMB")) && !identical(ci_method, "boot") + ) { # cannot pass argument "normalized" to "lme4::bootMer()" if (isTRUE(normalized)) { - insight::format_error("Normalized RMSE cannot be used with confidence intervals. Please use `ci_method = \"boot\"`.") # nolint + insight::format_error( + "Normalized RMSE cannot be used with confidence intervals. Please use `ci_method = \"boot\"`." + ) # nolint } result <- .do_lme4_bootmer( model, diff --git a/R/performance_roc.R b/R/performance_roc.R index 4de8be3e3..4e1375f15 100644 --- a/R/performance_roc.R +++ b/R/performance_roc.R @@ -78,11 +78,17 @@ performance_roc <- function(x, ..., predictions, new_data) { if (is.numeric(x) && !missing(predictions) && !is.null(predictions)) { .performance_roc_numeric(x, predictions) - } else if (inherits(x, c("logitor", "logitmfx", "probitmfx", "model_fit")) && length(dots) == 0) { - if (missing(new_data)) new_data <- NULL + } else if ( + inherits(x, c("logitor", "logitmfx", "probitmfx", "model_fit")) && length(dots) == 0 + ) { + if (missing(new_data)) { + new_data <- NULL + } .performance_roc_model(x$fit, new_data) } else if (info$is_binomial && length(dots) == 0) { - if (missing(new_data)) new_data <- NULL + if (missing(new_data)) { + new_data <- NULL + } .performance_roc_model(x, new_data) } else if (length(dots) > 0) { .performance_roc_models(list(x, ...), names = object_names) @@ -102,7 +108,10 @@ plot.performance_roc <- function(x, ...) { #' @export print.performance_roc <- function(x, ...) { if (length(unique(x$Model)) == 1) { - cat(sprintf("AUC: %.2f%%\n", 100 * bayestestR::area_under_curve(x$Specificity, x$Sensitivity))) + cat(sprintf( + "AUC: %.2f%%\n", + 100 * bayestestR::area_under_curve(x$Specificity, x$Sensitivity) + )) } else { insight::print_color("# Area under Curve\n\n", "blue") @@ -160,7 +169,9 @@ as.double.performance_roc <- function(x, ...) { .performance_roc_model <- function(x, new_data, model_name = "Model 1") { predictions <- stats::predict(x, newdata = new_data, type = "response") - if (is.null(new_data)) new_data <- insight::get_data(x, verbose = FALSE) + if (is.null(new_data)) { + new_data <- insight::get_data(x, verbose = FALSE) + } response <- new_data[[insight::find_response(x)]] if ((is.data.frame(response) || is.matrix(response)) && ncol(response) > 1) { diff --git a/R/performance_rse.R b/R/performance_rse.R index c93c68d1a..3217127b8 100644 --- a/R/performance_rse.R +++ b/R/performance_rse.R @@ -17,5 +17,8 @@ #' @export performance_rse <- function(model) { # Residual standard error - sqrt(sum(insight::get_residuals(model)^2, na.rm = TRUE) / insight::get_df(model, type = "residual")) + sqrt( + sum(insight::get_residuals(model)^2, na.rm = TRUE) / + insight::get_df(model, type = "residual") + ) } diff --git a/R/performance_score.R b/R/performance_score.R index ad9d1ce40..d711143d8 100644 --- a/R/performance_score.R +++ b/R/performance_score.R @@ -54,7 +54,20 @@ #' @export performance_score <- function(model, verbose = TRUE, ...) { # check special case - if (inherits(model, c("logitor", "logitmfx", "probitmfx", "negbinirr", "negbinmfx", "poissonirr", "poissonmfx"))) { + if ( + inherits( + model, + c( + "logitor", + "logitmfx", + "probitmfx", + "negbinirr", + "negbinmfx", + "poissonirr", + "poissonmfx" + ) + ) + ) { model <- model$fit } @@ -65,7 +78,9 @@ performance_score <- function(model, verbose = TRUE, ...) { if (minfo$is_ordinal || minfo$is_multinomial) { if (verbose) { - insight::format_alert("Can't calculate proper scoring rules for ordinal, multinomial or cumulative link models.") + insight::format_alert( + "Can't calculate proper scoring rules for ordinal, multinomial or cumulative link models." + ) } return(list(logarithmic = NA, quadratic = NA, spherical = NA)) } @@ -74,7 +89,9 @@ performance_score <- function(model, verbose = TRUE, ...) { if (!is.null(ncol(resp)) && ncol(resp) > 1) { if (verbose) { - insight::format_alert("Can't calculate proper scoring rules for models without integer response values.") + insight::format_alert( + "Can't calculate proper scoring rules for models without integer response values." + ) } return(list(logarithmic = NA, quadratic = NA, spherical = NA)) } @@ -84,7 +101,9 @@ performance_score <- function(model, verbose = TRUE, ...) { } else if (minfo$is_poisson && !minfo$is_zero_inflated) { function(x, mean, pis, n) stats::dpois(x, lambda = mean) } else if (minfo$is_negbin && !minfo$is_zero_inflated) { - function(x, mean, pis, n) stats::dnbinom(x, mu = mean, size = exp(.dispersion_parameter(model, minfo))) + function(x, mean, pis, n) { + stats::dnbinom(x, mu = mean, size = exp(.dispersion_parameter(model, minfo))) + } } else if (minfo$is_poisson && minfo$is_zero_inflated && !minfo$is_hurdle) { function(x, mean, pis, n) { ind0 <- x == 0 @@ -95,14 +114,20 @@ performance_score <- function(model, verbose = TRUE, ...) { } else if (minfo$is_zero_inflated && minfo$is_negbin && !minfo$is_hurdle) { function(x, mean, pis, n) { ind0 <- x == 0 - out <- (1 - pis) * stats::dnbinom(x, mu = mean / (1 - pis), size = exp(.dispersion_parameter(model, minfo))) + out <- (1 - pis) * + stats::dnbinom( + x, + mu = mean / (1 - pis), + size = exp(.dispersion_parameter(model, minfo)) + ) out[ind0] <- pis[ind0] + out[ind0] out } } else if (minfo$is_hurdle && minfo$is_poisson) { function(x, mean, pis, n) { ind0 <- x == 0 - trunc_zero <- stats::dpois(x, lambda = mean) / stats::ppois(0, lambda = mean, lower.tail = FALSE) + trunc_zero <- stats::dpois(x, lambda = mean) / + stats::ppois(0, lambda = mean, lower.tail = FALSE) out <- (1 - pis) * trunc_zero out[ind0] <- pis[ind0] out @@ -110,8 +135,17 @@ performance_score <- function(model, verbose = TRUE, ...) { } else if (minfo$is_hurdle && minfo$is_negbin) { function(x, mean, pis, n) { ind0 <- x == 0 - trunc_zero <- stats::dnbinom(x, mu = mean, size = exp(.dispersion_parameter(model, minfo))) / - stats::pnbinom(0, mu = mean, size = exp(.dispersion_parameter(model, minfo)), lower.tail = FALSE) + trunc_zero <- stats::dnbinom( + x, + mu = mean, + size = exp(.dispersion_parameter(model, minfo)) + ) / + stats::pnbinom( + 0, + mu = mean, + size = exp(.dispersion_parameter(model, minfo)), + lower.tail = FALSE + ) out <- (1 - pis) * trunc_zero out[ind0] <- pis[ind0] out @@ -124,7 +158,12 @@ performance_score <- function(model, verbose = TRUE, ...) { } else { datawizard::to_numeric(resp, dummy_factors = FALSE, preserve_levels = TRUE) } - p_y <- .safe(suppressWarnings(prob_fun(resp, mean = pr$pred, pis = pr$pred_zi, sum(resp)))) + p_y <- .safe(suppressWarnings(prob_fun( + resp, + mean = pr$pred, + pis = pr$pred_zi, + sum(resp) + ))) if (is.null(p_y) || all(is.na(p_y))) { if (verbose) { diff --git a/R/print-methods.R b/R/print-methods.R index 0358d99c4..5ca89c474 100644 --- a/R/print-methods.R +++ b/R/print-methods.R @@ -27,13 +27,25 @@ print.r2_generic <- function(x, digits = 3, ...) { out[1] <- .add_r2_ci_to_print(out[1], x$R2[2], x$R2[3], digits = digits) } if (!is.null(x$R2_adjusted) && length(x$R2_adjusted) == 3 && length(out) > 1) { - out[2] <- .add_r2_ci_to_print(out[2], x$R2_adjusted[2], x$R2_adjusted[3], digits = digits) + out[2] <- .add_r2_ci_to_print( + out[2], + x$R2_adjusted[2], + x$R2_adjusted[3], + digits = digits + ) } if (!is.null(x$R2_within) && length(x$R2_within) == 3 && length(out) > 2) { out[3] <- .add_r2_ci_to_print(out[3], x$R2_within[2], x$R2_within[3], digits = digits) } - if (!is.null(x$R2_within_adjusted) && length(x$R2_within_adjusted) == 3 && length(out) > 3) { - out[4] <- .add_r2_ci_to_print(out[4], x$R2_within_adjusted[2], x$R2_within_adjusted[3], digits = digits) + if ( + !is.null(x$R2_within_adjusted) && length(x$R2_within_adjusted) == 3 && length(out) > 3 + ) { + out[4] <- .add_r2_ci_to_print( + out[4], + x$R2_within_adjusted[2], + x$R2_within_adjusted[3], + digits = digits + ) } # separate lines for multiple R2 @@ -123,10 +135,18 @@ print.r2_bayes <- function(x, digits = 3, ...) { ci = attributes(x)$CI$R2_Bayes_marginal$CI, digits = digits ) - out <- paste(c( - out, - sprintf(" Marginal R2: %.*f (%s)", digits, x$R2_Bayes_marginal, r2_marginal_ci) - ), collapse = "\n") + out <- paste( + c( + out, + sprintf( + " Marginal R2: %.*f (%s)", + digits, + x$R2_Bayes_marginal, + r2_marginal_ci + ) + ), + collapse = "\n" + ) } cat(out) @@ -154,10 +174,13 @@ print.r2_loo <- function(x, digits = 3, ...) { ci = attributes(x)$CI$R2_loo_marginal$CI, digits = digits ) - out <- paste(c( - out, - sprintf(" Marginal R2: %.*f (%s)", digits, x$R2_loo_marginal, r2_marginal_ci) - ), collapse = "\n") + out <- paste( + c( + out, + sprintf(" Marginal R2: %.*f (%s)", digits, x$R2_loo_marginal, r2_marginal_ci) + ), + collapse = "\n" + ) } cat(out) diff --git a/R/print_md.R b/R/print_md.R index 9aba17638..583d64467 100644 --- a/R/print_md.R +++ b/R/print_md.R @@ -1,10 +1,12 @@ #' @rdname display.performance_model #' @export -print_md.performance_model <- function(x, - digits = 2, - caption = "Indices of model performance", - layout = "horizontal", - ...) { +print_md.performance_model <- function( + x, + digits = 2, + caption = "Indices of model performance", + layout = "horizontal", + ... +) { layout <- insight::validate_argument(layout, c("horizontal", "vertical")) formatted_table <- format( x = x, @@ -15,7 +17,10 @@ print_md.performance_model <- function(x, # switch to vertical layout if (layout == "vertical") { - formatted_table <- datawizard::rownames_as_column(as.data.frame(t(formatted_table)), "Metric") + formatted_table <- datawizard::rownames_as_column( + as.data.frame(t(formatted_table)), + "Metric" + ) colnames(formatted_table)[2] <- "Value" } @@ -32,22 +37,33 @@ print_md.performance_model <- function(x, #' @rdname display.performance_model #' @export -print_md.compare_performance <- function(x, - digits = 2, - caption = "Comparison of Model Performance Indices", - layout = "horizontal", - ...) { +print_md.compare_performance <- function( + x, + digits = 2, + caption = "Comparison of Model Performance Indices", + layout = "horizontal", + ... +) { layout <- insight::validate_argument(layout, c("horizontal", "vertical")) - .print_md_compare_performance(x, digits = digits, caption = caption, layout = layout, format = "markdown", ...) + .print_md_compare_performance( + x, + digits = digits, + caption = caption, + layout = layout, + format = "markdown", + ... + ) } #' @export -print_html.compare_performance <- function(x, - digits = 2, - caption = "Comparison of Model Performance Indices", - layout = "horizontal", - ...) { +print_html.compare_performance <- function( + x, + digits = 2, + caption = "Comparison of Model Performance Indices", + layout = "horizontal", + ... +) { layout <- insight::validate_argument(layout, c("horizontal", "vertical")) .print_md_compare_performance( x, @@ -62,12 +78,14 @@ print_html.compare_performance <- function(x, # helper ------------------------------------ -.print_md_compare_performance <- function(x, - digits = 2, - caption = "Comparison of Model Performance Indices", - layout = "horizontal", - format = "markdown", - ...) { +.print_md_compare_performance <- function( + x, + digits = 2, + caption = "Comparison of Model Performance Indices", + layout = "horizontal", + format = "markdown", + ... +) { layout <- insight::validate_argument(layout, c("horizontal", "vertical")) formatted_table <- format(x = x, digits = digits, format = format, ...) @@ -84,7 +102,10 @@ print_html.compare_performance <- function(x, # switch to vertical layout if (layout == "vertical") { - formatted_table <- datawizard::rownames_as_column(as.data.frame(t(formatted_table)), "Metric") + formatted_table <- datawizard::rownames_as_column( + as.data.frame(t(formatted_table)), + "Metric" + ) formatted_table <- datawizard::row_to_colnames(formatted_table) colnames(formatted_table)[1] <- "Metric" } diff --git a/R/r2.R b/R/r2.R index fbc7f983a..a6e077cb4 100644 --- a/R/r2.R +++ b/R/r2.R @@ -93,7 +93,10 @@ r2.default <- function(model, ci = NULL, verbose = TRUE, ...) { ) if (is.null(out) && isTRUE(verbose)) { - insight::print_color(sprintf("`r2()` does not support models of class `%s`.\n", class(model)[1]), "red") + insight::print_color( + sprintf("`r2()` does not support models of class `%s`.\n", class(model)[1]), + "red" + ) } if (!is.null(out)) { @@ -210,7 +213,8 @@ r2.cph <- r2.ols r2.mhurdle <- function(model, ...) { resp <- insight::get_response(model, verbose = FALSE) mean_resp <- mean(resp, na.rm = TRUE) - ftd <- model$fitted.values[, "pos", drop = TRUE] * (1 - model$fitted.values[, "zero", drop = TRUE]) + ftd <- model$fitted.values[, "pos", drop = TRUE] * + (1 - model$fitted.values[, "zero", drop = TRUE]) n <- length(resp) K <- insight::n_parameters(model) Ko <- length(model$naive$coefficients) @@ -296,7 +300,9 @@ r2.glm <- function(model, ci = NULL, verbose = TRUE, ...) { class(out) <- c("r2_pseudo", class(out)) } else if (info$is_binomial && !info$is_bernoulli && class(model)[1] == "glm") { if (verbose) { - insight::format_warning("Can't calculate accurate R2 for binomial models that are not Bernoulli models.") + insight::format_warning( + "Can't calculate accurate R2 for binomial models that are not Bernoulli models." + ) } out <- NULL } else if (info$is_orderedbeta) { @@ -329,7 +335,6 @@ r2.nestedLogit <- function(model, ci = NULL, verbose = TRUE, ...) { # mfx models --------------------- - #' @export r2.logitmfx <- function(model, ...) { r2(model$fit, ...) @@ -365,7 +370,6 @@ r2.model_fit <- r2.logitmfx # Cox & Snell R2 --------------------- - #' @export r2.BBreg <- function(model, ...) { out <- list(R2_CoxSnell = r2_coxsnell(model)) @@ -383,7 +387,6 @@ r2.bayesx <- r2.BBreg # Nagelkerke R2 ---------------------- - #' @export r2.censReg <- function(model, ...) { out <- list(R2_Nagelkerke = r2_nagelkerke(model)) @@ -438,7 +441,6 @@ r2.mblogit <- function(model, ...) { # McFadden ---------------------- - #' @export r2.multinom <- function(model, ...) { out <- r2_mcfadden(model) @@ -452,7 +454,6 @@ r2.mlogit <- r2.multinom # Zeroinflated R2 ------------------ - #' @export r2.hurdle <- function(model, ...) { r2_zeroinflated(model) @@ -467,7 +468,6 @@ r2.zeroinfl <- r2.hurdle # Nakagawa R2 ---------------------- - #' @rdname r2 #' @export r2.merMod <- function(model, ci = NULL, tolerance = 1e-5, ...) { @@ -521,7 +521,9 @@ r2.glmmTMB <- function(model, ci = NULL, tolerance = 1e-5, verbose = TRUE, ...) # currently, beta-binomial models without proportion response are not supported if (matrix_response) { if (verbose) { - insight::format_warning("Can't calculate accurate R2 for beta-binomial models with matrix-response formulation.") + insight::format_warning( + "Can't calculate accurate R2 for beta-binomial models with matrix-response formulation." + ) } out <- NULL } else { @@ -531,7 +533,9 @@ r2.glmmTMB <- function(model, ci = NULL, tolerance = 1e-5, verbose = TRUE, ...) } else if (info$is_binomial && !info$is_bernoulli) { # currently, non-bernoulli binomial models are not supported if (verbose) { - insight::format_warning("Can't calculate accurate R2 for binomial models that are not Bernoulli models.") + insight::format_warning( + "Can't calculate accurate R2 for binomial models that are not Bernoulli models." + ) } out <- NULL } else if ((info$is_poisson && !info$is_zero_inflated) || info$is_exponential) { @@ -608,7 +612,6 @@ r2.sem <- function(model, ...) { # Bayes R2 ------------------------ - #' @export r2.brmsfit <- function(model, ...) { r2_bayes(model, ...) @@ -624,7 +627,6 @@ r2.BFBayesFactor <- r2.brmsfit # Other methods ------------------------------ - #' @export r2.gam <- function(model, ...) { # gamlss inherits from gam, and summary.gamlss prints results automatically @@ -682,19 +684,25 @@ r2.fixest <- function(model, ...) { r2 <- fixest::r2(model) - out_normal <- insight::compact_list(list( - R2 = r2["r2"], - R2_adjusted = r2["ar2"], - R2_within = r2["wr2"], - R2_within_adjusted = r2["war2"] - ), remove_na = TRUE) + out_normal <- insight::compact_list( + list( + R2 = r2["r2"], + R2_adjusted = r2["ar2"], + R2_within = r2["wr2"], + R2_within_adjusted = r2["war2"] + ), + remove_na = TRUE + ) - out_pseudo <- insight::compact_list(list( - R2 = r2["pr2"], - R2_adjusted = r2["apr2"], - R2_within = r2["wpr2"], - R2_within_adjusted = r2["wapr2"] - ), remove_na = TRUE) + out_pseudo <- insight::compact_list( + list( + R2 = r2["pr2"], + R2_adjusted = r2["apr2"], + R2_within = r2["wpr2"], + R2_within_adjusted = r2["wapr2"] + ), + remove_na = TRUE + ) if (length(out_normal)) { out <- out_normal @@ -812,7 +820,9 @@ r2.mmclogit <- function(model, ...) { #' @export r2.Arima <- function(model, ...) { if (requireNamespace("forecast", quietly = TRUE)) { - list(R2 = stats::cor(stats::fitted(model), insight::get_data(model, verbose = FALSE))^2) + list( + R2 = stats::cor(stats::fitted(model), insight::get_data(model, verbose = FALSE))^2 + ) } else { list(R2 = NA) } @@ -886,11 +896,25 @@ r2.DirichletRegModel <- function(model, ...) { # helper ------------------- -.check_r2_ci_args <- function(ci = NULL, ci_method = "bootstrap", valid_ci_method = NULL, verbose = TRUE) { - if (!is.null(ci) && !is.na(ci) && !is.null(valid_ci_method) && !ci_method %in% valid_ci_method) { +.check_r2_ci_args <- function( + ci = NULL, + ci_method = "bootstrap", + valid_ci_method = NULL, + verbose = TRUE +) { + if ( + !is.null(ci) && + !is.na(ci) && + !is.null(valid_ci_method) && + !ci_method %in% valid_ci_method + ) { if (verbose) { insight::format_warning( - paste0("Method `", ci_method, "` to compute confidence intervals for R2 not supported.") + paste0( + "Method `", + ci_method, + "` to compute confidence intervals for R2 not supported." + ) ) } return(NULL) diff --git a/R/r2_bayes.R b/R/r2_bayes.R index c12319a0e..5d3332202 100644 --- a/R/r2_bayes.R +++ b/R/r2_bayes.R @@ -267,11 +267,13 @@ r2_posterior.stanmvreg <- function(model, verbose = TRUE, ...) { #' @inheritParams r2_bayes #' @export #' @rdname r2_bayes -r2_posterior.BFBayesFactor <- function(model, - average = FALSE, - prior_odds = NULL, - verbose = TRUE, - ...) { +r2_posterior.BFBayesFactor <- function( + model, + average = FALSE, + prior_odds = NULL, + verbose = TRUE, + ... +) { mi <- insight::model_info(model, verbose = FALSE) if (!mi$is_linear || mi$is_correlation || mi$is_ttest || mi$is_binomial || mi$is_meta) { if (verbose) { @@ -313,7 +315,11 @@ r2_posterior.BFBayesFactor <- function(model, BFMods$BF <- exp(BFMods$log_BF) } - has_random <- !is.null(insight::find_predictors(model, effects = "random", flatten = TRUE)) + has_random <- !is.null(insight::find_predictors( + model, + effects = "random", + flatten = TRUE + )) if (any(is.na(BFMods$BF) | is.infinite(BFMods$BF))) { if (verbose) { @@ -343,7 +349,6 @@ r2_posterior.BFBayesFactor <- function(model, } } - # Compute posterior model probabilities if (is.null(prior_odds)) { prior_odds <- rep(1, nrow(BFMods)) @@ -415,12 +420,18 @@ as.data.frame.r2_bayes <- function(x, ...) { colnames(mm)[1] <- "mu" # match? - if ((length(colnames(params_theta)) != length(colnames(mm))) || - !all(colnames(params_theta) == colnames(mm))) { + if ( + (length(colnames(params_theta)) != length(colnames(mm))) || + !all(colnames(params_theta) == colnames(mm)) + ) { if (utils::packageVersion("BayesFactor") < package_version("0.9.12.4.3")) { - insight::format_error("R2 for BayesFactor models with random effects requires BayesFactor v0.9.12.4.3 or higher.") + insight::format_error( + "R2 for BayesFactor models with random effects requires BayesFactor v0.9.12.4.3 or higher." + ) } - insight::format_error("Woops, you seem to have stumbled on some weird edge case. Please file an issue at {.url https://github.com/easystats/performance/issues}") # nolint + insight::format_error( + "Woops, you seem to have stumbled on some weird edge case. Please file an issue at {.url https://github.com/easystats/performance/issues}" + ) # nolint } out <- list( @@ -428,7 +439,12 @@ as.data.frame.r2_bayes <- function(x, ...) { y_pred = (as.matrix(params_theta) %*% t(mm)) ) - rand <- insight::find_predictors(model[1], effects = "random", flatten = TRUE, verbose = FALSE) + rand <- insight::find_predictors( + model[1], + effects = "random", + flatten = TRUE, + verbose = FALSE + ) if (!is.null(rand)) { idx <- sapply(paste0("\\b", rand, "\\b"), grepl, x = colnames(params_theta)) idx <- apply(idx, 1, any) diff --git a/R/r2_ci.R b/R/r2_ci.R index 1a3ecc72a..fd2fb4476 100644 --- a/R/r2_ci.R +++ b/R/r2_ci.R @@ -46,15 +46,18 @@ .dRsq <- function(K1, R2_pop, R2_obs, p, nobs) { NCP <- R2_pop / (1 - R2_pop) F1_obs <- ((nobs - p - 1) / p) * (R2_obs / (1 - R2_obs)) - exp(log( - suppressWarnings(stats::pf( - q = F1_obs, - df1 = p, - df2 = (nobs - p - 1), - ncp = NCP * K1, - lower.tail = FALSE - )) - ) + stats::dchisq(x = K1, df = (nobs - 1), log = TRUE)) + exp( + log( + suppressWarnings(stats::pf( + q = F1_obs, + df1 = p, + df2 = (nobs - p - 1), + ncp = NCP * K1, + lower.tail = FALSE + )) + ) + + stats::dchisq(x = K1, df = (nobs - 1), log = TRUE) + ) } @@ -65,8 +68,10 @@ integrals <- mapply( function(i, j, ...) { dots <- list(...) - stats::integrate(.dRsq, - i, j, + stats::integrate( + .dRsq, + i, + j, R2_pop = dots$R2_pop, R2_obs = dots$R2_obs, p = dots$p, diff --git a/R/r2_coxsnell.R b/R/r2_coxsnell.R index 0c47df07c..c0e29374c 100644 --- a/R/r2_coxsnell.R +++ b/R/r2_coxsnell.R @@ -39,7 +39,6 @@ r2_coxsnell <- function(model, ...) { # helper --------------------------- - .r2_coxsnell <- function(model, l_base) { l_full <- insight::get_loglikelihood(model) G2 <- -2 * (l_base - l_full) @@ -61,7 +60,6 @@ r2_coxsnell <- function(model, ...) { # r2-coxsnell based on model information --------------------------- - #' @export r2_coxsnell.glm <- function(model, verbose = TRUE, ...) { info <- list(...)$model_info @@ -71,16 +69,25 @@ r2_coxsnell.glm <- function(model, verbose = TRUE, ...) { matrix_response <- grepl("cbind", insight::find_response(model), fixed = TRUE) # Cox & Snell's R2 is not defined for binomial models that are not Bernoulli models - if (info$is_binomial && !info$is_betabinomial && !info$is_bernoulli && class(model)[1] %in% c("glm", "glmmTMB")) { + if ( + info$is_binomial && + !info$is_betabinomial && + !info$is_bernoulli && + class(model)[1] %in% c("glm", "glmmTMB") + ) { if (verbose) { - insight::format_alert("Can't calculate accurate R2 for binomial models that are not Bernoulli models.") + insight::format_alert( + "Can't calculate accurate R2 for binomial models that are not Bernoulli models." + ) } return(NULL) } # currently, beta-binomial models without proportion response are not supported if (info$is_betabinomial && matrix_response) { if (verbose) { - insight::format_warning("Can't calculate accurate R2 for beta-binomial models with matrix-response formulation.") + insight::format_warning( + "Can't calculate accurate R2 for beta-binomial models with matrix-response formulation." + ) } return(NULL) } @@ -88,7 +95,10 @@ r2_coxsnell.glm <- function(model, verbose = TRUE, ...) { if (is.null(model$deviance)) { return(NULL) } - r2_coxsnell <- (1 - exp((model$deviance - model$null.deviance) / insight::n_obs(model, disaggregate = TRUE))) + r2_coxsnell <- (1 - + exp( + (model$deviance - model$null.deviance) / insight::n_obs(model, disaggregate = TRUE) + )) names(r2_coxsnell) <- "Cox & Snell's R2" r2_coxsnell } @@ -106,7 +116,9 @@ r2_coxsnell.glmmTMB <- function(model, verbose = TRUE, ...) { # Cox & Snell's R2 is not defined for binomial models that are not Bernoulli models if (info$is_binomial && !info$is_bernoulli && !info$is_betabinomial) { if (verbose) { - insight::format_alert("Can't calculate accurate R2 for binomial models that are not Bernoulli models.") + insight::format_alert( + "Can't calculate accurate R2 for binomial models that are not Bernoulli models." + ) } return(NULL) } @@ -169,7 +181,6 @@ r2_coxsnell.bife <- function(model, ...) { # mfx models --------------------- - #' @export r2_coxsnell.logitmfx <- function(model, ...) { r2_coxsnell(model$fit, ...) @@ -196,7 +207,6 @@ r2_coxsnell.negbinmfx <- r2_coxsnell.logitmfx # r2-coxsnell based on loglik stored in model object --------------------------- - #' @export r2_coxsnell.coxph <- function(model, ...) { l_base <- model$loglik[1] @@ -215,7 +225,6 @@ r2_coxsnell.svycoxph <- function(model, ...) { # r2-coxsnell based on loglik of null-model (update) --------------------------- - #' @export r2_coxsnell.multinom <- function(model, ...) { l_base <- insight::get_loglikelihood(insight::null_model(model)) diff --git a/R/r2_efron.R b/R/r2_efron.R index ee9ccd262..fe578ac22 100644 --- a/R/r2_efron.R +++ b/R/r2_efron.R @@ -41,6 +41,11 @@ r2_efron.default <- function(model) { .r2_efron <- function(model) { y_hat <- stats::predict(model, type = "response") - y <- datawizard::to_numeric(insight::get_response(model, verbose = FALSE), dummy_factors = FALSE, preserve_levels = TRUE, lowest = 0) + y <- datawizard::to_numeric( + insight::get_response(model, verbose = FALSE), + dummy_factors = FALSE, + preserve_levels = TRUE, + lowest = 0 + ) (1 - (sum((y - y_hat)^2)) / (sum((y - mean(y))^2))) } diff --git a/R/r2_ferarri.R b/R/r2_ferarri.R index 402c95fdf..5966c45c7 100644 --- a/R/r2_ferarri.R +++ b/R/r2_ferarri.R @@ -46,7 +46,6 @@ r2_ferrari.default <- function(model, correct_bounds = FALSE, ...) { structure(class = "r2_generic", out) } - # helper ----------------------------- # .r2_ferrari <- function(model, x) { diff --git a/R/r2_loo.R b/R/r2_loo.R index 4aaa8dcab..e91dae8ed 100644 --- a/R/r2_loo.R +++ b/R/r2_loo.R @@ -72,7 +72,9 @@ r2_loo_posterior.brmsfit <- function(model, verbose = TRUE, ...) { algorithm <- insight::find_algorithm(model) if (algorithm$algorithm != "sampling") { - insight::format_warning("`r2()` only available for models fit using the \"sampling\" algorithm.") + insight::format_warning( + "`r2()` only available for models fit using the \"sampling\" algorithm." + ) return(NA) } diff --git a/R/r2_mcfadden.R b/R/r2_mcfadden.R index bf1bbb851..2c865fa65 100644 --- a/R/r2_mcfadden.R +++ b/R/r2_mcfadden.R @@ -31,7 +31,6 @@ r2_mcfadden <- function(model, ...) { # helper ----------------------- - .r2_mcfadden <- function(model, l_null) { l_full <- insight::get_loglikelihood(model) k <- length(insight::find_parameters(model)) @@ -50,7 +49,6 @@ r2_mcfadden <- function(model, ...) { # r2 via loglik and update -------------------------- - #' @export r2_mcfadden.glm <- function(model, verbose = TRUE, ...) { info <- list(...)$model_info @@ -59,16 +57,25 @@ r2_mcfadden.glm <- function(model, verbose = TRUE, ...) { } matrix_response <- grepl("cbind", insight::find_response(model), fixed = TRUE) - if (info$is_binomial && !info$is_betabinomial && !info$is_bernoulli && class(model)[1] %in% c("glm", "glmmTMB")) { + if ( + info$is_binomial && + !info$is_betabinomial && + !info$is_bernoulli && + class(model)[1] %in% c("glm", "glmmTMB") + ) { if (verbose) { - insight::format_warning("Can't calculate accurate R2 for binomial models that are not Bernoulli models.") + insight::format_warning( + "Can't calculate accurate R2 for binomial models that are not Bernoulli models." + ) } return(NULL) } # currently, beta-binomial models without proportion response are not supported if (info$is_betabinomial && matrix_response) { if (verbose) { - insight::format_warning("Can't calculate accurate R2 for beta-binomial models with matrix-response formulation.") + insight::format_warning( + "Can't calculate accurate R2 for beta-binomial models with matrix-response formulation." + ) } return(NULL) } @@ -128,7 +135,6 @@ r2_mcfadden.mblogit <- function(model, ...) { # mfx models --------------------- - #' @export r2_mcfadden.logitmfx <- function(model, ...) { r2_mcfadden(model$fit, ...) @@ -155,7 +161,6 @@ r2_mcfadden.negbinmfx <- r2_mcfadden.logitmfx # special models ------------------------------------------- - #' @export r2_mcfadden.vglm <- function(model, ...) { if (!(is.null(model@call$summ) && !identical(model@call$summ, 0))) { diff --git a/R/r2_mckelvey.R b/R/r2_mckelvey.R index 4a76e6311..55fcd8605 100644 --- a/R/r2_mckelvey.R +++ b/R/r2_mckelvey.R @@ -46,14 +46,16 @@ r2_mckelvey.default <- function(model) { n <- insight::n_obs(model, disaggregate = TRUE) if (faminfo$is_binomial || faminfo$is_ordinal || faminfo$is_multinomial) { - dist.variance <- switch(faminfo$link_function, + dist.variance <- switch( + faminfo$link_function, probit = 1, logit = pi^2 / 3, clogloglink = pi^2 / 6, NA ) } else if (faminfo$is_count) { - dist.variance <- switch(faminfo$link_function, + dist.variance <- switch( + faminfo$link_function, log = .get_poisson_variance(model), sqrt = 0.25, 0 @@ -64,7 +66,9 @@ r2_mckelvey.default <- function(model) { # fix for VGAM yhat_columns <- ncol(y.hat) - if (!is.null(yhat_columns) && yhat_columns > 1) y.hat <- as.vector(y.hat[, 1]) + if (!is.null(yhat_columns) && yhat_columns > 1) { + y.hat <- as.vector(y.hat[, 1]) + } dist.residual <- sum((y.hat - mean(y.hat))^2) diff --git a/R/r2_mlm.R b/R/r2_mlm.R index 240701439..1fbc0798d 100644 --- a/R/r2_mlm.R +++ b/R/r2_mlm.R @@ -69,10 +69,11 @@ r2_mlm <- function(model, ...) { #' @export r2_mlm.mlm <- function(model, verbose = TRUE, ...) { - rho2_vec <- 1 - stats::cancor( - insight::get_predictors(model), - insight::get_response(model) - )$cor^2 + rho2_vec <- 1 - + stats::cancor( + insight::get_predictors(model), + insight::get_response(model) + )$cor^2 R_xy <- 1 - Reduce(`*`, rho2_vec, 1) resid_cov <- stats::cov(residuals(model)) diff --git a/R/r2_nagelkerke.R b/R/r2_nagelkerke.R index f7042d1c0..8cd42ff2c 100644 --- a/R/r2_nagelkerke.R +++ b/R/r2_nagelkerke.R @@ -24,7 +24,6 @@ r2_nagelkerke <- function(model, ...) { # helper --------------------------- - .r2_nagelkerke <- function(model, l_base) { L.full <- insight::get_loglikelihood(model) D.full <- -2 * L.full @@ -56,7 +55,9 @@ r2_nagelkerke.glm <- function(model, verbose = TRUE, ...) { if (info$is_binomial && !info$is_bernoulli && class(model)[1] == "glm") { if (verbose) { - insight::format_warning("Can't calculate accurate R2 for binomial models that are not Bernoulli models.") + insight::format_warning( + "Can't calculate accurate R2 for binomial models that are not Bernoulli models." + ) } return(NULL) } @@ -67,7 +68,8 @@ r2_nagelkerke.glm <- function(model, verbose = TRUE, ...) { return(NULL) } - r2_nagelkerke <- r2cox / (1 - exp(-model$null.deviance / insight::n_obs(model, disaggregate = TRUE))) + r2_nagelkerke <- r2cox / + (1 - exp(-model$null.deviance / insight::n_obs(model, disaggregate = TRUE))) names(r2_nagelkerke) <- "Nagelkerke's R2" r2_nagelkerke } @@ -85,7 +87,9 @@ r2_nagelkerke.glmmTMB <- function(model, verbose = TRUE, ...) { if (info$is_binomial && !info$is_bernoulli) { if (verbose) { - insight::format_warning("Can't calculate accurate R2 for binomial models that are not Bernoulli models.") + insight::format_warning( + "Can't calculate accurate R2 for binomial models that are not Bernoulli models." + ) } return(NULL) } @@ -105,7 +109,8 @@ r2_nagelkerke.glmmTMB <- function(model, verbose = TRUE, ...) { return(NULL) } - r2_nagelkerke <- r2cox / (1 - exp(-null_dev / insight::n_obs(model, disaggregate = TRUE))) + r2_nagelkerke <- r2cox / + (1 - exp(-null_dev / insight::n_obs(model, disaggregate = TRUE))) names(r2_nagelkerke) <- "Nagelkerke's R2" r2_nagelkerke } @@ -121,7 +126,8 @@ r2_nagelkerke.nestedLogit <- function(model, ...) { if (is.null(m$deviance)) { return(NA) } - r2_nagelkerke <- (1 - exp((m$deviance - m$null.deviance) / n[[i]])) / (1 - exp(-m$null.deviance / n[[i]])) + r2_nagelkerke <- (1 - exp((m$deviance - m$null.deviance) / n[[i]])) / + (1 - exp(-m$null.deviance / n[[i]])) names(r2_nagelkerke) <- "Nagelkerke's R2" r2_nagelkerke }), @@ -132,7 +138,8 @@ r2_nagelkerke.nestedLogit <- function(model, ...) { #' @export r2_nagelkerke.bife <- function(model, ...) { - r2_nagelkerke <- r2_coxsnell(model) / (1 - exp(-model$null_deviance / insight::n_obs(model))) + r2_nagelkerke <- r2_coxsnell(model) / + (1 - exp(-model$null_deviance / insight::n_obs(model))) names(r2_nagelkerke) <- "Nagelkerke's R2" r2_nagelkerke } @@ -140,7 +147,6 @@ r2_nagelkerke.bife <- function(model, ...) { # mfx models --------------------- - #' @export r2_nagelkerke.logitmfx <- function(model, ...) { r2_nagelkerke(model$fit, ...) @@ -167,7 +173,6 @@ r2_nagelkerke.negbinmfx <- r2_nagelkerke.logitmfx # Nagelkerke's R2 based on LogLik ---------------- - #' @export r2_nagelkerke.multinom <- function(model, ...) { l_base <- insight::get_loglikelihood(insight::null_model(model)) @@ -220,7 +225,6 @@ r2_nagelkerke.DirichletRegModel <- r2_coxsnell.clm # Nagelkerke's R2 based on LogLik stored in model object ---------------- - #' @export r2_nagelkerke.coxph <- function(model, ...) { l_base <- model$loglik[1] diff --git a/R/r2_xu.R b/R/r2_xu.R index 4ef7b7b7d..0e9e1f8d2 100644 --- a/R/r2_xu.R +++ b/R/r2_xu.R @@ -26,7 +26,9 @@ r2_xu <- function(model) { insight::format_error("Xu's R2 is only applicable for linear models.") } - .r2_xu <- 1 - stats::var(stats::residuals(model, verbose = FALSE)) / stats::var(insight::get_response(model, verbose = FALSE)) + .r2_xu <- 1 - + stats::var(stats::residuals(model, verbose = FALSE)) / + stats::var(insight::get_response(model, verbose = FALSE)) names(.r2_xu) <- "Xu's R2" .r2_xu } diff --git a/R/residuals.R b/R/residuals.R index 01e5c4bc2..949abf4a1 100644 --- a/R/residuals.R +++ b/R/residuals.R @@ -1,4 +1,9 @@ #' @exportS3Method residuals iv_robust residuals.iv_robust <- function(object, ...) { - datawizard::to_numeric(insight::get_response(object, verbose = FALSE), dummy_factors = FALSE, preserve_levels = TRUE) - object$fitted.values + datawizard::to_numeric( + insight::get_response(object, verbose = FALSE), + dummy_factors = FALSE, + preserve_levels = TRUE + ) - + object$fitted.values } diff --git a/R/simulate_residuals.R b/R/simulate_residuals.R index 1f58218c0..e5e735363 100644 --- a/R/simulate_residuals.R +++ b/R/simulate_residuals.R @@ -90,8 +90,11 @@ print.performance_simres <- function(x, ...) { # DHARMa uses, but with an easystats style. For now we can just stick with # DHARMa's method. msg <- paste0( - "Simulated residuals from a model of class `", class(x$fittedModel)[1], - "` based on ", x$nSim, " simulations. Use `check_residuals()` to check", + "Simulated residuals from a model of class `", + class(x$fittedModel)[1], + "` based on ", + x$nSim, + " simulations. Use `check_residuals()` to check", " uniformity of residuals or `residuals()` to extract simulated residuals.", " It is recommended to refer to `?DHARMa::simulateResiudals` and", " `vignette(\"DHARMa\")` for more information about different settings", @@ -111,7 +114,12 @@ plot.performance_simres <- function(x, ...) { #' @rdname simulate_residuals #' @export -residuals.performance_simres <- function(object, quantile_function = NULL, outlier_values = NULL, ...) { +residuals.performance_simres <- function( + object, + quantile_function = NULL, + outlier_values = NULL, + ... +) { # check for DHARMa argument names dots <- list(...) if (!is.null(dots$quantileFunction)) { @@ -153,7 +161,8 @@ residuals.performance_simres <- function(object, quantile_function = NULL, outli simulated <- apply(x$simulatedResponse, 2, statistic_fun) } # p is simply ratio of simulated zeros to observed zeros - p <- switch(alternative, + p <- switch( + alternative, greater = mean(simulated >= observed), less = mean(simulated <= observed), min(min(mean(simulated <= observed), mean(simulated >= observed)) * 2, 1) diff --git a/R/test_bf.R b/R/test_bf.R index 658883c76..eb78461f9 100644 --- a/R/test_bf.R +++ b/R/test_bf.R @@ -22,7 +22,12 @@ test_bf.default <- function(..., reference = 1, text_length = NULL) { } # If a suitable class is found, run the more specific method on it - if (inherits(my_objects, c("ListNestedRegressions", "ListNonNestedRegressions", "ListLavaan"))) { + if ( + inherits( + my_objects, + c("ListNestedRegressions", "ListNonNestedRegressions", "ListLavaan") + ) + ) { test_bf(my_objects, reference = reference, text_length = text_length) } else { insight::format_error("The models cannot be compared for some reason :/") @@ -33,7 +38,9 @@ test_bf.default <- function(..., reference = 1, text_length = NULL) { #' @export test_bf.ListModels <- function(objects, reference = 1, text_length = NULL, ...) { if (.test_bf_areAllBayesian(objects) == "mixed") { - insight::format_error("You cannot mix Bayesian and non-Bayesian models in `test_bf()`.") + insight::format_error( + "You cannot mix Bayesian and non-Bayesian models in `test_bf()`." + ) } # Adapt reference but keep original input @@ -81,7 +88,9 @@ test_bf.ListModels <- function(objects, reference = 1, text_length = NULL, ...) # Helpers ----------------------------------------------------------------- .test_bf_areAllBayesian <- function(objects) { - bayesian_models <- sapply(objects, function(i) isTRUE(insight::model_info(i)$is_bayesian)) + bayesian_models <- sapply(objects, function(i) { + isTRUE(insight::model_info(i)$is_bayesian) + }) if (all(bayesian_models)) { "yes" diff --git a/R/test_likelihoodratio.R b/R/test_likelihoodratio.R index 5d6e394d5..6deadd348 100644 --- a/R/test_likelihoodratio.R +++ b/R/test_likelihoodratio.R @@ -29,7 +29,11 @@ test_likelihoodratio.default <- function(..., estimator = "OLS", verbose = TRUE) # different default when mixed model or glm is included if (missing(estimator)) { mixed_models <- sapply(my_objects, insight::is_mixed_model) - if (all(mixed_models) && all(sapply(my_objects, .is_lmer_reml)) && isTRUE(attributes(my_objects)$same_fixef)) { + if ( + all(mixed_models) && + all(sapply(my_objects, .is_lmer_reml)) && + isTRUE(attributes(my_objects)$same_fixef) + ) { estimator <- "REML" } else if (any(mixed_models) || !all(attributes(my_objects)$is_linear)) { estimator <- "ML" @@ -37,7 +41,10 @@ test_likelihoodratio.default <- function(..., estimator = "OLS", verbose = TRUE) } # ensure proper object names - my_objects <- .check_objectnames(my_objects, sapply(match.call(expand.dots = FALSE)[["..."]], as.character)) + my_objects <- .check_objectnames( + my_objects, + sapply(match.call(expand.dots = FALSE)[["..."]], as.character) + ) # If a suitable class is found, run the more specific method on it if (inherits(my_objects, "ListNestedRegressions")) { @@ -73,11 +80,20 @@ print.test_likelihoodratio <- function(x, digits = 2, ...) { #' @export -format.test_likelihoodratio <- function(x, digits = 2, p_digits = 3, format = "text", ...) { +format.test_likelihoodratio <- function( + x, + digits = 2, + p_digits = 3, + format = "text", + ... +) { # Footer if ("LogLik" %in% names(x)) { best <- which.max(x$LogLik) - footer <- c(sprintf("\nModel '%s' seems to have the best model fit.\n", x$Model[best]), "yellow") + footer <- c( + sprintf("\nModel '%s' seems to have the best model fit.\n", x$Model[best]), + "yellow" + ) } else { footer <- NULL } @@ -92,9 +108,15 @@ format.test_likelihoodratio <- function(x, digits = 2, p_digits = 3, format = "t } if (format == "text") { - caption <- c(paste0("# Likelihood-Ratio-Test (LRT) for Model Comparison", estimator_string), "blue") + caption <- c( + paste0("# Likelihood-Ratio-Test (LRT) for Model Comparison", estimator_string), + "blue" + ) } else { - caption <- paste0("Likelihood-Ratio-Test (LRT) for Model Comparison", estimator_string) + caption <- paste0( + "Likelihood-Ratio-Test (LRT) for Model Comparison", + estimator_string + ) } attr(x, "table_footer") <- footer @@ -105,7 +127,11 @@ format.test_likelihoodratio <- function(x, digits = 2, p_digits = 3, format = "t #' @export print_md.test_likelihoodratio <- function(x, digits = 2, ...) { - insight::export_table(format(x, digits = digits, format = "markdown", ...), format = "markdown", ...) + insight::export_table( + format(x, digits = digits, format = "markdown", ...), + format = "markdown", + ... + ) } @@ -138,7 +164,12 @@ display.test_likelihoodratio <- function(object, format = "markdown", digits = 2 # other classes --------------------------- #' @export -test_likelihoodratio.ListNestedRegressions <- function(objects, estimator = "ML", verbose = TRUE, ...) { +test_likelihoodratio.ListNestedRegressions <- function( + objects, + estimator = "ML", + verbose = TRUE, + ... +) { dfs <- sapply(objects, insight::get_df, type = "model") same_fixef <- attributes(objects)$same_fixef @@ -173,11 +204,14 @@ test_likelihoodratio.ListNestedRegressions <- function(objects, estimator = "ML" } # for REML fits, warn user - if (isTRUE(REML) && - # only when mixed models are involved, others probably don't have problems with REML fit - any(sapply(objects, insight::is_mixed_model)) && - # only if not all models have same fixed effects (else, REML is ok) - !isTRUE(same_fixef) && isTRUE(verbose)) { + if ( + isTRUE(REML) && + # only when mixed models are involved, others probably don't have problems with REML fit + any(sapply(objects, insight::is_mixed_model)) && + # only if not all models have same fixed effects (else, REML is ok) + !isTRUE(same_fixef) && + isTRUE(verbose) + ) { insight::format_warning( "The Likelihood-Ratio-Test is probably inaccurate when comparing REML-fit models with different fixed effects." ) @@ -224,7 +258,8 @@ test_likelihoodratio_ListLavaan <- function(..., objects = NULL) { # helper ---------------------- .is_lmer_reml <- function(x) { - tryCatch(inherits(x, "lmerMod") && as.logical(x@devcomp$dims[["REML"]]), + tryCatch( + inherits(x, "lmerMod") && as.logical(x@devcomp$dims[["REML"]]), error = function(e) FALSE ) } diff --git a/R/test_performance.R b/R/test_performance.R index c0bfc7809..af4a64ffc 100644 --- a/R/test_performance.R +++ b/R/test_performance.R @@ -233,7 +233,12 @@ test_performance <- function(..., reference = 1, verbose = TRUE) { # default -------------------------------- #' @export -test_performance.default <- function(..., reference = 1, include_formula = FALSE, verbose = TRUE) { +test_performance.default <- function( + ..., + reference = 1, + include_formula = FALSE, + verbose = TRUE +) { # Attribute class to list and get names from the global environment my_objects <- insight::ellipsis_info(..., only_models = TRUE) @@ -241,10 +246,18 @@ test_performance.default <- function(..., reference = 1, include_formula = FALSE my_objects <- .test_performance_checks(my_objects, verbose = verbose) # ensure proper object names - my_objects <- .check_objectnames(my_objects, sapply(match.call(expand.dots = FALSE)[["..."]], as.character)) + my_objects <- .check_objectnames( + my_objects, + sapply(match.call(expand.dots = FALSE)[["..."]], as.character) + ) # If a suitable class is found, run the more specific method on it - if (inherits(my_objects, c("ListNestedRegressions", "ListNonNestedRegressions", "ListLavaan"))) { + if ( + inherits( + my_objects, + c("ListNestedRegressions", "ListNonNestedRegressions", "ListLavaan") + ) + ) { test_performance(my_objects, reference = reference, include_formula = include_formula) } else { insight::format_error("The models cannot be compared for some reason :/") @@ -326,10 +339,12 @@ display.test_performance <- function(object, format = "markdown", digits = 2, .. # other classes ----------------------------------- #' @export -test_performance.ListNestedRegressions <- function(objects, - reference = 1, - include_formula = FALSE, - ...) { +test_performance.ListNestedRegressions <- function( + objects, + reference = 1, + include_formula = FALSE, + ... +) { out <- .test_performance_init(objects, include_formula = include_formula, ...) # BF test @@ -363,17 +378,23 @@ test_performance.ListNestedRegressions <- function(objects, ) attr(out, "is_nested") <- attributes(objects)$is_nested - attr(out, "reference") <- if (attributes(objects)$is_nested_increasing) "increasing" else "decreasing" + attr(out, "reference") <- if (attributes(objects)$is_nested_increasing) { + "increasing" + } else { + "decreasing" + } class(out) <- c("test_performance", class(out)) out } #' @export -test_performance.ListNonNestedRegressions <- function(objects, - reference = 1, - include_formula = FALSE, - ...) { +test_performance.ListNonNestedRegressions <- function( + objects, + reference = 1, + include_formula = FALSE, + ... +) { out <- .test_performance_init(objects, include_formula = include_formula, ...) # BF test @@ -421,10 +442,8 @@ test_performance.ListNonNestedRegressions <- function(objects, # lmtest::encomptest(m2, m3) # nonnest2::icci(m2, m3) - # Helpers ----------------------------------------------------------------- - .test_performance_init <- function(objects, include_formula = FALSE) { model_names <- insight::model_name(objects, include_formula = include_formula) out <- data.frame( @@ -437,7 +456,12 @@ test_performance.ListNonNestedRegressions <- function(objects, } -.test_performance_checks <- function(objects, multiple = TRUE, same_response = TRUE, verbose = TRUE) { +.test_performance_checks <- function( + objects, + multiple = TRUE, + same_response = TRUE, + verbose = TRUE +) { # TODO: we could actually generate a baseline model 'y ~ 1' whenever a single model is passed if (multiple && insight::is_model(objects)) { null_model <- .safe(insight::null_model(objects, verbose = FALSE)) @@ -455,7 +479,11 @@ test_performance.ListNonNestedRegressions <- function(objects, } } - if (same_response && !inherits(objects, "ListLavaan") && isFALSE(attributes(objects)$same_response)) { + if ( + same_response && + !inherits(objects, "ListLavaan") && + isFALSE(attributes(objects)$same_response) + ) { insight::format_error( "The models' dependent variables don't have the same data, which is a prerequisite to compare them. Probably the proportion of missing data differs between models." # nolint ) @@ -480,13 +508,15 @@ test_performance.ListNonNestedRegressions <- function(objects, # Replace with names from the global environment, if these are not yet properly set object_names <- insight::compact_character(names(objects)) # check if we have any names at all - if ((is.null(object_names) || - # or if length of names doesn't match number of models - length(object_names) != length(objects) || - # or if names are "..1", "..2" pattern - all(grepl("\\.\\.\\d", object_names))) && - # and length of dot-names must match length of objects - length(objects) == length(dot_names)) { + if ( + (is.null(object_names) || + # or if length of names doesn't match number of models + length(object_names) != length(objects) || + # or if names are "..1", "..2" pattern + all(grepl("\\.\\.\\d", object_names))) && + # and length of dot-names must match length of objects + length(objects) == length(dot_names) + ) { names(objects) <- dot_names } objects diff --git a/R/test_vuong.R b/R/test_vuong.R index 26c3d70dc..b43587f76 100644 --- a/R/test_vuong.R +++ b/R/test_vuong.R @@ -14,10 +14,18 @@ test_vuong.default <- function(..., reference = 1, verbose = TRUE) { my_objects <- .test_performance_checks(my_objects, verbose = verbose) # ensure proper object names - my_objects <- .check_objectnames(my_objects, sapply(match.call(expand.dots = FALSE)[["..."]], as.character)) + my_objects <- .check_objectnames( + my_objects, + sapply(match.call(expand.dots = FALSE)[["..."]], as.character) + ) # If a suitable class is found, run the more specific method on it - if (inherits(my_objects, c("ListNestedRegressions", "ListNonNestedRegressions", "ListLavaan"))) { + if ( + inherits( + my_objects, + c("ListNestedRegressions", "ListNonNestedRegressions", "ListLavaan") + ) + ) { test_vuong(my_objects, reference = reference) } else { insight::format_error("The models cannot be compared for some reason :/") @@ -50,9 +58,14 @@ test_vuong.ListNonNestedRegressions <- function(objects, reference = 1, ...) { # - sandwich::estfun() # - CompQuadForm::imhof() - .test_vuong <- function(objects, nested = FALSE, reference = NULL, ...) { - out <- data.frame(Omega2 = NA, p_Omega2 = NA, LR = NA, p_LR = NA, stringsAsFactors = FALSE) + out <- data.frame( + Omega2 = NA, + p_Omega2 = NA, + LR = NA, + p_LR = NA, + stringsAsFactors = FALSE + ) for (i in 2:length(objects)) { if (is.null(reference)) { @@ -86,7 +99,6 @@ test_vuong.ListNonNestedRegressions <- function(objects, reference = 1, ...) { # Vuong test for two models ----------------------------------------------- # ------------------------------------------------------------------------- - # m1 <- lm(mpg ~ disp, data=mtcars) # m2 <- lm(mpg ~ drat, data=mtcars) # ref <- nonnest2::vuongtest(m1, m2, nested=FALSE) @@ -114,7 +126,11 @@ test_vuong.ListNonNestedRegressions <- function(objects, reference = 1, ...) { # If nested==TRUE, find the full model and reverse if necessary if (nested) { - dfs <- c(insight::get_df(object1, type = "residual"), insight::get_df(object2), type = "residual") + dfs <- c( + insight::get_df(object1, type = "residual"), + insight::get_df(object2), + type = "residual" + ) if (order(dfs)[1] == 2) { temp <- object2 object2 <- object1 @@ -126,7 +142,6 @@ test_vuong.ListNonNestedRegressions <- function(objects, reference = 1, ...) { llA <- attributes(insight::get_loglikelihood(object1))$per_obs llB <- attributes(insight::get_loglikelihood(object2))$per_obs - # DISTINGUISABILITY TEST -------- # Eq (4.2) n <- insight::n_obs(object1) @@ -158,7 +173,6 @@ test_vuong.ListNonNestedRegressions <- function(objects, reference = 1, ...) { } } - # Null distribution and test stat depends on nested if (nested) { teststat <- 2 * lr @@ -253,7 +267,9 @@ test_vuong.ListNonNestedRegressions <- function(objects, reference = 1, ...) { scaling <- 1 } else { scaling <- insight::get_sigma(model, ci = NULL, verbose = FALSE)^2 - if (is.null(scaling) || is.na(scaling)) scaling <- 1 + if (is.null(scaling) || is.na(scaling)) { + scaling <- 1 + } covmat <- n * insight::get_varcov(model, component = "conditional") } diff --git a/R/test_wald.R b/R/test_wald.R index 6873cf72c..da3d7f71f 100644 --- a/R/test_wald.R +++ b/R/test_wald.R @@ -14,10 +14,18 @@ test_wald.default <- function(..., verbose = TRUE) { my_objects <- .test_performance_checks(my_objects, verbose = verbose) # ensure proper object names - my_objects <- .check_objectnames(my_objects, sapply(match.call(expand.dots = FALSE)[["..."]], as.character)) + my_objects <- .check_objectnames( + my_objects, + sapply(match.call(expand.dots = FALSE)[["..."]], as.character) + ) # If a suitable class is found, run the more specific method on it - if (inherits(my_objects, c("ListNestedRegressions", "ListNonNestedRegressions", "ListLavaan"))) { + if ( + inherits( + my_objects, + c("ListNestedRegressions", "ListNonNestedRegressions", "ListLavaan") + ) + ) { test_wald(my_objects) } else { insight::format_error("The models cannot be compared for some reason :/") @@ -48,12 +56,13 @@ test_wald.ListNestedRegressions <- function(objects, verbose = TRUE, ...) { #' @export test_wald.ListNonNestedRegressions <- function(objects, verbose = TRUE, ...) { - insight::format_error("Wald tests cannot be run on non-nested models. Try `test_vuong()`.") + insight::format_error( + "Wald tests cannot be run on non-nested models. Try `test_vuong()`." + ) } # Helpers -------------------------- - .test_wald <- function(objects, test = "F") { # Compute stuff dfs <- sapply(objects, insight::get_df, type = "residual") @@ -74,7 +83,6 @@ test_wald.ListNonNestedRegressions <- function(objects, verbose = TRUE, ...) { stringsAsFactors = FALSE ) - # Find reference-model related stuff refmodel <- order(dfs)[1] my_scale <- dev[refmodel] / dfs[refmodel] diff --git a/R/zzz-deprecated-check_heterogeneity_bias.R b/R/zzz-deprecated-check_heterogeneity_bias.R index a9aecaeee..8d31150a3 100644 --- a/R/zzz-deprecated-check_heterogeneity_bias.R +++ b/R/zzz-deprecated-check_heterogeneity_bias.R @@ -53,15 +53,24 @@ #' check_heterogeneity_bias(iris, select = c("Sepal.Length", "Petal.Length"), by = "ID") #' @export check_heterogeneity_bias <- function(x, select = NULL, by = NULL, nested = FALSE) { - insight::format_alert("`check_heterogeneity_bias()` is deprecated. Please use `check_group_variation()` instead.") + insight::format_alert( + "`check_heterogeneity_bias()` is deprecated. Please use `check_group_variation()` instead." + ) if (insight::is_model(x)) { by <- insight::find_random(x, split_nested = TRUE, flatten = TRUE) if (is.null(by)) { - insight::format_error("Model is no mixed model. Please provide a mixed model, or a data frame and arguments `select` and `by`.") # nolint + insight::format_error( + "Model is no mixed model. Please provide a mixed model, or a data frame and arguments `select` and `by`." + ) # nolint } my_data <- insight::get_data(x, source = "mf", verbose = FALSE) - select <- insight::find_predictors(x, effects = "fixed", component = "conditional", flatten = TRUE) + select <- insight::find_predictors( + x, + effects = "fixed", + component = "conditional", + flatten = TRUE + ) } else { if (inherits(select, "formula")) { select <- all.vars(select) @@ -77,7 +86,9 @@ check_heterogeneity_bias <- function(x, select = NULL, by = NULL, nested = FALSE insight::format_error("Please provide the group variable using `by`.") } if (!all(by %in% colnames(my_data))) { - insight::format_error("The variable(s) speciefied in `by` were not found in the data.") + insight::format_error( + "The variable(s) speciefied in `by` were not found in the data." + ) } # select all, if not given @@ -94,22 +105,26 @@ check_heterogeneity_bias <- function(x, select = NULL, by = NULL, nested = FALSE # create all combinations that should be checked combinations <- expand.grid(select, by[1]) - result <- Map(function(predictor, id) { - # demean predictor + result <- Map( + function(predictor, id) { + # demean predictor - d <- datawizard::demean(my_data, select = predictor, by = id, verbose = FALSE) + d <- datawizard::demean(my_data, select = predictor, by = id, verbose = FALSE) - # get new names - within_name <- paste0(predictor, "_within") + # get new names + within_name <- paste0(predictor, "_within") - # check if any within-variable differs from zero. if yes, we have - # a within-subject effect - if (any(abs(d[[within_name]]) > 1e-5)) { - predictor - } else { - NULL - } - }, as.character(combinations[[1]]), by) + # check if any within-variable differs from zero. if yes, we have + # a within-subject effect + if (any(abs(d[[within_name]]) > 1e-5)) { + predictor + } else { + NULL + } + }, + as.character(combinations[[1]]), + by + ) out <- unlist(insight::compact_list(result), use.names = FALSE) diff --git a/WIP/generate_distribution.R b/WIP/generate_distribution.R index b42e2d70d..636b943e4 100644 --- a/WIP/generate_distribution.R +++ b/WIP/generate_distribution.R @@ -11,14 +11,16 @@ rhalfcauchy <- function(n, location, scale) { } -generate_distribution <- function(family = "normal", - size = 1000, - location = 0, - scale = 1, - trials = 1, - prob = .5, - mu = 3, - zi = .2) { +generate_distribution <- function( + family = "normal", + size = 1000, + location = 0, + scale = 1, + trials = 1, + prob = .5, + mu = 3, + zi = .2 +) { if (family == "normal") { rnorm(size, location, scale) } else if (family == "beta") { @@ -72,10 +74,27 @@ generate_distribution <- function(family = "normal", df <- data.frame() distrs <- c( - "normal", "beta", "chi", "F", "exponential", "gamma", "inverse-gamma", - "lognormal", "poisson", "uniform", "negative binomial", "bernoulli", "cauchy", - "half-cauchy", "poisson (zero-infl.)", "neg. binomial (zero-infl.)", - "weibull", "beta-binomial", "binomial", "pareto", "tweedie" + "normal", + "beta", + "chi", + "F", + "exponential", + "gamma", + "inverse-gamma", + "lognormal", + "poisson", + "uniform", + "negative binomial", + "bernoulli", + "cauchy", + "half-cauchy", + "poisson (zero-infl.)", + "neg. binomial (zero-infl.)", + "weibull", + "beta-binomial", + "binomial", + "pareto", + "tweedie" ) .is.integer <- function(x) { diff --git a/WIP/r2mlm_init.R b/WIP/r2mlm_init.R index 324d8a8ff..977076a82 100644 --- a/WIP/r2mlm_init.R +++ b/WIP/r2mlm_init.R @@ -7,8 +7,6 @@ library(r2mlm) source("r2mlm_utils.R") - - r2mlm_init <- function(model) { # Step 1) check if model has_intercept has_intercept <- insight::has_intercept(model) @@ -31,7 +29,6 @@ r2mlm_init <- function(model) { } data <- dplyr::group_by(modelframe, modelframe[cluster_variable]) - # Step 3b) determine whether data is appropriate format. Only the cluster variable can be a factor, for now # a) Pull all variables except for cluster @@ -40,7 +37,9 @@ r2mlm_init <- function(model) { # b) If any of those variables is non-numeric, then throw an error for (variable in outcome_and_predictors) { - if (!(class(data[[variable]]) == "integer") && !(class(data[[variable]]) == "numeric")) { + if ( + !(class(data[[variable]]) == "integer") && !(class(data[[variable]]) == "numeric") + ) { stop("Your data must be numeric. Only the cluster variable can be a factor.") } } @@ -56,7 +55,10 @@ r2mlm_init <- function(model) { if (length(outcome_and_predictors) == 1) { predictors <- insight::find_interactions(model, flatten = TRUE) } else { - predictors <- append(outcome_and_predictors[2:length(outcome_and_predictors)], insight::find_interactions(model, flatten = TRUE)) + predictors <- append( + outcome_and_predictors[2:length(outcome_and_predictors)], + insight::find_interactions(model, flatten = TRUE) + ) } # * Step 4b) Create and fill vectors @@ -101,7 +103,7 @@ r2mlm_init <- function(model) { # 8b) gamma_b, intercept value if hasintercept = TRUE, and fixed slopes for L2 variables (from between list) gammab <- c() - if (has_intercept ) { + if (has_intercept) { gammab[1] <- fixef(model)[1] i <- 2 } else { diff --git a/WIP/r2mlm_test.R b/WIP/r2mlm_test.R index e3cde3cb0..c31f9b8fb 100644 --- a/WIP/r2mlm_test.R +++ b/WIP/r2mlm_test.R @@ -10,14 +10,35 @@ source("r2mlm_init.R") model <- lmer(satisfaction ~ salary_c + (1 + salary_c | schoolID), data = r2mlm::teachsat) l <- r2mlm_init(model) # Get list of ingredients -r2mlm::r2mlm_manual(data = l$data, within_covs = l$within_covs, between_covs = l$between_covs, random_covs = l$random_covs, gamma_w = l$gamma_w, gamma_b = l$gamma_b, Tau = l$Tau, sigma2 = l$sigma2, has_intercept = l$has_intercept, clustermeancentered = l$clustermeancentered) +r2mlm::r2mlm_manual( + data = l$data, + within_covs = l$within_covs, + between_covs = l$between_covs, + random_covs = l$random_covs, + gamma_w = l$gamma_w, + gamma_b = l$gamma_b, + Tau = l$Tau, + sigma2 = l$sigma2, + has_intercept = l$has_intercept, + clustermeancentered = l$clustermeancentered +) # Testing ----------------------------------------------------------------- - test_it <- function(model) { l <- r2mlm_init(model) - rez <- r2mlm::r2mlm_manual(data = l$data, within_covs = l$within_covs, between_covs = l$between_covs, random_covs = l$random_covs, gamma_w = l$gamma_w, gamma_b = l$gamma_b, Tau = l$Tau, sigma2 = l$sigma2, has_intercept = l$has_intercept, clustermeancentered = l$clustermeancentered) + rez <- r2mlm::r2mlm_manual( + data = l$data, + within_covs = l$within_covs, + between_covs = l$between_covs, + random_covs = l$random_covs, + gamma_w = l$gamma_w, + gamma_b = l$gamma_b, + Tau = l$Tau, + sigma2 = l$sigma2, + has_intercept = l$has_intercept, + clustermeancentered = l$clustermeancentered + ) truth <- r2mlm::r2mlm(model) if (all(rez$Decompositions == truth$Decompositions) & all(rez$R2s == truth$R2s)) { @@ -28,11 +49,12 @@ test_it <- function(model) { } - - model <- lmer(satisfaction ~ salary_c + (1 + salary_c | schoolID), data = r2mlm::teachsat) test_it(model) -model <- lmer(satisfaction ~ salary_c * control_c + (1 + salary_c | schoolID), data = r2mlm::teachsat) +model <- lmer( + satisfaction ~ salary_c * control_c + (1 + salary_c | schoolID), + data = r2mlm::teachsat +) test_it(model) # model <- lmer(satisfaction ~ 0 + salary_c + (1 + salary_c | schoolID), data = r2mlm::teachsat) # test_it(model) diff --git a/WIP/r2mlm_utils.R b/WIP/r2mlm_utils.R index df4c6ad67..22aba6438 100644 --- a/WIP/r2mlm_utils.R +++ b/WIP/r2mlm_utils.R @@ -1,8 +1,5 @@ - - # sort_variables ---------------------------------------------------------- - r2mlm_sort_variables <- function(data, predictors, cluster_variable) { l1_vars <- c() l2_vars <- c() @@ -54,16 +51,8 @@ r2mlm_sort_variables <- function(data, predictors, cluster_variable) { } - - - - # get_random_slope_vars --------------------------------------------------- - - - - r2mlm_get_random_slope_vars <- function(model) { temp_cov_list <- insight::get_parameters(model, effects = "random") if (inherits(model, "merMod")) { @@ -91,10 +80,8 @@ r2mlm_get_random_slope_vars <- function(model) { } - # get_cwc ----------------------------------------------------------------- - r2mlm_get_cwc <- function(l1_vars, cluster_variable, data) { # Group data # see "Indirection" here for explanation of this group_by formatting: https://dplyr.tidyverse.org/articles/programming.html @@ -128,14 +115,8 @@ r2mlm_get_cwc <- function(l1_vars, cluster_variable, data) { } - # get_covs ---------------------------------------------------------------- - - - - - r2mlm_get_covs <- function(variable_list, data) { cov_list <- c() # create empty list to fill diff --git a/WIP/test-model_performance.survey.R b/WIP/test-model_performance.survey.R index fdf713f11..c123f5371 100644 --- a/WIP/test-model_performance.survey.R +++ b/WIP/test-model_performance.survey.R @@ -31,7 +31,9 @@ test_that("model_performance.survey-cox", { pbc$randomized <- with(pbc, !is.na(trt) & trt > 0) biasmodel <- glm(randomized ~ age * edema, data = pbc, family = binomial) pbc$randprob <- fitted(biasmodel) - if (is.null(pbc$albumin)) pbc$albumin <- pbc$alb ## pre2.9.0 + if (is.null(pbc$albumin)) { + pbc$albumin <- pbc$alb + } ## pre2.9.0 dpbc <- survey::svydesign( id = ~1, @@ -40,7 +42,10 @@ test_that("model_performance.survey-cox", { data = subset(pbc, randomized) ) rpbc <- survey::as.svrepdesign(dpbc) - model <- survey::svycoxph(Surv(time, status > 0) ~ log(bili) + protime + albumin, design = dpbc) + model <- survey::svycoxph( + Surv(time, status > 0) ~ log(bili) + protime + albumin, + design = dpbc + ) mp <- suppressWarnings(model_performance(model)) diff --git a/tests/testthat/test-binned_residuals.R b/tests/testthat/test-binned_residuals.R index c0c6a4be7..cdb9b9fac 100644 --- a/tests/testthat/test-binned_residuals.R +++ b/tests/testthat/test-binned_residuals.R @@ -31,7 +31,12 @@ test_that("binned_residuals", { test_that("binned_residuals, n_bins", { data(mtcars) model <- glm(vs ~ wt + mpg, data = mtcars, family = "binomial") - result <- binned_residuals(model, ci_type = "gaussian", residuals = "response", n_bins = 10) + result <- binned_residuals( + model, + ci_type = "gaussian", + residuals = "response", + n_bins = 10 + ) expect_named( result, c("xbar", "ybar", "n", "x.lo", "x.hi", "se", "CI_low", "CI_high", "group") @@ -39,16 +44,32 @@ test_that("binned_residuals, n_bins", { expect_equal( result$xbar, c( - 0.02373, 0.06301, 0.08441, 0.17907, 0.29225, 0.44073, 0.54951, - 0.69701, 0.9168, 0.99204 + 0.02373, + 0.06301, + 0.08441, + 0.17907, + 0.29225, + 0.44073, + 0.54951, + 0.69701, + 0.9168, + 0.99204 ), tolerance = 1e-4 ) expect_equal( result$ybar, c( - -0.02373, -0.06301, -0.08441, -0.17907, 0.20775, -0.1074, 0.11715, - 0.30299, -0.25014, 0.00796 + -0.02373, + -0.06301, + -0.08441, + -0.17907, + 0.20775, + -0.1074, + 0.11715, + 0.30299, + -0.25014, + 0.00796 ), tolerance = 1e-4 ) @@ -58,7 +79,12 @@ test_that("binned_residuals, n_bins", { test_that("binned_residuals, terms", { data(mtcars) model <- glm(vs ~ wt + mpg, data = mtcars, family = "binomial") - result <- binned_residuals(model, ci_type = "gaussian", residuals = "response", term = "mpg") + result <- binned_residuals( + model, + ci_type = "gaussian", + residuals = "response", + term = "mpg" + ) expect_named( result, c("xbar", "ybar", "n", "x.lo", "x.hi", "se", "CI_low", "CI_high", "group") @@ -169,11 +195,7 @@ test_that("binned_residuals, msg for non-bernoulli", { dat$prop <- suc / tot dat$x1 <- as.factor(sample.int(5, 100, replace = TRUE)) - mod <- glm(prop ~ x1, - family = binomial, - data = dat, - weights = tot - ) + mod <- glm(prop ~ x1, family = binomial, data = dat, weights = tot) expect_message(binned_residuals(mod), regex = "Using `ci_type = \"gaussian\"`") expect_silent(binned_residuals(mod, verbose = FALSE)) @@ -182,52 +204,349 @@ test_that("binned_residuals, msg for non-bernoulli", { test_that("binned_residuals, empty bins", { eel <- data.frame( cured_bin = c( - 1, 1, 1, 0, 0, 0, 1, 0, 0, 1, 0, - 0, 0, 1, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, - 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, - 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, - 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 0, 1, - 0, 0, 1, 1, 0, 1, 1, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 0 + 1, + 1, + 1, + 0, + 0, + 0, + 1, + 0, + 0, + 1, + 0, + 0, + 0, + 1, + 1, + 1, + 0, + 1, + 0, + 0, + 1, + 0, + 0, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 1, + 0, + 0, + 1, + 0, + 0, + 0, + 1, + 0, + 0, + 0, + 1, + 0, + 1, + 1, + 1, + 1, + 1, + 1, + 0, + 0, + 0, + 0, + 0, + 1, + 0, + 0, + 1, + 0, + 0, + 0, + 1, + 0, + 1, + 0, + 1, + 1, + 0, + 1, + 1, + 0, + 1, + 1, + 0, + 0, + 0, + 0, + 1, + 0, + 1, + 0, + 1, + 0, + 0, + 1, + 0, + 0, + 1, + 0, + 1, + 0, + 1, + 0, + 0, + 1, + 0, + 0, + 1, + 1, + 0, + 1, + 1, + 0, + 0, + 1, + 0, + 1, + 1, + 0, + 0, + 1, + 1, + 0 ), intervention = c( "No treatment", - "No treatment", "No treatment", "No treatment", "Intervention", - "No treatment", "Intervention", "Intervention", "No treatment", - "No treatment", "Intervention", "No treatment", "No treatment", - "Intervention", "No treatment", "No treatment", "Intervention", - "Intervention", "Intervention", "Intervention", "No treatment", - "Intervention", "Intervention", "No treatment", "Intervention", - "Intervention", "No treatment", "No treatment", "Intervention", - "Intervention", "No treatment", "No treatment", "Intervention", - "Intervention", "Intervention", "No treatment", "No treatment", - "Intervention", "No treatment", "Intervention", "No treatment", - "Intervention", "Intervention", "Intervention", "No treatment", - "No treatment", "No treatment", "Intervention", "Intervention", - "No treatment", "Intervention", "Intervention", "Intervention", - "No treatment", "No treatment", "Intervention", "Intervention", - "No treatment", "Intervention", "Intervention", "No treatment", - "No treatment", "No treatment", "Intervention", "Intervention", - "No treatment", "No treatment", "No treatment", "No treatment", - "No treatment", "Intervention", "No treatment", "Intervention", - "Intervention", "Intervention", "No treatment", "Intervention", - "Intervention", "No treatment", "Intervention", "No treatment", - "No treatment", "Intervention", "Intervention", "Intervention", - "Intervention", "No treatment", "Intervention", "Intervention", - "No treatment", "Intervention", "No treatment", "Intervention", - "Intervention", "Intervention", "Intervention", "No treatment", - "No treatment", "No treatment", "Intervention", "No treatment", - "No treatment", "Intervention", "No treatment", "No treatment", - "No treatment", "No treatment", "No treatment", "Intervention", - "Intervention", "No treatment", "No treatment", "Intervention" - ), duration = c( - 7L, 7L, 6L, 8L, 7L, 6L, 7L, 7L, 8L, 7L, 7L, 7L, - 5L, 9L, 6L, 7L, 8L, 7L, 7L, 9L, 7L, 9L, 8L, 7L, 6L, 8L, 7L, 6L, - 7L, 6L, 7L, 6L, 5L, 6L, 7L, 7L, 8L, 7L, 5L, 7L, 9L, 10L, 7L, - 8L, 5L, 8L, 4L, 7L, 8L, 6L, 6L, 6L, 7L, 7L, 8L, 7L, 7L, 7L, 7L, - 8L, 7L, 9L, 7L, 8L, 8L, 7L, 7L, 7L, 8L, 7L, 8L, 7L, 8L, 8L, 9L, - 7L, 10L, 5L, 7L, 8L, 9L, 5L, 10L, 8L, 7L, 6L, 5L, 6L, 7L, 7L, - 7L, 7L, 7L, 7L, 8L, 5L, 6L, 7L, 6L, 7L, 7L, 9L, 6L, 6L, 7L, 7L, - 6L, 7L, 8L, 9L, 4L, 6L, 9L + "No treatment", + "No treatment", + "No treatment", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "Intervention", + "Intervention", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "No treatment", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "No treatment", + "No treatment", + "No treatment", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "Intervention", + "Intervention", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "Intervention", + "No treatment", + "Intervention", + "Intervention", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "No treatment", + "Intervention", + "No treatment", + "No treatment", + "Intervention", + "No treatment", + "No treatment", + "No treatment", + "No treatment", + "No treatment", + "Intervention", + "Intervention", + "No treatment", + "No treatment", + "Intervention" + ), + duration = c( + 7L, + 7L, + 6L, + 8L, + 7L, + 6L, + 7L, + 7L, + 8L, + 7L, + 7L, + 7L, + 5L, + 9L, + 6L, + 7L, + 8L, + 7L, + 7L, + 9L, + 7L, + 9L, + 8L, + 7L, + 6L, + 8L, + 7L, + 6L, + 7L, + 6L, + 7L, + 6L, + 5L, + 6L, + 7L, + 7L, + 8L, + 7L, + 5L, + 7L, + 9L, + 10L, + 7L, + 8L, + 5L, + 8L, + 4L, + 7L, + 8L, + 6L, + 6L, + 6L, + 7L, + 7L, + 8L, + 7L, + 7L, + 7L, + 7L, + 8L, + 7L, + 9L, + 7L, + 8L, + 8L, + 7L, + 7L, + 7L, + 8L, + 7L, + 8L, + 7L, + 8L, + 8L, + 9L, + 7L, + 10L, + 5L, + 7L, + 8L, + 9L, + 5L, + 10L, + 8L, + 7L, + 6L, + 5L, + 6L, + 7L, + 7L, + 7L, + 7L, + 7L, + 7L, + 8L, + 5L, + 6L, + 7L, + 6L, + 7L, + 7L, + 9L, + 6L, + 6L, + 7L, + 7L, + 6L, + 7L, + 8L, + 9L, + 4L, + 6L, + 9L ), stringsAsFactors = FALSE ) diff --git a/tests/testthat/test-check_collinearity.R b/tests/testthat/test-check_collinearity.R index e0587c648..952d4897a 100644 --- a/tests/testthat/test-check_collinearity.R +++ b/tests/testthat/test-check_collinearity.R @@ -35,13 +35,16 @@ test_that("check_collinearity", { data(Salamanders, package = "glmmTMB") - m1 <- glmmTMB::glmmTMB(count ~ spp + mined + (1 | site), + m1 <- glmmTMB::glmmTMB( + count ~ spp + mined + (1 | site), ziformula = ~spp, Salamanders, family = poisson() ) expect_equal( - suppressWarnings(check_collinearity(m1, component = "conditional", verbose = FALSE)$VIF), + suppressWarnings( + check_collinearity(m1, component = "conditional", verbose = FALSE)$VIF + ), c(1.00037354840318, 1.00037354840318), tolerance = 1e-3 ) @@ -68,12 +71,16 @@ test_that("check_collinearity", { ) expect_equal( - suppressWarnings(check_collinearity(m2, component = "conditional", verbose = FALSE)$VIF), + suppressWarnings( + check_collinearity(m2, component = "conditional", verbose = FALSE)$VIF + ), c(1.09015, 1.2343, 1.17832), tolerance = 1e-3 ) expect_equal( - suppressWarnings(check_collinearity(m2, component = "conditional", verbose = FALSE)$VIF_CI_low), + suppressWarnings( + check_collinearity(m2, component = "conditional", verbose = FALSE)$VIF_CI_low + ), c(1.03392, 1.14674, 1.10105), tolerance = 1e-3 ) @@ -83,17 +90,27 @@ test_that("check_collinearity", { tolerance = 1e-3 ) expect_equal( - suppressWarnings(check_collinearity(m2, component = "all", verbose = FALSE)$VIF_CI_low), + suppressWarnings( + check_collinearity(m2, component = "all", verbose = FALSE)$VIF_CI_low + ), c(1.03392, 1.14674, 1.10105, 1.17565, 1, 1.17565), tolerance = 1e-3 ) expect_equal( - suppressWarnings(check_collinearity(m2, component = "zero_inflated", verbose = FALSE)$VIF), + suppressWarnings( + check_collinearity(m2, component = "zero_inflated", verbose = FALSE)$VIF + ), c(1.26914, 1, 1.26914), tolerance = 1e-3 ) expect_equal( - suppressWarnings(check_collinearity(m2, component = "zero_inflated", verbose = FALSE)$Tolerance_CI_high), + suppressWarnings( + check_collinearity( + m2, + component = "zero_inflated", + verbose = FALSE + )$Tolerance_CI_high + ), c(0.85059, 1, 0.85059), tolerance = 1e-3 ) @@ -104,7 +121,14 @@ test_that("check_collinearity", { expect_identical( attributes(coll)$data$Component, - c("conditional", "conditional", "conditional", "zero inflated", "zero inflated", "zero inflated") + c( + "conditional", + "conditional", + "conditional", + "zero inflated", + "zero inflated", + "zero inflated" + ) ) expect_identical( colnames(attributes(coll)$CI), @@ -119,17 +143,14 @@ test_that("check_collinearity | afex", { obk.long$treatment <- as.character(obk.long$treatment) suppressWarnings(suppressMessages({ - aM <- afex::aov_car(value ~ treatment * gender + Error(id / (phase * hour)), + aM <- afex::aov_car( + value ~ treatment * gender + Error(id / (phase * hour)), data = obk.long ) - aW <- afex::aov_car(value ~ Error(id / (phase * hour)), - data = obk.long - ) + aW <- afex::aov_car(value ~ Error(id / (phase * hour)), data = obk.long) - aB <- afex::aov_car(value ~ treatment * gender + Error(id), - data = obk.long - ) + aB <- afex::aov_car(value ~ treatment * gender + Error(id), data = obk.long) })) expect_message(ccoM <- check_collinearity(aM)) # nolint @@ -141,17 +162,20 @@ test_that("check_collinearity | afex", { expect_identical(nrow(ccoB), 3L) suppressWarnings(suppressMessages({ - aM <- afex::aov_car(value ~ treatment * gender + Error(id / (phase * hour)), + aM <- afex::aov_car( + value ~ treatment * gender + Error(id / (phase * hour)), include_aov = TRUE, data = obk.long ) - aW <- afex::aov_car(value ~ Error(id / (phase * hour)), + aW <- afex::aov_car( + value ~ Error(id / (phase * hour)), include_aov = TRUE, data = obk.long ) - aB <- afex::aov_car(value ~ treatment * gender + Error(id), + aB <- afex::aov_car( + value ~ treatment * gender + Error(id), include_aov = TRUE, data = obk.long ) @@ -166,7 +190,8 @@ test_that("check_collinearity | afex", { expect_identical(nrow(ccoB), 3L) }) -test_that("check_collinearity, ci = NULL", { # 518 +test_that("check_collinearity, ci = NULL", { + # 518 data(npk) m <- lm(yield ~ N + P + K, npk) out <- check_collinearity(m, ci = NULL) @@ -174,8 +199,14 @@ test_that("check_collinearity, ci = NULL", { # 518 expect_identical( colnames(out), c( - "Term", "VIF", "VIF_CI_low", "VIF_CI_high", "SE_factor", "Tolerance", - "Tolerance_CI_low", "Tolerance_CI_high" + "Term", + "VIF", + "VIF_CI_low", + "VIF_CI_high", + "SE_factor", + "Tolerance", + "Tolerance_CI_low", + "Tolerance_CI_high" ) ) expect_snapshot(out) @@ -190,8 +221,14 @@ test_that("check_collinearity, ci are NA", { expect_identical( colnames(out), c( - "Term", "VIF", "VIF_CI_low", "VIF_CI_high", "SE_factor", "Tolerance", - "Tolerance_CI_low", "Tolerance_CI_high" + "Term", + "VIF", + "VIF_CI_low", + "VIF_CI_high", + "SE_factor", + "Tolerance", + "Tolerance_CI_low", + "Tolerance_CI_high" ) ) }) @@ -210,8 +247,15 @@ test_that("check_collinearity, hurdle/zi models w/o zi-formula", { expect_named( out, c( - "Term", "VIF", "VIF_CI_low", "VIF_CI_high", "SE_factor", "Tolerance", - "Tolerance_CI_low", "Tolerance_CI_high", "Component" + "Term", + "VIF", + "VIF_CI_low", + "VIF_CI_high", + "SE_factor", + "Tolerance", + "Tolerance_CI_low", + "Tolerance_CI_high", + "Component" ) ) expect_equal(out$VIF, c(1.05772, 1.05772, 1.06587, 1.06587), tolerance = 1e-4) diff --git a/tests/testthat/test-check_convergence.R b/tests/testthat/test-check_convergence.R index 8897b785d..12b897f3a 100644 --- a/tests/testthat/test-check_convergence.R +++ b/tests/testthat/test-check_convergence.R @@ -32,8 +32,8 @@ test_that("check_convergence, glmmTMB", { skip_if_not_installed("glmmTMB") data(iris) model <- suppressWarnings(glmmTMB::glmmTMB( - Sepal.Length ~ poly(Petal.Width, 4) * poly(Petal.Length, 4) + - (1 + poly(Petal.Width, 4) | Species), + Sepal.Length ~ + poly(Petal.Width, 4) * poly(Petal.Length, 4) + (1 + poly(Petal.Width, 4) | Species), data = iris )) expect_false(check_convergence(model)) diff --git a/tests/testthat/test-check_dag.R b/tests/testthat/test-check_dag.R index 0d6efa9d6..a25d2ff1f 100644 --- a/tests/testthat/test-check_dag.R +++ b/tests/testthat/test-check_dag.R @@ -149,11 +149,15 @@ test_that("check_dag, different adjustements for total and direct", { test_that("check_dag, collider bias", { dag <- check_dag( - SMD_ICD11 ~ agegroup + gender_kid + edgroup3 + residence + pss4_kid_sum_2sd + sm_h_total_kid, + SMD_ICD11 ~ + agegroup + gender_kid + edgroup3 + residence + pss4_kid_sum_2sd + sm_h_total_kid, pss4_kid_sum_2sd ~ gender_kid, sm_h_total_kid ~ gender_kid + agegroup, adjusted = c( - "agegroup", "gender_kid", "edgroup3", "residence", + "agegroup", + "gender_kid", + "edgroup3", + "residence", "pss4_kid_sum_2sd" ), outcome = "SMD_ICD11", @@ -162,12 +166,17 @@ test_that("check_dag, collider bias", { expect_snapshot(print(dag)) dag <- check_dag( - SMD_ICD11 ~ agegroup + gender_kid + edgroup3 + residence + pss4_kid_sum_2sd + sm_h_total_kid, + SMD_ICD11 ~ + agegroup + gender_kid + edgroup3 + residence + pss4_kid_sum_2sd + sm_h_total_kid, pss4_kid_sum_2sd ~ gender_kid, sm_h_total_kid ~ gender_kid + agegroup, adjusted = c( - "agegroup", "gender_kid", "edgroup3", "residence", - "pss4_kid_sum_2sd", "sm_h_total_kid" + "agegroup", + "gender_kid", + "edgroup3", + "residence", + "pss4_kid_sum_2sd", + "sm_h_total_kid" ), outcome = "SMD_ICD11", exposure = "agegroup" diff --git a/tests/testthat/test-check_distribution.R b/tests/testthat/test-check_distribution.R index ca2e134be..f3d4c89f7 100644 --- a/tests/testthat/test-check_distribution.R +++ b/tests/testthat/test-check_distribution.R @@ -8,26 +8,80 @@ test_that("check_distribution", { expect_identical( out$Distribution, c( - "bernoulli", "beta", "beta-binomial", "binomial", "cauchy", - "chi", "exponential", "F", "gamma", "half-cauchy", "inverse-gamma", - "lognormal", "neg. binomial (zero-infl.)", "negative binomial", - "normal", "pareto", "poisson", "poisson (zero-infl.)", "tweedie", - "uniform", "weibull" + "bernoulli", + "beta", + "beta-binomial", + "binomial", + "cauchy", + "chi", + "exponential", + "F", + "gamma", + "half-cauchy", + "inverse-gamma", + "lognormal", + "neg. binomial (zero-infl.)", + "negative binomial", + "normal", + "pareto", + "poisson", + "poisson (zero-infl.)", + "tweedie", + "uniform", + "weibull" ) ) expect_equal( out$p_Residuals, c( - 0, 0, 0, 0, 0.90625, 0, 0, 0, 0.0625, 0, 0, 0, 0.03125, 0, 0, - 0, 0, 0, 0, 0, 0 + 0, + 0, + 0, + 0, + 0.90625, + 0, + 0, + 0, + 0.0625, + 0, + 0, + 0, + 0.03125, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0 ), tolerance = 1e-4 ) expect_equal( out$p_Response, c( - 0, 0, 0, 0, 0, 0, 0, 0, 0.34375, 0, 0, 0.65625, 0, 0, 0, 0, - 0, 0, 0, 0, 0 + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0.34375, + 0, + 0, + 0.65625, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0 ), tolerance = 1e-4 ) diff --git a/tests/testthat/test-check_group_variation.R b/tests/testthat/test-check_group_variation.R index 4f936e518..9f4bf3059 100644 --- a/tests/testthat/test-check_group_variation.R +++ b/tests/testthat/test-check_group_variation.R @@ -14,14 +14,20 @@ test_that("check_group_variation-1", { out, data.frame( Group = rep("group", 6), - Variable = c("constant", "variable1", "variable1b", "variable2", "variable3", "variable4"), + Variable = c( + "constant", + "variable1", + "variable1b", + "variable2", + "variable3", + "variable4" + ), Variation = c(NA, "between", "between", "within", "both", "both"), Design = c(NA, "nested", NA, "crossed", "nested", NA) ), ignore_attr = TRUE ) - set.seed(111) dat <- data.frame( id = rep(letters, each = 2), @@ -49,7 +55,14 @@ test_that("check_group_variation-1", { out, data.frame( Group = c("id", "id", "id", "id", "id", "id"), - Variable = c("between_num", "within_num", "both_num", "between_fac", "within_fac", "both_fac"), + Variable = c( + "between_num", + "within_num", + "both_num", + "between_fac", + "within_fac", + "both_fac" + ), Variation = c("between", "within", "both", "between", "within", "both"), Design = c(NA, NA, NA, "nested", "crossed", NA) ), @@ -143,10 +156,30 @@ test_that("check_group_variation, multiple by", { female = rep(c(TRUE, FALSE), each = 12), year = rep(1:6, times = 4), math = c( - -3.068, -1.13, -0.921, 0.463, 0.021, 2.035, - -2.732, -2.097, -0.988, 0.227, 0.403, 1.623, - -2.732, -1.898, -0.921, 0.587, 1.578, 2.3, - -2.288, -2.162, -1.631, -1.555, -0.725, 0.097 + -3.068, + -1.13, + -0.921, + 0.463, + 0.021, + 2.035, + -2.732, + -2.097, + -0.988, + 0.227, + 0.403, + 1.623, + -2.732, + -1.898, + -0.921, + 0.587, + 1.578, + 2.3, + -2.288, + -2.162, + -1.631, + -1.555, + -0.725, + 0.097 ) ) @@ -154,9 +187,36 @@ test_that("check_group_variation, multiple by", { expect_equal( out, data.frame( - Group = c("schoolid", "schoolid", "schoolid", "schoolid", "childid", "childid", "childid", "childid"), - Variable = c("lowinc", "female", "year", "math", "lowinc", "female", "year", "math"), - Variation = c("between", "both", "within", "both", "between", "between", "within", "both"), + Group = c( + "schoolid", + "schoolid", + "schoolid", + "schoolid", + "childid", + "childid", + "childid", + "childid" + ), + Variable = c( + "lowinc", + "female", + "year", + "math", + "lowinc", + "female", + "year", + "math" + ), + Variation = c( + "between", + "both", + "within", + "both", + "between", + "between", + "within", + "both" + ), Design = c("nested", rep(NA_character_, 7)) ), ignore_attr = TRUE @@ -167,16 +227,40 @@ test_that("check_group_variation, multiple by", { out, data.frame( Group = c( - "schoolid", "schoolid", "schoolid", "schoolid", "schoolid", - "childid", "childid", "childid", "childid", "childid" + "schoolid", + "schoolid", + "schoolid", + "schoolid", + "schoolid", + "childid", + "childid", + "childid", + "childid", + "childid" ), Variable = c( - "childid", "lowinc", "female", "year", "math", - "schoolid", "lowinc", "female", "year", "math" + "childid", + "lowinc", + "female", + "year", + "math", + "schoolid", + "lowinc", + "female", + "year", + "math" ), Variation = c( - "both", "between", "both", "within", "both", - "between", "between", "between", "within", "both" + "both", + "between", + "both", + "within", + "both", + "between", + "between", + "between", + "within", + "both" ), Design = c("nested", "nested", rep(NA_character_, 8)) ), @@ -222,10 +306,30 @@ test_that("check_group_variation, numeric_as_factor", { female = rep(c(TRUE, FALSE), each = 12), year = rep(1:6, times = 4), math = c( - -3.068, -1.13, -0.921, 0.463, 0.021, 2.035, - -2.732, -2.097, -0.988, 0.227, 0.403, 1.623, - -2.732, -1.898, -0.921, 0.587, 1.578, 2.3, - -2.288, -2.162, -1.631, -1.555, -0.725, 0.097 + -3.068, + -1.13, + -0.921, + 0.463, + 0.021, + 2.035, + -2.732, + -2.097, + -0.988, + 0.227, + 0.403, + 1.623, + -2.732, + -1.898, + -0.921, + 0.587, + 1.578, + 2.3, + -2.288, + -2.162, + -1.631, + -1.555, + -0.725, + 0.097 ) ) diff --git a/tests/testthat/test-check_homogeneity.R b/tests/testthat/test-check_homogeneity.R index 1b3fddbd9..22fc3d646 100644 --- a/tests/testthat/test-check_homogeneity.R +++ b/tests/testthat/test-check_homogeneity.R @@ -5,21 +5,21 @@ test_that("check_homogeneity | afex", { obk.long$treatment <- as.character(obk.long$treatment) suppressWarnings(suppressMessages({ - aM <- afex::aov_car(value ~ treatment * gender + Error(id / (phase * hour)), + aM <- afex::aov_car( + value ~ treatment * gender + Error(id / (phase * hour)), data = obk.long ) - aW <- afex::aov_car(value ~ Error(id / (phase * hour)), - data = obk.long - ) + aW <- afex::aov_car(value ~ Error(id / (phase * hour)), data = obk.long) - aB <- afex::aov_car(value ~ treatment * gender + Error(id), - data = obk.long - ) + aB <- afex::aov_car(value ~ treatment * gender + Error(id), data = obk.long) })) expect_error(check_homogeneity(aW)) - msg <- capture.output(expect_message(check_homogeneity(aB, method = "bartlett"), "Only")) + msg <- capture.output(expect_message( + check_homogeneity(aB, method = "bartlett"), + "Only" + )) msg <- capture.output({ pM <- check_homogeneity(aM) @@ -48,7 +48,8 @@ test_that("check_homogeneity | t-test", { method = "Bartlett Test", class = c( "check_homogeneity", - "see_check_homogeneity", "numeric" + "see_check_homogeneity", + "numeric" ) ), tolerance = 1e-3, diff --git a/tests/testthat/test-check_itemscale.R b/tests/testthat/test-check_itemscale.R index 71db28d1d..8a19be62f 100644 --- a/tests/testthat/test-check_itemscale.R +++ b/tests/testthat/test-check_itemscale.R @@ -82,7 +82,12 @@ test_that("check_itemscale for FA", { skip_if_not_installed("psych") skip_if_not_installed("GPArotation") - f <- parameters::factor_analysis(mtcars, n = 2, rotation = "oblimin", standardize = FALSE) + f <- parameters::factor_analysis( + mtcars, + n = 2, + rotation = "oblimin", + standardize = FALSE + ) out <- check_itemscale(f) expect_equal( out[[1]]$Mean, @@ -98,7 +103,12 @@ test_that("print_md check_itemscale for FA", { skip_if_not_installed("GPArotation") skip_if_not_installed("knitr") - f <- parameters::factor_analysis(mtcars, n = 2, rotation = "oblimin", standardize = FALSE) + f <- parameters::factor_analysis( + mtcars, + n = 2, + rotation = "oblimin", + standardize = FALSE + ) out <- check_itemscale(f) expect_snapshot(print_md(out)) }) diff --git a/tests/testthat/test-check_model.R b/tests/testthat/test-check_model.R index 687a32344..7ee4be747 100644 --- a/tests/testthat/test-check_model.R +++ b/tests/testthat/test-check_model.R @@ -3,23 +3,106 @@ skip_if_not_installed("see", minimum_version = "0.9.1") d <- data.frame( y = c( - 101L, 219L, 70L, 67L, 31L, 243L, 41L, 250L, 140L, 210L, 22L, 121L, 282L, - 144L, 223L, 297L, 20L, 13L, 148L, 57L, 143L, 109L, 273L, 83L, 28L, 153L, - 261L, 209L, 134L, 95L, 17L, 11L + 101L, + 219L, + 70L, + 67L, + 31L, + 243L, + 41L, + 250L, + 140L, + 210L, + 22L, + 121L, + 282L, + 144L, + 223L, + 297L, + 20L, + 13L, + 148L, + 57L, + 143L, + 109L, + 273L, + 83L, + 28L, + 153L, + 261L, + 209L, + 134L, + 95L, + 17L, + 11L ), x = c( - 9.43240344971252, 15.2821279871535, 29.1169666338249, 14.0859852649899, - 15.6464367574587, 8.86321119888889, 67.9427830082998, 8.60340052656454, 21.9029971533007, - 19.8586681899898, 9.68086847417484, 25.0990259928273, 16.1398284119823, 29.3829154122785, - 31.5592351678585, 14.0320212214305, 31.3815560884357, 18.3566866719804, 28.3822251897697, - 67.9433435559261, 26.6656339570149, 5.83151069454924, 7.93210796912854, 35.9198997836162, - 21.6330853399868, 34.484392512508, 35.9444483480784, 28.4517728364097, 27.2868577206239, - 8.1803022427107, 46.3029232706936, 41.516915503604 + 9.43240344971252, + 15.2821279871535, + 29.1169666338249, + 14.0859852649899, + 15.6464367574587, + 8.86321119888889, + 67.9427830082998, + 8.60340052656454, + 21.9029971533007, + 19.8586681899898, + 9.68086847417484, + 25.0990259928273, + 16.1398284119823, + 29.3829154122785, + 31.5592351678585, + 14.0320212214305, + 31.3815560884357, + 18.3566866719804, + 28.3822251897697, + 67.9433435559261, + 26.6656339570149, + 5.83151069454924, + 7.93210796912854, + 35.9198997836162, + 21.6330853399868, + 34.484392512508, + 35.9444483480784, + 28.4517728364097, + 27.2868577206239, + 8.1803022427107, + 46.3029232706936, + 41.516915503604 ), offset = c( - 481L, 515L, 396L, 451L, 547L, 409L, 375L, 430L, 526L, 456L, 450L, 425L, - 406L, 396L, 421L, 417L, 430L, 419L, 436L, 517L, 511L, 435L, 489L, 417L, - 372L, 373L, 351L, 367L, 350L, 339L, 169L, 63L + 481L, + 515L, + 396L, + 451L, + 547L, + 409L, + 375L, + 430L, + 526L, + 456L, + 450L, + 425L, + 406L, + 396L, + 421L, + 417L, + 430L, + 419L, + 436L, + 517L, + 511L, + 435L, + 489L, + 417L, + 372L, + 373L, + 351L, + 367L, + 350L, + 339L, + 169L, + 63L ) ) @@ -57,7 +140,8 @@ test_that("`check_model()` warnings for tweedie", { data(sleepstudy, package = "lme4") set.seed(123) d <- sleepstudy[sample.int(50), ] - m <- suppressWarnings(glmmTMB::glmmTMB(Reaction ~ Days, + m <- suppressWarnings(glmmTMB::glmmTMB( + Reaction ~ Days, data = d, family = glmmTMB::tweedie )) @@ -77,7 +161,10 @@ test_that("`check_model()` warnings for zero-infl", { art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists ) - expect_message(expect_message(check_model(model, verbose = TRUE), regex = "Cannot simulate"), regex = "Homogeneity") + expect_message( + expect_message(check_model(model, verbose = TRUE), regex = "Cannot simulate"), + regex = "Homogeneity" + ) }) @@ -91,11 +178,13 @@ test_that("`check_model()` no warnings for quasipoisson", { sd = 2 ) # Generate y values y = 5x + e - y <- 5 * x + rnorm( - n = 500, - mean = 5, - sd = 2 - ) + y <- 5 * + x + + rnorm( + n = 500, + mean = 5, + sd = 2 + ) # Generate z as offset z <- runif(500, min = 0, max = 6719) mock_data <- data.frame(x, y, z) |> diff --git a/tests/testthat/test-check_normality.R b/tests/testthat/test-check_normality.R index f166c6f03..4867adf4a 100644 --- a/tests/testthat/test-check_normality.R +++ b/tests/testthat/test-check_normality.R @@ -6,17 +6,14 @@ test_that("check_normality | afex", { obk.long$treatment <- as.character(obk.long$treatment) suppressWarnings(suppressMessages({ - aM <- afex::aov_car(value ~ treatment * gender + Error(id / (phase * hour)), + aM <- afex::aov_car( + value ~ treatment * gender + Error(id / (phase * hour)), data = obk.long ) - aW <- afex::aov_car(value ~ Error(id / (phase * hour)), - data = obk.long - ) + aW <- afex::aov_car(value ~ Error(id / (phase * hour)), data = obk.long) - aB <- afex::aov_car(value ~ treatment * gender + Error(id), - data = obk.long - ) + aB <- afex::aov_car(value ~ treatment * gender + Error(id), data = obk.long) })) msg <- capture.output({ @@ -75,7 +72,8 @@ test_that("check_normality | t-test", { effects = "fixed", class = c( "check_normality", - "see_check_normality", "numeric" + "see_check_normality", + "numeric" ) ), tolerance = 1e-3, diff --git a/tests/testthat/test-check_outliers.R b/tests/testthat/test-check_outliers.R index 4be407635..37ca26c98 100644 --- a/tests/testthat/test-check_outliers.R +++ b/tests/testthat/test-check_outliers.R @@ -89,7 +89,12 @@ test_that("mcd which", { # (not clear why method mcd needs a seed) set.seed(42) expect_identical( - tail(which(check_outliers(mtcars[1:4], method = "mcd", threshold = 45, verbose = FALSE))), + tail(which(check_outliers( + mtcars[1:4], + method = "mcd", + threshold = 45, + verbose = FALSE + ))), 31L ) expect_warning( @@ -208,16 +213,35 @@ test_that("all methods which", { skip_if_not_installed("loo") expect_identical( - which(check_outliers(mtcars, + which(check_outliers( + mtcars, method = c( - "zscore", "zscore_robust", "iqr", "ci", "eti", "hdi", "bci", - "mahalanobis", "mahalanobis_robust", "mcd", "optics", "lof" + "zscore", + "zscore_robust", + "iqr", + "ci", + "eti", + "hdi", + "bci", + "mahalanobis", + "mahalanobis_robust", + "mcd", + "optics", + "lof" ), threshold = list( - zscore = 2.2, zscore_robust = 2.2, iqr = 1.2, - ci = 0.95, eti = 0.95, hdi = 0.90, bci = 0.95, - mahalanobis = 20, mahalanobis_robust = 25, mcd = 25, - optics = 14, lof = 0.005 + zscore = 2.2, + zscore_robust = 2.2, + iqr = 1.2, + ci = 0.95, + eti = 0.95, + hdi = 0.90, + bci = 0.95, + mahalanobis = 20, + mahalanobis_robust = 25, + mcd = 25, + optics = 14, + lof = 0.005 ), verbose = FALSE )), @@ -227,7 +251,6 @@ test_that("all methods which", { # 5. Next, we test adding ID - test_that("multiple methods with ID", { skip_if_not_installed("bigutilsr") skip_if_not_installed("MASS") @@ -237,16 +260,35 @@ test_that("multiple methods with ID", { skip_if_not_installed("loo") data <- datawizard::rownames_as_column(mtcars, var = "car") - x <- attributes(check_outliers(data, + x <- attributes(check_outliers( + data, method = c( - "zscore", "zscore_robust", "iqr", "ci", "eti", "hdi", "bci", - "mahalanobis", "mahalanobis_robust", "mcd", "optics", "lof" + "zscore", + "zscore_robust", + "iqr", + "ci", + "eti", + "hdi", + "bci", + "mahalanobis", + "mahalanobis_robust", + "mcd", + "optics", + "lof" ), threshold = list( - zscore = 2.2, zscore_robust = 2.2, iqr = 1.2, - ci = 0.95, eti = 0.95, hdi = 0.90, bci = 0.95, - mahalanobis = 20, mahalanobis_robust = 25, mcd = 25, - optics = 14, lof = 0.005 + zscore = 2.2, + zscore_robust = 2.2, + iqr = 1.2, + ci = 0.95, + eti = 0.95, + hdi = 0.90, + bci = 0.95, + mahalanobis = 20, + mahalanobis_robust = 25, + mcd = 25, + optics = 14, + lof = 0.005 ), ID = "car", verbose = FALSE @@ -376,10 +418,14 @@ test_that("check_outliers with DHARMa", { skip_if_not_installed("DHARMa") mt1 <- mtcars[, c(1, 3, 4)] # create some fake outliers and attach outliers to main df - mt2 <- rbind(mt1, data.frame( - mpg = c(37, 40), disp = c(300, 400), - hp = c(110, 120) - )) + mt2 <- rbind( + mt1, + data.frame( + mpg = c(37, 40), + disp = c(300, 400), + hp = c(110, 120) + ) + ) # fit model with outliers model <- lm(disp ~ mpg + hp, data = mt2) set.seed(123) @@ -389,8 +435,10 @@ test_that("check_outliers with DHARMa", { out, structure( list( - Coefficient = 0.0294117647058824, Expected = 0.00796812749003984, - CI_low = 0.000744364234690261, CI_high = 0.153267669560318, + Coefficient = 0.0294117647058824, + Expected = 0.00796812749003984, + CI_low = 0.000744364234690261, + CI_high = 0.153267669560318, p_value = 0.238146844116552 ), class = c("check_outliers_simres", "list") @@ -401,7 +449,9 @@ test_that("check_outliers with DHARMa", { expect_identical( capture.output(print(out)), c( - "# Outliers detection", "", " Proportion of observed outliers: 2.94%", + "# Outliers detection", + "", + " Proportion of observed outliers: 2.94%", " Proportion of expected outliers: 0.80%, 95% CI [0.07, 15.33]", "" ) diff --git a/tests/testthat/test-check_predictions.R b/tests/testthat/test-check_predictions.R index cf88e0959..015f8f308 100644 --- a/tests/testthat/test-check_predictions.R +++ b/tests/testthat/test-check_predictions.R @@ -10,24 +10,94 @@ test_that("check_predictions", { expect_named( out, c( - "sim_1", "sim_2", "sim_3", "sim_4", "sim_5", "sim_6", "sim_7", - "sim_8", "sim_9", "sim_10", "sim_11", "sim_12", "sim_13", "sim_14", - "sim_15", "sim_16", "sim_17", "sim_18", "sim_19", "sim_20", "sim_21", - "sim_22", "sim_23", "sim_24", "sim_25", "sim_26", "sim_27", "sim_28", - "sim_29", "sim_30", "sim_31", "sim_32", "sim_33", "sim_34", "sim_35", - "sim_36", "sim_37", "sim_38", "sim_39", "sim_40", "sim_41", "sim_42", - "sim_43", "sim_44", "sim_45", "sim_46", "sim_47", "sim_48", "sim_49", - "sim_50", "y" + "sim_1", + "sim_2", + "sim_3", + "sim_4", + "sim_5", + "sim_6", + "sim_7", + "sim_8", + "sim_9", + "sim_10", + "sim_11", + "sim_12", + "sim_13", + "sim_14", + "sim_15", + "sim_16", + "sim_17", + "sim_18", + "sim_19", + "sim_20", + "sim_21", + "sim_22", + "sim_23", + "sim_24", + "sim_25", + "sim_26", + "sim_27", + "sim_28", + "sim_29", + "sim_30", + "sim_31", + "sim_32", + "sim_33", + "sim_34", + "sim_35", + "sim_36", + "sim_37", + "sim_38", + "sim_39", + "sim_40", + "sim_41", + "sim_42", + "sim_43", + "sim_44", + "sim_45", + "sim_46", + "sim_47", + "sim_48", + "sim_49", + "sim_50", + "y" ) ) expect_equal( out$sim_1, c( - 23.70112, 24.56502, 25.43419, 20.40954, 13.58266, 20.72532, - 11.95366, 25.14559, 22.61286, 18.48403, 20.26737, 21.2291, 20.67149, - 10.07628, 0.25886, 10.64176, 10.18407, 20.68235, 28.10115, 27.55045, - 28.22301, 18.94021, 16.87727, 14.05421, 13.8378, 28.13797, 26.86451, - 23.90539, 10.68719, 28.17587, 21.65853, 26.07681 + 23.70112, + 24.56502, + 25.43419, + 20.40954, + 13.58266, + 20.72532, + 11.95366, + 25.14559, + 22.61286, + 18.48403, + 20.26737, + 21.2291, + 20.67149, + 10.07628, + 0.25886, + 10.64176, + 10.18407, + 20.68235, + 28.10115, + 27.55045, + 28.22301, + 18.94021, + 16.87727, + 14.05421, + 13.8378, + 28.13797, + 26.86451, + 23.90539, + 10.68719, + 28.17587, + 21.65853, + 26.07681 ), tolerance = 1e-4 ) @@ -44,21 +114,94 @@ test_that("check_predictions, glmmTMB", { expect_named( out, c( - "sim_1", "sim_2", "sim_3", "sim_4", "sim_5", "sim_6", "sim_7", - "sim_8", "sim_9", "sim_10", "sim_11", "sim_12", "sim_13", "sim_14", - "sim_15", "sim_16", "sim_17", "sim_18", "sim_19", "sim_20", "sim_21", - "sim_22", "sim_23", "sim_24", "sim_25", "sim_26", "sim_27", "sim_28", - "sim_29", "sim_30", "sim_31", "sim_32", "sim_33", "sim_34", "sim_35", - "sim_36", "sim_37", "sim_38", "sim_39", "sim_40", "sim_41", "sim_42", - "sim_43", "sim_44", "sim_45", "sim_46", "sim_47", "sim_48", "sim_49", - "sim_50", "y" + "sim_1", + "sim_2", + "sim_3", + "sim_4", + "sim_5", + "sim_6", + "sim_7", + "sim_8", + "sim_9", + "sim_10", + "sim_11", + "sim_12", + "sim_13", + "sim_14", + "sim_15", + "sim_16", + "sim_17", + "sim_18", + "sim_19", + "sim_20", + "sim_21", + "sim_22", + "sim_23", + "sim_24", + "sim_25", + "sim_26", + "sim_27", + "sim_28", + "sim_29", + "sim_30", + "sim_31", + "sim_32", + "sim_33", + "sim_34", + "sim_35", + "sim_36", + "sim_37", + "sim_38", + "sim_39", + "sim_40", + "sim_41", + "sim_42", + "sim_43", + "sim_44", + "sim_45", + "sim_46", + "sim_47", + "sim_48", + "sim_49", + "sim_50", + "y" ) ) expect_equal( out$sim_1, c( - 1, 1, 1, 1, 0, 1, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, - 1, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0, 1 + 1, + 1, + 1, + 1, + 0, + 1, + 0, + 1, + 1, + 1, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 1, + 1, + 1, + 1, + 0, + 0, + 0, + 0, + 1, + 1, + 1, + 0, + 1, + 0, + 1 ), tolerance = 1e-4 ) @@ -71,8 +214,38 @@ test_that("check_predictions, glmmTMB", { expect_equal( out$sim_1, c( - 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, - 1, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0, 0 + 0, + 1, + 1, + 0, + 0, + 0, + 0, + 1, + 1, + 0, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 1, + 1, + 1, + 1, + 0, + 0, + 0, + 0, + 1, + 1, + 1, + 0, + 1, + 0, + 0 ), tolerance = 1e-4 ) @@ -88,26 +261,13 @@ test_that("check_predictions, glm, binomial", { dat <- data.frame(tot, suc) dat$prop <- suc / tot - mod1 <- glm(cbind(suc, tot - suc) ~ 1, - family = binomial, - data = dat - ) + mod1 <- glm(cbind(suc, tot - suc) ~ 1, family = binomial, data = dat) - mod2 <- glm(prop ~ 1, - family = binomial, - data = dat, - weights = tot - ) + mod2 <- glm(prop ~ 1, family = binomial, data = dat, weights = tot) - mod3 <- glm(cbind(suc, tot) ~ 1, - family = binomial, - data = dat - ) + mod3 <- glm(cbind(suc, tot) ~ 1, family = binomial, data = dat) - mod4 <- glm(am ~ 1, - family = binomial, - data = mtcars - ) + mod4 <- glm(am ~ 1, family = binomial, data = mtcars) set.seed(1) out1 <- check_predictions(mod1) @@ -122,7 +282,11 @@ test_that("check_predictions, glm, binomial", { expect_false(attributes(out1)$model_info$is_bernoulli) expect_equal(head(out2$sim_1), c(1, 0.9, 0.9, 0.8, 1, 0.8), tolerance = 1e-4) expect_false(attributes(out2)$model_info$is_bernoulli) - expect_equal(head(out3$sim_1), c(0.4, 0.42105, 0.47368, 0.61111, 0.4, 0.61111), tolerance = 1e-3) + expect_equal( + head(out3$sim_1), + c(0.4, 0.42105, 0.47368, 0.61111, 0.4, 0.61111), + tolerance = 1e-3 + ) expect_false(attributes(out3)$model_info$is_bernoulli) expect_equal(head(out4$sim_1), c(0, 0, 0, 1, 0, 1), tolerance = 1e-4) expect_true(attributes(out4)$model_info$is_bernoulli) @@ -163,7 +327,7 @@ test_that("check_predictions, glmmTMB, proportion and cbind binomial", { data = cbpp ) - cbpp <- transform(cbpp, prop = incidence/size) + cbpp <- transform(cbpp, prop = incidence / size) m3 <- glmmTMB::glmmTMB( prop ~ period + herd, weights = size, @@ -171,7 +335,7 @@ test_that("check_predictions, glmmTMB, proportion and cbind binomial", { data = cbpp ) - X <- with(cbpp, cbind(incidence, size - incidence)) + X <- with(cbpp, cbind(incidence, size - incidence)) cbpp$X <- X m4 <- glmmTMB::glmmTMB( diff --git a/tests/testthat/test-check_residuals.R b/tests/testthat/test-check_residuals.R index dbaebe447..526ba02c5 100644 --- a/tests/testthat/test-check_residuals.R +++ b/tests/testthat/test-check_residuals.R @@ -52,8 +52,18 @@ test_that("check_residuals and simulate_residuals", { ) # outlier_values works expect_identical(sum(is.infinite(residuals(res, quantile_function = stats::qnorm))), 3L) - expect_identical(sum(is.infinite(residuals(res, quantile_function = stats::qnorm, outlier_values = c(-100, 100)))), 0L) # nolint - expect_error(residuals(res, quantile_function = stats::qnorm, outlier_values = 1:3), regex = "`outlier_values` must be") # nolint + expect_identical( + sum(is.infinite(residuals( + res, + quantile_function = stats::qnorm, + outlier_values = c(-100, 100) + ))), + 0L + ) # nolint + expect_error( + residuals(res, quantile_function = stats::qnorm, outlier_values = 1:3), + regex = "`outlier_values` must be" + ) # nolint # check_residuals out <- check_residuals(res) diff --git a/tests/testthat/test-check_singularity.R b/tests/testthat/test-check_singularity.R index 82a941958..a3c468202 100644 --- a/tests/testthat/test-check_singularity.R +++ b/tests/testthat/test-check_singularity.R @@ -31,7 +31,8 @@ test_that("check_singularity", { skip_if_not_installed("glmmTMB") set.seed(101) dd <- expand.grid(x = factor(1:6), f = factor(1:20), rep = 1:5) - dd$y <- glmmTMB::simulate_new(~ 1 + (x | f), + dd$y <- glmmTMB::simulate_new( + ~ 1 + (x | f), newdata = dd, newparam = list( beta = 0, diff --git a/tests/testthat/test-check_sphericity.R b/tests/testthat/test-check_sphericity.R index ad9022de9..001fb77ac 100644 --- a/tests/testthat/test-check_sphericity.R +++ b/tests/testthat/test-check_sphericity.R @@ -5,17 +5,14 @@ test_that("check_sphericity | afex", { obk.long$treatment <- as.character(obk.long$treatment) suppressWarnings(suppressMessages({ - aM <- afex::aov_car(value ~ treatment * gender + Error(id / (phase * hour)), + aM <- afex::aov_car( + value ~ treatment * gender + Error(id / (phase * hour)), data = obk.long ) - aW <- afex::aov_car(value ~ Error(id / (phase * hour)), - data = obk.long - ) + aW <- afex::aov_car(value ~ Error(id / (phase * hour)), data = obk.long) - aB <- afex::aov_car(value ~ treatment * gender + Error(id), - data = obk.long - ) + aB <- afex::aov_car(value ~ treatment * gender + Error(id), data = obk.long) })) expect_error(check_sphericity(aB)) diff --git a/tests/testthat/test-compare_performance.R b/tests/testthat/test-compare_performance.R index efe45be37..3fce8c4c9 100644 --- a/tests/testthat/test-compare_performance.R +++ b/tests/testthat/test-compare_performance.R @@ -7,13 +7,39 @@ test_that("compare_performance", { expect_silent(expect_identical( colnames(compare_performance(lm1, lm2, lm3)), - c("Name", "Model", "AIC", "AIC_wt", "AICc", "AICc_wt", "BIC", "BIC_wt", "R2", "R2_adjusted", "RMSE", "Sigma") + c( + "Name", + "Model", + "AIC", + "AIC_wt", + "AICc", + "AICc_wt", + "BIC", + "BIC_wt", + "R2", + "R2_adjusted", + "RMSE", + "Sigma" + ) )) expect_message( expect_identical( colnames(compare_performance(lm1, lm2, lm3, lm4)), - c("Name", "Model", "AIC", "AIC_wt", "AICc", "AICc_wt", "BIC", "BIC_wt", "R2", "R2_adjusted", "RMSE", "Sigma") + c( + "Name", + "Model", + "AIC", + "AIC_wt", + "AICc", + "AICc_wt", + "BIC", + "BIC_wt", + "R2", + "R2_adjusted", + "RMSE", + "Sigma" + ) ) ) @@ -22,11 +48,28 @@ test_that("compare_performance", { expect_snapshot(print(compare_performance(lm1, lm2, lm3), table_width = Inf)) # vertical layout expect_snapshot(print(compare_performance(lm1, lm2, lm3), layout = "vertical")) - expect_snapshot(print(compare_performance(lm1, lm2, lm3, lm4), layout = "vertical", table_width = 50)) + expect_snapshot(print( + compare_performance(lm1, lm2, lm3, lm4), + layout = "vertical", + table_width = 50 + )) expect_silent(expect_identical( colnames(compare_performance(lm1, lm2, lm3, lm4, verbose = FALSE)), - c("Name", "Model", "AIC", "AIC_wt", "AICc", "AICc_wt", "BIC", "BIC_wt", "R2", "R2_adjusted", "RMSE", "Sigma") + c( + "Name", + "Model", + "AIC", + "AIC_wt", + "AICc", + "AICc_wt", + "BIC", + "BIC_wt", + "R2", + "R2_adjusted", + "RMSE", + "Sigma" + ) )) out <- compare_performance(lm1, lm2, lm3, lm4, verbose = FALSE) @@ -34,12 +77,29 @@ test_that("compare_performance", { models <- list(Interaction = lm3, NoInteraction = lm2, SingleTerm = lm1) rez <- compare_performance(models) - expect_equal(rez$Name, c("Interaction", "NoInteraction", "SingleTerm"), ignore_attr = TRUE) + expect_equal( + rez$Name, + c("Interaction", "NoInteraction", "SingleTerm"), + ignore_attr = TRUE + ) out <- compare_performance(list(lm1, lm2, lm3, lm4), verbose = FALSE) expect_identical( colnames(out), - c("Name", "Model", "AIC", "AIC_wt", "AICc", "AICc_wt", "BIC", "BIC_wt", "R2", "R2_adjusted", "RMSE", "Sigma") + c( + "Name", + "Model", + "AIC", + "AIC_wt", + "AICc", + "AICc_wt", + "BIC", + "BIC_wt", + "R2", + "R2_adjusted", + "RMSE", + "Sigma" + ) ) expect_identical(out$Name, c("Model 1", "Model 2", "Model 3", "Model 4")) @@ -47,7 +107,20 @@ test_that("compare_performance", { out <- compare_performance(models, verbose = FALSE) expect_identical( colnames(out), - c("Name", "Model", "AIC", "AIC_wt", "AICc", "AICc_wt", "BIC", "BIC_wt", "R2", "R2_adjusted", "RMSE", "Sigma") + c( + "Name", + "Model", + "AIC", + "AIC_wt", + "AICc", + "AICc_wt", + "BIC", + "BIC_wt", + "R2", + "R2_adjusted", + "RMSE", + "Sigma" + ) ) expect_identical(out$Name, c("Model 1", "Model 2", "Model 3", "Model 4")) diff --git a/tests/testthat/test-coxph.R b/tests/testthat/test-coxph.R index b0dfcf86e..0e98e4b1d 100644 --- a/tests/testthat/test-coxph.R +++ b/tests/testthat/test-coxph.R @@ -9,7 +9,12 @@ m1 <- survival::coxph(survival::Surv(time, status) ~ sex + age + ph.ecog, data = test_that("r2", { expect_equal(r2_nagelkerke(m1), c(`Nagelkerke's R2` = 0.1203544), tolerance = 1e-3) - expect_equal(r2(m1), list(R2 = c(`Nagelkerke's R2` = 0.1203544)), tolerance = 1e-3, ignore_attr = TRUE) + expect_equal( + r2(m1), + list(R2 = c(`Nagelkerke's R2` = 0.1203544)), + tolerance = 1e-3, + ignore_attr = TRUE + ) }) test_that("model_performance", { diff --git a/tests/testthat/test-cronbachs_alpha.R b/tests/testthat/test-cronbachs_alpha.R index fcc6e743d..20d07b6d4 100644 --- a/tests/testthat/test-cronbachs_alpha.R +++ b/tests/testthat/test-cronbachs_alpha.R @@ -14,11 +14,19 @@ test_that("cronbachs_alpha, principal_components", { skip_if_not_installed("parameters") pca <- parameters::principal_components(mtcars[, c("cyl", "gear", "carb", "hp")], n = 2) - expect_equal(cronbachs_alpha(pca, verbose = FALSE), c(PC1 = 0.1101384), tolerance = 1e-3) + expect_equal( + cronbachs_alpha(pca, verbose = FALSE), + c(PC1 = 0.1101384), + tolerance = 1e-3 + ) expect_message(cronbachs_alpha(pca), regex = "Too few") pca <- parameters::principal_components(mtcars[, c("cyl", "gear", "carb", "hp")], n = 1) - expect_equal(cronbachs_alpha(pca, verbose = FALSE), c(PC1 = 0.09463206), tolerance = 1e-3) + expect_equal( + cronbachs_alpha(pca, verbose = FALSE), + c(PC1 = 0.09463206), + tolerance = 1e-3 + ) expect_silent(cronbachs_alpha(pca)) }) diff --git a/tests/testthat/test-glmmPQL.R b/tests/testthat/test-glmmPQL.R index 6c1713cc8..3172179fa 100644 --- a/tests/testthat/test-glmmPQL.R +++ b/tests/testthat/test-glmmPQL.R @@ -2,14 +2,26 @@ skip_if_not_installed("MASS") test_that("r2", { example_dat <- data.frame( prop = c(0.2, 0.2, 0.5, 0.7, 0.1, 1, 1, 1, 0.1), - size = c("small", "small", "small", "large", "large", "large", "large", "small", "small"), + size = c( + "small", + "small", + "small", + "large", + "large", + "large", + "large", + "small", + "small" + ), x = c(0.1, 0.1, 0.8, 0.7, 0.6, 0.5, 0.5, 0.1, 0.1), species = c("sp1", "sp1", "sp2", "sp2", "sp3", "sp3", "sp4", "sp4", "sp4"), stringsAsFactors = FALSE ) - mn <- MASS::glmmPQL(prop ~ x + size, + mn <- MASS::glmmPQL( + prop ~ x + size, random = ~ 1 | species, - family = "quasibinomial", data = example_dat + family = "quasibinomial", + data = example_dat ) expect_message(performance_score(mn), regex = "Can't calculate") }) diff --git a/tests/testthat/test-icc.R b/tests/testthat/test-icc.R index 7c92f4a92..b79c6f7fc 100644 --- a/tests/testthat/test-icc.R +++ b/tests/testthat/test-icc.R @@ -12,7 +12,8 @@ test_that("icc", { expect_equal( icc(m1), data.frame( - ICC_adjusted = 0.910433109183341, ICC_conditional = 0.310947768161385, + ICC_adjusted = 0.910433109183341, + ICC_conditional = 0.310947768161385, ICC_unadjusted = 0.310947768161385 ), tolerance = 1e-3, @@ -43,7 +44,8 @@ test_that("icc", { expect_equal( icc(m2), data.frame( - ICC_adjusted = 0.40579, ICC_conditional = 0.21881, + ICC_adjusted = 0.40579, + ICC_conditional = 0.21881, ICC_unadjusted = 0.21881 ), tolerance = 1e-2, @@ -75,7 +77,8 @@ test_that("icc", { expect_equal( icc(m3), data.frame( - ICC_adjusted = 0.930217931275196, ICC_conditional = 0.771475122370036, + ICC_adjusted = 0.930217931275196, + ICC_conditional = 0.771475122370036, ICC_unadjusted = 0.771475122370036 ), tolerance = 0.05, @@ -132,12 +135,22 @@ test_that("icc, glmmTMB 1.1.9+", { x2 = runif(1000, 0, 10), re = rep(1:20, each = 50) ) - dd <- transform(dd, x3 = as.factor(ifelse( - x1 <= 500, "Low", sample(c("Middle", "High"), 1000, replace = TRUE) - ))) - dd <- transform(dd, x4 = as.factor(ifelse( - x1 > 500, "High", sample(c("Absent", "Low"), 1000, replace = TRUE) - ))) + dd <- transform( + dd, + x3 = as.factor(ifelse( + x1 <= 500, + "Low", + sample(c("Middle", "High"), 1000, replace = TRUE) + )) + ) + dd <- transform( + dd, + x4 = as.factor(ifelse( + x1 > 500, + "High", + sample(c("Absent", "Low"), 1000, replace = TRUE) + )) + ) dd <- transform(dd, z = z + re * 5) expect_message({ mod_TMB <- glmmTMB::glmmTMB( diff --git a/tests/testthat/test-item_difficulty.R b/tests/testthat/test-item_difficulty.R index e40da29af..ca9fa2a8f 100644 --- a/tests/testthat/test-item_difficulty.R +++ b/tests/testthat/test-item_difficulty.R @@ -6,7 +6,9 @@ test_that("item_difficulty", { structure( list( Item = c( - "Sepal.Length", "Sepal.Width", "Petal.Length", + "Sepal.Length", + "Sepal.Width", + "Petal.Length", "Petal.Width" ), Difficulty = c(0.74, 0.69, 0.54, 0.48), diff --git a/tests/testthat/test-item_discrimination.R b/tests/testthat/test-item_discrimination.R index b057de744..a2afdcc4a 100644 --- a/tests/testthat/test-item_discrimination.R +++ b/tests/testthat/test-item_discrimination.R @@ -7,16 +7,27 @@ test_that("item_discrimination", { expect_equal( item_discrimination(x), - structure(list(Item = c( - "Sepal.Length", "Sepal.Width", "Petal.Length", - "Petal.Width" - ), Discrimination = c( - 0.894040250011166, -0.348657747269071, - 0.863271047498634, 0.921040960149154 - )), class = c( - "item_discrimination", - "data.frame" - ), row.names = c(NA, -4L)), + structure( + list( + Item = c( + "Sepal.Length", + "Sepal.Width", + "Petal.Length", + "Petal.Width" + ), + Discrimination = c( + 0.894040250011166, + -0.348657747269071, + 0.863271047498634, + 0.921040960149154 + ) + ), + class = c( + "item_discrimination", + "data.frame" + ), + row.names = c(NA, -4L) + ), tolerance = 1e-3 ) diff --git a/tests/testthat/test-mclogit.R b/tests/testthat/test-mclogit.R index bb50551de..e26f410e3 100644 --- a/tests/testthat/test-mclogit.R +++ b/tests/testthat/test-mclogit.R @@ -2,7 +2,11 @@ skip_if_not_installed("mclogit") data(Transport, package = "mclogit") mod_mb <- mclogit::mblogit(factor(gear) ~ mpg + hp, data = mtcars, trace = FALSE) -mod_mc <- mclogit::mclogit(resp | suburb ~ distance + cost, data = Transport, trace = FALSE) +mod_mc <- mclogit::mclogit( + resp | suburb ~ distance + cost, + data = Transport, + trace = FALSE +) test_that("r2 Nagelkerke", { expect_equal( diff --git a/tests/testthat/test-model_performance-various.R b/tests/testthat/test-model_performance-various.R index 3fd797e56..8c207e531 100644 --- a/tests/testthat/test-model_performance-various.R +++ b/tests/testthat/test-model_performance-various.R @@ -22,8 +22,16 @@ test_that("model_performance various", { ) expect_equal(model_performance(m1, verbose = FALSE)$R2, 0.9617312, tolerance = 1e-4) - expect_equal(model_performance(m3, verbose = FALSE)$R2_Nagelkerke, 0.4042792, tolerance = 1e-4) - expect_equal(model_performance(m4, verbose = FALSE)$R2_Nagelkerke, 0.4042792, tolerance = 1e-4) + expect_equal( + model_performance(m3, verbose = FALSE)$R2_Nagelkerke, + 0.4042792, + tolerance = 1e-4 + ) + expect_equal( + model_performance(m4, verbose = FALSE)$R2_Nagelkerke, + 0.4042792, + tolerance = 1e-4 + ) expect_equal(model_performance(m5, verbose = FALSE)$R2, 0.4294224, tolerance = 1e-4) mp <- model_performance(m5) @@ -36,7 +44,6 @@ test_that("model_performance various", { expect_equal(mp$weak_instruments_p, ms$diagnostics["Weak instruments", 4]) }) - # DirichletReg is currently orphaned # test_that("model_performance (Dirichlet regression)", { # skip_if_not_installed("DirichletReg") diff --git a/tests/testthat/test-model_performance.bayesian.R b/tests/testthat/test-model_performance.bayesian.R index f19723762..781ab9e38 100644 --- a/tests/testthat/test-model_performance.bayesian.R +++ b/tests/testthat/test-model_performance.bayesian.R @@ -47,10 +47,20 @@ test_that("model_performance.brmsfit", { expect_equal(perf$R2, 0.8262673, tolerance = 1e-2) expect_equal(perf$R2_adjusted, 0.792831, tolerance = 1e-2) expect_equal(perf$ELPD, -78.59823, tolerance = 1e-2) - expect_identical(colnames(perf), c( - "ELPD", "ELPD_SE", "LOOIC", "LOOIC_SE", "WAIC", "R2", "R2_adjusted", - "RMSE", "Sigma" - )) + expect_identical( + colnames(perf), + c( + "ELPD", + "ELPD_SE", + "LOOIC", + "LOOIC_SE", + "WAIC", + "R2", + "R2_adjusted", + "RMSE", + "Sigma" + ) + ) model <- insight::download_model("brms_mixed_4") skip_if(is.null(model)) @@ -60,10 +70,23 @@ test_that("model_performance.brmsfit", { expect_equal(perf$R2, 0.954538, tolerance = 1e-2) expect_equal(perf$R2_adjusted, 0.9526158, tolerance = 1e-2) expect_equal(perf$ELPD, -70.40493, tolerance = 1e-2) - expect_named(perf, c( - "ELPD", "ELPD_SE", "LOOIC", "LOOIC_SE", "WAIC", "R2", "R2_marginal", - "R2_adjusted", "R2_adjusted_marginal", "ICC", "RMSE", "Sigma" - )) + expect_named( + perf, + c( + "ELPD", + "ELPD_SE", + "LOOIC", + "LOOIC_SE", + "WAIC", + "R2", + "R2_marginal", + "R2_adjusted", + "R2_adjusted_marginal", + "ICC", + "RMSE", + "Sigma" + ) + ) model <- insight::download_model("brms_ordinal_1") skip_if(is.null(model)) @@ -87,7 +110,11 @@ test_that("model_performance.BFBayesFactor", { }) expect_null(p) - mods <- BayesFactor::contingencyTableBF(matrix(1:4, 2), sampleType = "indepMulti", fixedMargin = "cols") + mods <- BayesFactor::contingencyTableBF( + matrix(1:4, 2), + sampleType = "indepMulti", + fixedMargin = "cols" + ) expect_warning({ p <- model_performance(mod) }) diff --git a/tests/testthat/test-model_performance.kmeans.R b/tests/testthat/test-model_performance.kmeans.R index 654b15d58..94415f8d7 100644 --- a/tests/testthat/test-model_performance.kmeans.R +++ b/tests/testthat/test-model_performance.kmeans.R @@ -2,7 +2,8 @@ test_that("model_performance.kmeans", { set.seed(123) cl <- kmeans(subset(iris, select = Sepal.Length:Petal.Width), 3) - expect_equal(model_performance(cl), + expect_equal( + model_performance(cl), structure( list( Sum_Squares_Total = 681.370599999999, @@ -20,8 +21,11 @@ test_that("model_performance.kmeans", { ) set.seed(123) - mod <- kmeans(subset(iris, select = Sepal.Length:Petal.Width), - centers = 3, iter.max = 100, nstart = 10 + mod <- kmeans( + subset(iris, select = Sepal.Length:Petal.Width), + centers = 3, + iter.max = 100, + nstart = 10 ) expect_equal( diff --git a/tests/testthat/test-model_performance.lavaan.R b/tests/testthat/test-model_performance.lavaan.R index 3a3bc0e8a..386c20d43 100644 --- a/tests/testthat/test-model_performance.lavaan.R +++ b/tests/testthat/test-model_performance.lavaan.R @@ -11,10 +11,31 @@ test_that("model_performance.lavaan", { expect_named( out, c( - "Chi2", "Chi2_df", "p_Chi2", "Baseline", "Baseline_df", "p_Baseline", - "GFI", "AGFI", "NFI", "NNFI", "CFI", "RMSEA", "RMSEA_CI_low", - "RMSEA_CI_high", "p_RMSEA", "RMR", "SRMR", "RFI", "PNFI", "IFI", - "RNI", "Loglikelihood", "AIC", "BIC", "BIC_adjusted" + "Chi2", + "Chi2_df", + "p_Chi2", + "Baseline", + "Baseline_df", + "p_Baseline", + "GFI", + "AGFI", + "NFI", + "NNFI", + "CFI", + "RMSEA", + "RMSEA_CI_low", + "RMSEA_CI_high", + "p_RMSEA", + "RMR", + "SRMR", + "RFI", + "PNFI", + "IFI", + "RNI", + "Loglikelihood", + "AIC", + "BIC", + "BIC_adjusted" ) ) diff --git a/tests/testthat/test-model_performance.lm.R b/tests/testthat/test-model_performance.lm.R index e81d2b5b3..8cf0262bc 100644 --- a/tests/testthat/test-model_performance.lm.R +++ b/tests/testthat/test-model_performance.lm.R @@ -13,20 +13,40 @@ test_that("model_performance.glm", { expect_equal( colnames(model_performance(model)), c( - "AIC", "AICc", "BIC", "R2_Tjur", "RMSE", "Sigma", "Log_loss", "Score_log", - "Score_spherical", "PCP" + "AIC", + "AICc", + "BIC", + "R2_Tjur", + "RMSE", + "Sigma", + "Log_loss", + "Score_log", + "Score_spherical", + "PCP" ) ) }) test_that("model_performance.glm-factor", { - model <- glm(factor(vs, labels = c("automatic", "manual")) ~ wt + mpg, data = mtcars, family = "binomial") + model <- glm( + factor(vs, labels = c("automatic", "manual")) ~ wt + mpg, + data = mtcars, + family = "binomial" + ) expect_equal(model_performance(model)$R2_Tjur, 0.478, tolerance = 0.01) expect_equal( colnames(model_performance(model)), c( - "AIC", "AICc", "BIC", "R2_Tjur", "RMSE", "Sigma", "Log_loss", "Score_log", - "Score_spherical", "PCP" + "AIC", + "AICc", + "BIC", + "R2_Tjur", + "RMSE", + "Sigma", + "Log_loss", + "Score_log", + "Score_spherical", + "PCP" ) ) }) diff --git a/tests/testthat/test-model_performance.merMod.R b/tests/testthat/test-model_performance.merMod.R index cc224ee8d..d204f52f1 100644 --- a/tests/testthat/test-model_performance.merMod.R +++ b/tests/testthat/test-model_performance.merMod.R @@ -6,13 +6,25 @@ test_that("model_performance.merMod", { model <- insight::download_model("lmerMod_1") skip_if(is.null(model)) - expect_equal(model_performance(model, estimator = "ML")$AIC, AIC(logLik(model, REML = FALSE)), tolerance = 0.01) - expect_equal(model_performance(model, estimator = "REML")$AIC, AIC(model), tolerance = 0.01) + expect_equal( + model_performance(model, estimator = "ML")$AIC, + AIC(logLik(model, REML = FALSE)), + tolerance = 0.01 + ) + expect_equal( + model_performance(model, estimator = "REML")$AIC, + AIC(model), + tolerance = 0.01 + ) model <- insight::download_model("merMod_1") skip_if(is.null(model)) expect_equal(model_performance(model)$AIC, AIC(model), tolerance = 0.01) - expect_equal(model_performance(model, estimator = "REML")$AIC, AIC(model), tolerance = 0.01) + expect_equal( + model_performance(model, estimator = "REML")$AIC, + AIC(model), + tolerance = 0.01 + ) expect_equal(model_performance(model)$AIC, 23.58593, tolerance = 0.01) model <- insight::download_model("merMod_2") @@ -33,7 +45,11 @@ test_that("model_performance.merMod AICc", { c(177.52804, 182.88598), tolerance = 1e-3 )) - expect_equal(model_performance(m1, metrics = "AICc", estimator = "REML")$AICc, 177.52804, tolerance = 1e-3) + expect_equal( + model_performance(m1, metrics = "AICc", estimator = "REML")$AICc, + 177.52804, + tolerance = 1e-3 + ) expect_equal(performance_aicc(m1, estimator = "REML"), 177.52804, tolerance = 1e-3) # default - ML @@ -44,7 +60,11 @@ test_that("model_performance.merMod AICc", { ) # default model_performance is REML expect_equal(model_performance(m1, metrics = "AICc")$AICc, 177.52804, tolerance = 1e-3) - expect_equal(model_performance(m1, metrics = "AICc", estimator = "ML")$AICc, 174.5701, tolerance = 1e-3) + expect_equal( + model_performance(m1, metrics = "AICc", estimator = "ML")$AICc, + 174.5701, + tolerance = 1e-3 + ) # default performance_aic is REML expect_equal(performance_aicc(m1), 177.52804, tolerance = 1e-3) expect_equal(performance_aicc(m1, estimator = "ML"), 174.5701, tolerance = 1e-3) diff --git a/tests/testthat/test-model_performance.psych.R b/tests/testthat/test-model_performance.psych.R index ac1ca4a68..6a1cb7487 100644 --- a/tests/testthat/test-model_performance.psych.R +++ b/tests/testthat/test-model_performance.psych.R @@ -8,12 +8,12 @@ test_that("model_performance.psych", { raq_items$id <- NULL raq_fa <- parameters::factor_analysis( - raq_items, - n = 4, - scores = "tenBerge", - cor = "poly", - rotation = "none", - standardize = FALSE + raq_items, + n = 4, + scores = "tenBerge", + cor = "poly", + rotation = "none", + standardize = FALSE ) expect_snapshot(print(raq_fa)) diff --git a/tests/testthat/test-model_performance.rma.R b/tests/testthat/test-model_performance.rma.R index eb06f5d95..bbfaa6f49 100644 --- a/tests/testthat/test-model_performance.rma.R +++ b/tests/testthat/test-model_performance.rma.R @@ -2,8 +2,12 @@ skip_if_not_installed("metafor") skip_if_not_installed("metadat") data(dat.bcg, package = "metadat") dat <- metafor::escalc( - measure = "RR", ai = tpos, bi = tneg, ci = cpos, - di = cneg, data = dat.bcg + measure = "RR", + ai = tpos, + bi = tneg, + ci = cpos, + di = cneg, + data = dat.bcg ) test_that("model_performance.rma", { @@ -12,10 +16,21 @@ test_that("model_performance.rma", { expect_null(mp$R2) expect_equal(mp$AIC, 28.40474, tolerance = 1e-3) expect_equal(mp$I2, 0.9222139, tolerance = 1e-3) - expect_identical(colnames(mp), c( - "AIC", "BIC", "I2", "H2", "TAU2", "CochransQ", - "p_CochransQ", "df_error", "Omnibus", "p_Omnibus" - )) + expect_identical( + colnames(mp), + c( + "AIC", + "BIC", + "I2", + "H2", + "TAU2", + "CochransQ", + "p_CochransQ", + "df_error", + "Omnibus", + "p_Omnibus" + ) + ) }) test_that("check_outliers.rma", { @@ -24,8 +39,19 @@ test_that("check_outliers.rma", { expect_equal( out, c( - FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, - FALSE, FALSE, FALSE, FALSE, FALSE + FALSE, + FALSE, + FALSE, + TRUE, + FALSE, + FALSE, + FALSE, + TRUE, + FALSE, + FALSE, + FALSE, + FALSE, + FALSE ), ignore_attr = TRUE ) @@ -39,8 +65,20 @@ test_that("model_performance.rma", { expect_equal(mp$R2, 0.6463217, tolerance = 1e-3) expect_equal(mp$AIC, 24.21375, tolerance = 1e-3) expect_equal(mp$I2, 0.719778, tolerance = 1e-3) - expect_identical(colnames(mp), c( - "AIC", "BIC", "I2", "H2", "TAU2", "CochransQ", - "p_CochransQ", "df_error", "Omnibus", "p_Omnibus", "R2" - )) + expect_identical( + colnames(mp), + c( + "AIC", + "BIC", + "I2", + "H2", + "TAU2", + "CochransQ", + "p_CochransQ", + "df_error", + "Omnibus", + "p_Omnibus", + "R2" + ) + ) }) diff --git a/tests/testthat/test-nestedLogit.R b/tests/testthat/test-nestedLogit.R index 52ffaddb9..b0f800282 100644 --- a/tests/testthat/test-nestedLogit.R +++ b/tests/testthat/test-nestedLogit.R @@ -17,10 +17,12 @@ test_that("r2", { out <- r2(mnl) expect_equal( out, - list(R2_Tjur = list( - work = c(`Tjur's R2` = 0.137759452521642), - full = c(`Tjur's R2` = 0.332536937208286) - )), + list( + R2_Tjur = list( + work = c(`Tjur's R2` = 0.137759452521642), + full = c(`Tjur's R2` = 0.332536937208286) + ) + ), ignore_attr = TRUE, tolerance = 1e-4 ) diff --git a/tests/testthat/test-performance_reliability.R b/tests/testthat/test-performance_reliability.R index 5befbf04e..f78c2af71 100644 --- a/tests/testthat/test-performance_reliability.R +++ b/tests/testthat/test-performance_reliability.R @@ -31,7 +31,6 @@ test_that("performance_reliability - Bayesian", { expect_equal(out$Reliability, c(0.97116, 0.80915), tolerance = 1e-3) }) - ## FIXME: doesn't work yet for Bayesian models # test_that("performance_reliability - Bayesian", { diff --git a/tests/testthat/test-performance_roc.R b/tests/testthat/test-performance_roc.R index 4a02042fa..8f698b7cb 100644 --- a/tests/testthat/test-performance_roc.R +++ b/tests/testthat/test-performance_roc.R @@ -7,10 +7,40 @@ test_that("performance_roc", { expect_equal( roc$Sensitivity, c( - 0, 0.07143, 0.14286, 0.21429, 0.28571, 0.35714, 0.42857, 0.5, - 0.57143, 0.57143, 0.64286, 0.64286, 0.64286, 0.71429, 0.78571, - 0.85714, 0.85714, 0.92857, 0.92857, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1 + 0, + 0.07143, + 0.14286, + 0.21429, + 0.28571, + 0.35714, + 0.42857, + 0.5, + 0.57143, + 0.57143, + 0.64286, + 0.64286, + 0.64286, + 0.71429, + 0.78571, + 0.85714, + 0.85714, + 0.92857, + 0.92857, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1 ), tolerance = 1e-3 ) @@ -32,13 +62,58 @@ test_that("performance_roc", { expect_equal( roc$Sensitivity, c( - 0, 0, 0.07692, 0.07692, 0.07692, 0.15385, 0.23077, 0.23077, - 0.23077, 0.23077, 0.23077, 0.30769, 0.30769, 0.30769, 0.30769, - 0.30769, 0.38462, 0.38462, 0.38462, 0.46154, 0.46154, 0.53846, - 0.53846, 0.53846, 0.53846, 0.61538, 0.61538, 0.61538, 0.61538, - 0.61538, 0.69231, 0.76923, 0.76923, 0.76923, 0.84615, 0.92308, - 0.92308, 0.92308, 0.92308, 0.92308, 0.92308, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1 + 0, + 0, + 0.07692, + 0.07692, + 0.07692, + 0.15385, + 0.23077, + 0.23077, + 0.23077, + 0.23077, + 0.23077, + 0.30769, + 0.30769, + 0.30769, + 0.30769, + 0.30769, + 0.38462, + 0.38462, + 0.38462, + 0.46154, + 0.46154, + 0.53846, + 0.53846, + 0.53846, + 0.53846, + 0.61538, + 0.61538, + 0.61538, + 0.61538, + 0.61538, + 0.69231, + 0.76923, + 0.76923, + 0.76923, + 0.84615, + 0.92308, + 0.92308, + 0.92308, + 0.92308, + 0.92308, + 0.92308, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1 ), tolerance = 1e-3 ) diff --git a/tests/testthat/test-pkg-fixest.R b/tests/testthat/test-pkg-fixest.R index b6c7e93b0..e19f5e6ec 100644 --- a/tests/testthat/test-pkg-fixest.R +++ b/tests/testthat/test-pkg-fixest.R @@ -10,7 +10,11 @@ test_that("fixest: r2", { expect_equal(r2_res$R2, fixest::fitstat(res, "r2")[[1]], ignore_attr = TRUE) expect_equal(r2_res$R2_adjusted, fixest::fitstat(res, "ar2")[[1]], ignore_attr = TRUE) expect_equal(r2_res$R2_within, fixest::fitstat(res, "wr2")[[1]], ignore_attr = TRUE) - expect_equal(r2_res$R2_within_adjusted, fixest::fitstat(res, "war2")[[1]], ignore_attr = TRUE) + expect_equal( + r2_res$R2_within_adjusted, + fixest::fitstat(res, "war2")[[1]], + ignore_attr = TRUE + ) }) diff --git a/tests/testthat/test-pkg-ivreg.R b/tests/testthat/test-pkg-ivreg.R index 83b534938..7a97a1527 100644 --- a/tests/testthat/test-pkg-ivreg.R +++ b/tests/testthat/test-pkg-ivreg.R @@ -2,7 +2,10 @@ test_that("Issue #530 from the `modelsummary` repo", { skip_if_not_installed("ivreg") # for ivreg diagnostics data(mtcars) - iv_model <- suppressMessages(ivreg::ivreg(mpg ~ qsec + cyl + drat | disp | wt, data = mtcars)) + iv_model <- suppressMessages(ivreg::ivreg( + mpg ~ qsec + cyl + drat | disp | wt, + data = mtcars + )) out <- expect_silent(model_performance(iv_model)) expect_snapshot(out) }) diff --git a/tests/testthat/test-r2.R b/tests/testthat/test-r2.R index 6b4ac0b05..fc8ba21aa 100644 --- a/tests/testthat/test-r2.R +++ b/tests/testthat/test-r2.R @@ -103,7 +103,11 @@ withr::with_environment( lot1 = c(118, 58, 42, 35, 27, 25, 21, 19, 18), lot2 = c(69, 35, 26, 21, 18, 16, 13, 12, 12) ) - m <- suppressWarnings(glmmTMB::glmmTMB(lot1 ~ log(u), data = clotting, family = Gamma())) + m <- suppressWarnings(glmmTMB::glmmTMB( + lot1 ~ log(u), + data = clotting, + family = Gamma() + )) out <- r2(m) expect_equal(out[[1]], 0.996103, tolerance = 1e-3, ignore_attr = TRUE) # validate against glm diff --git a/tests/testthat/test-r2_bayes.R b/tests/testthat/test-r2_bayes.R index 830e08adc..ea5ef9397 100644 --- a/tests/testthat/test-r2_bayes.R +++ b/tests/testthat/test-r2_bayes.R @@ -20,7 +20,12 @@ test_that("r2_BayesFactor", { # with random effects: skip_if_not_installed("BayesFactor", minimum_version = "0.9.12.4.3") mtcars$gear <- factor(mtcars$gear) - model <- BayesFactor::lmBF(mpg ~ hp + cyl + gear + gear:wt, mtcars, progress = FALSE, whichRandom = c("gear", "gear:wt")) + model <- BayesFactor::lmBF( + mpg ~ hp + cyl + gear + gear:wt, + mtcars, + progress = FALSE, + whichRandom = c("gear", "gear:wt") + ) r_BF <- r2(model, ci = 0.89) r_CI <- attr(r_BF, "CI")$R2_Bayes diff --git a/tests/testthat/test-r2_coxsnell.R b/tests/testthat/test-r2_coxsnell.R index c3be11520..3c48ed29e 100644 --- a/tests/testthat/test-r2_coxsnell.R +++ b/tests/testthat/test-r2_coxsnell.R @@ -1,4 +1,8 @@ test_that("r2_coxsnell", { model <- glm(vs ~ wt + mpg, data = mtcars, family = "binomial") - expect_equal(r2_coxsnell(model), c(`Cox & Snell's R2` = 0.440140715155838), tolerance = 1e-3) + expect_equal( + r2_coxsnell(model), + c(`Cox & Snell's R2` = 0.440140715155838), + tolerance = 1e-3 + ) }) diff --git a/tests/testthat/test-r2_ferrari.R b/tests/testthat/test-r2_ferrari.R index 35aab72c1..237d32077 100644 --- a/tests/testthat/test-r2_ferrari.R +++ b/tests/testthat/test-r2_ferrari.R @@ -3,7 +3,12 @@ test_that("r2_ferarri", { data("GasolineYield", package = "betareg") model <- betareg::betareg(yield ~ batch + temp, data = GasolineYield) out <- r2_ferrari(model) - expect_equal(out$R2, summary(model)$pseudo.r.squared, tolerance = 1e-3, ignore_attr = TRUE) + expect_equal( + out$R2, + summary(model)$pseudo.r.squared, + tolerance = 1e-3, + ignore_attr = TRUE + ) }) @@ -33,5 +38,10 @@ test_that("r2_ferarri", { family = glmmTMB::ordbeta() ) out <- r2(m) - expect_equal(out$R2, c(`Ferrari's R2` = 0.2354701), tolerance = 1e-3, ignore_attr = TRUE) + expect_equal( + out$R2, + c(`Ferrari's R2` = 0.2354701), + tolerance = 1e-3, + ignore_attr = TRUE + ) }) diff --git a/tests/testthat/test-r2_kullback.R b/tests/testthat/test-r2_kullback.R index 8ce9620b9..c5f212e0c 100644 --- a/tests/testthat/test-r2_kullback.R +++ b/tests/testthat/test-r2_kullback.R @@ -1,7 +1,11 @@ test_that("r2_kullback", { model <- glm(vs ~ wt + mpg, data = mtcars, family = "binomial") expect_equal(r2_kullback(model), c(`Kullback-Leibler R2` = 0.3834), tolerance = 1e-3) - expect_equal(r2_kullback(model, adjust = FALSE), c(`Kullback-Leibler R2` = 0.4232), tolerance = 1e-3) + expect_equal( + r2_kullback(model, adjust = FALSE), + c(`Kullback-Leibler R2` = 0.4232), + tolerance = 1e-3 + ) }) test_that("r2_kullback errors for non-supported", { diff --git a/tests/testthat/test-r2_mcfadden.R b/tests/testthat/test-r2_mcfadden.R index 354f6884e..4607375cf 100644 --- a/tests/testthat/test-r2_mcfadden.R +++ b/tests/testthat/test-r2_mcfadden.R @@ -12,7 +12,8 @@ test_that("r2_mcfadden", { R2 = c(`McFadden's R2` = 0.0465152150591893), R2_adjusted = c(`adjusted McFadden's R2` = 0.0459671013089695) ), - model_type = "Generalized Linear", class = "r2_generic" + model_type = "Generalized Linear", + class = "r2_generic" ), tolerance = 1e-3 ) diff --git a/tests/testthat/test-r2_nagelkerke.R b/tests/testthat/test-r2_nagelkerke.R index 7eca752f7..4563538c2 100644 --- a/tests/testthat/test-r2_nagelkerke.R +++ b/tests/testthat/test-r2_nagelkerke.R @@ -1,7 +1,16 @@ test_that("r2_nagelkerke", { model <- glm(vs ~ wt + mpg, data = mtcars, family = "binomial") - expect_equal(r2_nagelkerke(model), c(`Nagelkerke's R2` = 0.589959301837163), tolerance = 1e-3) - expect_equal(r2(model), list(R2_Tjur = c(`Tjur's R2` = 0.477692621360749)), tolerance = 1e-3, ignore_attr = TRUE) + expect_equal( + r2_nagelkerke(model), + c(`Nagelkerke's R2` = 0.589959301837163), + tolerance = 1e-3 + ) + expect_equal( + r2(model), + list(R2_Tjur = c(`Tjur's R2` = 0.477692621360749)), + tolerance = 1e-3, + ignore_attr = TRUE + ) }) skip_if_not_installed("withr") @@ -13,7 +22,11 @@ test_that("r2_nagelkerke", { { data(housing, package = "MASS") model <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) - expect_equal(r2_nagelkerke(model), c(`Nagelkerke's R2` = 0.1084083), tolerance = 1e-3) + expect_equal( + r2_nagelkerke(model), + c(`Nagelkerke's R2` = 0.1084083), + tolerance = 1e-3 + ) } ) }) diff --git a/tests/testthat/test-r2_nakagawa.R b/tests/testthat/test-r2_nakagawa.R index 12ea23f00..a3312dc4e 100644 --- a/tests/testthat/test-r2_nakagawa.R +++ b/tests/testthat/test-r2_nakagawa.R @@ -37,47 +37,497 @@ test_that("r2_nakagawa, ci", { }) -dat <- structure(list( - y = structure( - c( - 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 1L, 2L, 1L, 1L, 2L, 2L, 1L, 2L, 2L, 2L, 1L, - 2L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 1L, 1L, 2L, 2L, 1L, 2L, 1L, 2L, - 2L, 1L, 1L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 1L, 1L, 1L, 1L +dat <- structure( + list( + y = structure( + c( + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 2L, + 1L, + 2L, + 2L, + 1L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 1L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 1L, + 1L, + 1L, + 1L, + 1L, + 1L, + 1L, + 1L, + 1L, + 1L, + 1L, + 2L, + 1L, + 1L, + 1L, + 1L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 1L, + 1L, + 1L, + 2L, + 2L, + 1L, + 2L, + 1L, + 2L, + 2L, + 1L, + 1L, + 1L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 1L, + 1L, + 1L, + 1L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 1L, + 1L + ), + .Label = c("0", "1"), + class = "factor" ), - .Label = c("0", "1"), class = "factor" - ), - x1 = structure( - c( - 2L, 1L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 1L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, - 1L, 2L, 1L, 2L, 1L, 1L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 1L, 1L, - 1L, 2L, 2L, 1L, 1L, 1L, 2L, 1L, 2L, 2L, 2L, 1L, 2L, 2L, 1L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, - 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 1L, 2L, 2L, 2L, 1L, 2L, 2L, 1L, 1L, 1L, 2L, 2L + x1 = structure( + c( + 2L, + 1L, + 2L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 1L, + 1L, + 1L, + 2L, + 1L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 1L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 1L, + 2L, + 1L, + 1L, + 1L, + 2L, + 2L, + 1L, + 1L, + 1L, + 2L, + 1L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 1L, + 1L, + 2L, + 2L, + 2L, + 1L, + 1L, + 1L, + 1L, + 1L, + 2L, + 1L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 1L, + 2L, + 2L, + 2L, + 1L, + 2L, + 2L, + 1L, + 1L, + 1L, + 2L, + 2L + ), + .Label = c("1", "2"), + class = "factor" ), - .Label = c("1", "2"), class = "factor" - ), - a1 = structure( - c( - 9L, 1L, 1L, 5L, 9L, 7L, 1L, 1L, 9L, 5L, 5L, 5L, 5L, 6L, 4L, 3L, 5L, 9L, 9L, 6L, 1L, 9L, 9L, 9L, 9L, 5L, 2L, 7L, 7L, 7L, 4L, - 5L, 7L, 4L, 2L, 9L, 2L, 2L, 9L, 9L, 5L, 5L, 7L, 5L, 9L, 8L, 8L, 8L, 8L, 3L, 9L, 5L, 6L, 6L, 3L, 9L, 6L, 9L, 6L, 3L, 5L, - 6L, 6L, 5L, 7L, 4L, 7L, 2L, 5L, 2L, 5L, 5L, 9L, 5L, 9L, 4L, 3L, 5L, 5L, 3L, 9L, 3L, 3L, 3L, 9L, 9L, 3L, 9L, 3L, 3L, 9L, - 8L, 3L, 9L, 7L, 9L, 9L, 6L, 2L, 9L, 9L, 4L, 9L, 7L, 5L, 5L, 5L, 5L, 5L, 5L + a1 = structure( + c( + 9L, + 1L, + 1L, + 5L, + 9L, + 7L, + 1L, + 1L, + 9L, + 5L, + 5L, + 5L, + 5L, + 6L, + 4L, + 3L, + 5L, + 9L, + 9L, + 6L, + 1L, + 9L, + 9L, + 9L, + 9L, + 5L, + 2L, + 7L, + 7L, + 7L, + 4L, + 5L, + 7L, + 4L, + 2L, + 9L, + 2L, + 2L, + 9L, + 9L, + 5L, + 5L, + 7L, + 5L, + 9L, + 8L, + 8L, + 8L, + 8L, + 3L, + 9L, + 5L, + 6L, + 6L, + 3L, + 9L, + 6L, + 9L, + 6L, + 3L, + 5L, + 6L, + 6L, + 5L, + 7L, + 4L, + 7L, + 2L, + 5L, + 2L, + 5L, + 5L, + 9L, + 5L, + 9L, + 4L, + 3L, + 5L, + 5L, + 3L, + 9L, + 3L, + 3L, + 3L, + 9L, + 9L, + 3L, + 9L, + 3L, + 3L, + 9L, + 8L, + 3L, + 9L, + 7L, + 9L, + 9L, + 6L, + 2L, + 9L, + 9L, + 4L, + 9L, + 7L, + 5L, + 5L, + 5L, + 5L, + 5L, + 5L + ), + .Label = c("1", "2", "3", "4", "5", "6", "7", "8", "9"), + class = "factor" ), - .Label = c("1", "2", "3", "4", "5", "6", "7", "8", "9"), class = "factor" + a2 = structure( + c( + 6L, + 6L, + 12L, + 12L, + 11L, + 11L, + 11L, + 14L, + 14L, + 14L, + 14L, + 14L, + 13L, + 1L, + 1L, + 13L, + 1L, + 14L, + 14L, + 14L, + 14L, + 14L, + 14L, + 14L, + 14L, + 12L, + 12L, + 12L, + 7L, + 9L, + 9L, + 9L, + 9L, + 9L, + 9L, + 9L, + 5L, + 5L, + 11L, + 7L, + 8L, + 1L, + 1L, + 12L, + 4L, + 11L, + 11L, + 11L, + 5L, + 5L, + 5L, + 2L, + 13L, + 2L, + 3L, + 3L, + 3L, + 3L, + 3L, + 3L, + 3L, + 4L, + 4L, + 4L, + 5L, + 5L, + 7L, + 7L, + 8L, + 8L, + 8L, + 9L, + 9L, + 9L, + 7L, + 7L, + 8L, + 8L, + 9L, + 10L, + 10L, + 10L, + 10L, + 1L, + 10L, + 1L, + 10L, + 13L, + 13L, + 6L, + 11L, + 11L, + 14L, + 2L, + 2L, + 2L, + 2L, + 6L, + 6L, + 6L, + 3L, + 3L, + 3L, + 13L, + 13L, + 13L, + 6L, + 6L, + 6L, + 4L + ), + .Label = c( + "01", + "02", + "03", + "04", + "05", + "06", + "07", + "08", + "09", + "10", + "11", + "12", + "13", + "14" + ), + class = "factor" + ) ), - a2 = structure( - c( - 6L, 6L, 12L, 12L, 11L, 11L, 11L, 14L, 14L, 14L, 14L, 14L, 13L, 1L, 1L, 13L, - 1L, 14L, 14L, 14L, 14L, 14L, 14L, 14L, 14L, 12L, 12L, 12L, 7L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 5L, 5L, 11L, 7L, 8L, 1L, - 1L, 12L, 4L, 11L, 11L, 11L, 5L, 5L, 5L, 2L, 13L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 5L, 5L, 7L, 7L, 8L, 8L, - 8L, 9L, 9L, 9L, 7L, 7L, 8L, 8L, 9L, 10L, 10L, 10L, 10L, 1L, 10L, 1L, 10L, 13L, 13L, 6L, 11L, 11L, 14L, 2L, 2L, 2L, 2L, - 6L, 6L, 6L, 3L, 3L, 3L, 13L, 13L, 13L, 6L, 6L, 6L, 4L - ), - .Label = c("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12", "13", "14"), class = "factor" - ) -), row.names = c(NA, -110L), class = "data.frame") + row.names = c(NA, -110L), + class = "data.frame" +) -model <- lme4::glmer(y ~ x1 + (1 | a1) + (1 | a2), family = binomial(link = "logit"), data = dat) +model <- lme4::glmer( + y ~ x1 + (1 | a1) + (1 | a2), + family = binomial(link = "logit"), + data = dat +) test_that("r2_nakagawa, by_group", { out <- r2_nakagawa(model, by_group = TRUE) diff --git a/tests/testthat/test-rmse.R b/tests/testthat/test-rmse.R index e19bd49b3..188b40b11 100644 --- a/tests/testthat/test-rmse.R +++ b/tests/testthat/test-rmse.R @@ -14,7 +14,11 @@ test_that("rmse", { cp <- compare_performance(m1.1, m1.2, m1.3, m2.1, m2.2, m2.3), "seem to be identical" ) - expect_equal(cp$RMSE, c(47.4489, 47.39881, 47.38701, 47.41375, 47.39979, 47.38705), tolerance = 1e-3) + expect_equal( + cp$RMSE, + c(47.4489, 47.39881, 47.38701, 47.41375, 47.39979, 47.38705), + tolerance = 1e-3 + ) }) test_that("rmse, ci", { diff --git a/tests/testthat/test-roc.R b/tests/testthat/test-roc.R index 7821a78bb..4ce854902 100644 --- a/tests/testthat/test-roc.R +++ b/tests/testthat/test-roc.R @@ -11,7 +11,11 @@ auc1 <- bayestestR::area_under_curve(roc1$Specificity, roc1$Sensitivity) auc2 <- bayestestR::area_under_curve(roc2$Specificity, roc2$Sensitivity) test_that("roc", { - expect_equal(head(roc1$Sensitivity), c(0, 0.07692, 0.15385, 0.23077, 0.30769, 0.38462), tolerance = 1e-2) + expect_equal( + head(roc1$Sensitivity), + c(0, 0.07692, 0.15385, 0.23077, 0.30769, 0.38462), + tolerance = 1e-2 + ) expect_equal(head(roc2$Sensitivity), c(0, 0, 0, 0, 0.00154, 0.00154), tolerance = 1e-2) }) diff --git a/tests/testthat/test-test_likelihoodratio.R b/tests/testthat/test-test_likelihoodratio.R index fa5467bf6..6b1652193 100644 --- a/tests/testthat/test-test_likelihoodratio.R +++ b/tests/testthat/test-test_likelihoodratio.R @@ -55,9 +55,18 @@ test_that("test_likelihoodratio - reversed order", { skip_on_cran() skip_if_not_installed("lme4") -m1 <- suppressMessages(lme4::lmer(Sepal.Length ~ Petal.Width + (1 | Species), data = iris)) -m2 <- suppressMessages(lme4::lmer(Sepal.Length ~ Petal.Width + Petal.Length + (1 | Species), data = iris)) -m3 <- suppressMessages(lme4::lmer(Sepal.Length ~ Petal.Width * Petal.Length + (1 | Species), data = iris)) +m1 <- suppressMessages(lme4::lmer( + Sepal.Length ~ Petal.Width + (1 | Species), + data = iris +)) +m2 <- suppressMessages(lme4::lmer( + Sepal.Length ~ Petal.Width + Petal.Length + (1 | Species), + data = iris +)) +m3 <- suppressMessages(lme4::lmer( + Sepal.Length ~ Petal.Width * Petal.Length + (1 | Species), + data = iris +)) test_that("test_likelihoodratio - lme4 ML", { t1 <- test_lrt(m1, m2, m3) diff --git a/tests/testthat/test-test_performance.R b/tests/testthat/test-test_performance.R index 5a99b1612..de5c0535c 100644 --- a/tests/testthat/test-test_performance.R +++ b/tests/testthat/test-test_performance.R @@ -19,7 +19,11 @@ test_that("test_performance - nested", { models <- list(Interaction = m1, NoInteraction = m2, SingleTerm = m3) rez <- test_performance(models) - expect_equal(rez$Name, c("Interaction", "NoInteraction", "SingleTerm"), ignore_attr = TRUE) + expect_equal( + rez$Name, + c("Interaction", "NoInteraction", "SingleTerm"), + ignore_attr = TRUE + ) # Increasing # TODO: Increasing order must be fixed and double checked, because the empty line should be the bottom one (?)