From b68e32f9907aa03e6a3b8a2dfbcef4bd5c19ecad Mon Sep 17 00:00:00 2001 From: Daniel Date: Sat, 6 Jul 2024 21:24:50 +0200 Subject: [PATCH] Draft R2 Ferrari (#743) --- DESCRIPTION | 2 +- NAMESPACE | 3 ++ NEWS.md | 3 ++ R/r2.R | 3 ++ R/r2_ferarri.R | 64 ++++++++++++++++++++++++++++++++ R/r2_mcfadden.R | 7 ++-- inst/WORDLIST | 3 ++ man/r2_ferrari.Rd | 34 +++++++++++++++++ tests/testthat/test-r2_ferrari.R | 21 +++++++++++ 9 files changed, 136 insertions(+), 4 deletions(-) create mode 100644 R/r2_ferarri.R create mode 100644 man/r2_ferrari.Rd create mode 100644 tests/testthat/test-r2_ferrari.R diff --git a/DESCRIPTION b/DESCRIPTION index 1b7413974..581dc9f23 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: performance Title: Assessment of Regression Models Performance -Version: 0.12.0.5 +Version: 0.12.0.6 Authors@R: c(person(given = "Daniel", family = "Lüdecke", diff --git a/NAMESPACE b/NAMESPACE index c46c53cc6..1635d5793 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -453,6 +453,8 @@ S3method(r2_coxsnell,survreg) S3method(r2_coxsnell,svycoxph) S3method(r2_coxsnell,truncreg) S3method(r2_efron,default) +S3method(r2_ferrari,default) +S3method(r2_ferrari,glmmTMB) S3method(r2_kullback,default) S3method(r2_kullback,glm) S3method(r2_loo_posterior,BFBayesFactor) @@ -599,6 +601,7 @@ export(r2) export(r2_bayes) export(r2_coxsnell) export(r2_efron) +export(r2_ferrari) export(r2_kullback) export(r2_loo) export(r2_loo_posterior) diff --git a/NEWS.md b/NEWS.md index 775d2d7be..14f4c4e3c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -18,6 +18,9 @@ bootstrapped confidence intervals. The function gains following new arguments: `ci`, `ci_method` and `iterations`. +* New function `r2_ferrari()` to compute Ferrari & Cribari-Neto's R2 for + generalized linear models, in particular beta-regression. + # performance 0.12.0 ## Breaking diff --git a/R/r2.R b/R/r2.R index 94982b401..6f9d6b505 100644 --- a/R/r2.R +++ b/R/r2.R @@ -527,6 +527,9 @@ r2.glmmTMB <- function(model, ci = NULL, tolerance = 1e-5, verbose = TRUE, ...) } else if (info$is_zero_inflated) { # zero-inflated models use the default method out <- r2_zeroinflated(model) + } else if (info$is_beta) { + # beta-regression + out <- r2_ferrari(model) } else { insight::format_error("`r2()` does not support models of class `glmmTMB` without random effects and this link-function.") # nolint } diff --git a/R/r2_ferarri.R b/R/r2_ferarri.R new file mode 100644 index 000000000..cf6097591 --- /dev/null +++ b/R/r2_ferarri.R @@ -0,0 +1,64 @@ +#' @title Ferrari's and Cribari-Neto's R2 +#' @name r2_ferrari +#' +#' @description Calculates Ferrari's and Cribari-Neto's pseudo R2 (for +#' beta-regression models). +#' +#' @param model Generalized linear, in particular beta-regression model. +#' @param ... Currently not used. +#' +#' @return A list with the pseudo R2 value. +#' +#' @references +#' - Ferrari, S., and Cribari-Neto, F. (2004). Beta Regression for Modelling Rates +#' and Proportions. Journal of Applied Statistics, 31(7), 799–815. +#' \doi{10.1080/0266476042000214501} +#' +#' @examplesIf require("betareg") +#' data("GasolineYield", package = "betareg") +#' model <- betareg::betareg(yield ~ batch + temp, data = GasolineYield) +#' r2_ferrari(model) +#' @export +r2_ferrari <- function(model, ...) { + UseMethod("r2_ferrari") +} + +#' @export +r2_ferrari.default <- function(model, ...) { + # coefficients, but remove phi parameter + x <- stats::coef(model) + x <- x[names(x) != "(phi)"] + .r2_ferrari(model, x) +} + +#' @export +r2_ferrari.glmmTMB <- function(model, ...) { + insight::check_if_installed("lme4") + # coefficients, but remove phi parameter + x <- .collapse_cond(lme4::fixef(model)) + x <- x[names(x) != "(phi)"] + .r2_ferrari(model, x) +} + + +# helper ----------------------------- + +.r2_ferrari <- function(model, x) { + # model matrix, check dimensions / length + mm <- insight::get_modelmatrix(model) + + if (length(x) != ncol(mm)) { + insight::format_warning("Model matrix and coefficients do not match.") + return(NULL) + } + + # linear predictor for the mean + eta <- as.vector(x %*% t(mm)) + y <- insight::get_response(model) + + ferrari <- stats::cor(eta, insight::link_function(model)(y))^2 + out <- list(R2 = c(`Ferrari's R2` = ferrari)) + + attr(out, "model_type") <- "Generalized Linear" + structure(class = "r2_generic", out) +} diff --git a/R/r2_mcfadden.R b/R/r2_mcfadden.R index b04977517..de61fac87 100644 --- a/R/r2_mcfadden.R +++ b/R/r2_mcfadden.R @@ -63,15 +63,16 @@ r2_mcfadden.glm <- function(model, verbose = TRUE, ...) { if (is.null(info)) { info <- suppressWarnings(insight::model_info(model, verbose = FALSE)) } + 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.") } return(NULL) - } else { - l_null <- insight::get_loglikelihood(stats::update(model, ~1)) - .r2_mcfadden(model, l_null) } + + l_null <- insight::get_loglikelihood(stats::update(model, ~1)) + .r2_mcfadden(model, l_null) } #' @export diff --git a/inst/WORDLIST b/inst/WORDLIST index f0e335ab1..e5e90d844 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -39,6 +39,7 @@ Chisq CochransQ CompQuadForm Concurvity +Cribari Cronbach's Crujeiras Csaki @@ -154,6 +155,8 @@ Nagelkerke Nagelkerke's Nakagawa Nakagawa's +Neto +Neto's Nondegenerate Nordhausen Normed diff --git a/man/r2_ferrari.Rd b/man/r2_ferrari.Rd new file mode 100644 index 000000000..43dcda19a --- /dev/null +++ b/man/r2_ferrari.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/r2_ferarri.R +\name{r2_ferrari} +\alias{r2_ferrari} +\title{Ferrari's and Cribari-Neto's R2} +\usage{ +r2_ferrari(model, ...) +} +\arguments{ +\item{model}{Generalized linear, in particular beta-regression model.} + +\item{...}{Currently not used.} +} +\value{ +A list with the pseudo R2 value. +} +\description{ +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} +data("GasolineYield", package = "betareg") +model <- betareg::betareg(yield ~ batch + temp, data = GasolineYield) +r2_ferrari(model) +\dontshow{\}) # examplesIf} +} +\references{ +\itemize{ +\item Ferrari, S., and Cribari-Neto, F. (2004). Beta Regression for Modelling Rates +and Proportions. Journal of Applied Statistics, 31(7), 799–815. +\doi{10.1080/0266476042000214501} +} +} diff --git a/tests/testthat/test-r2_ferrari.R b/tests/testthat/test-r2_ferrari.R new file mode 100644 index 000000000..6e666d60a --- /dev/null +++ b/tests/testthat/test-r2_ferrari.R @@ -0,0 +1,21 @@ +test_that("r2_ferarri", { + skip_if_not_installed("betareg") + 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) +}) + + +test_that("r2_ferarri", { + skip_if_not_installed("betareg") + skip_if_not_installed("glmmTMB") + data("GasolineYield", package = "betareg") + model <- glmmTMB::glmmTMB( + yield ~ batch + temp, + data = GasolineYield, + family = glmmTMB::beta_family() + ) + out <- r2_ferrari(model) + expect_equal(out$R2, c(`Ferrari's R2` = 0.96173), tolerance = 1e-3, ignore_attr = TRUE) +})