Draft R2 Ferrari

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",

NAMESPACE

@@ -145,7 +145,6 @@ S3method(display,check_itemscale)
 S3method(display,compare_performance)
 S3method(display,performance_model)
 S3method(display,test_performance)
-S3method(fitted,BFBayesFactor)
 S3method(format,compare_performance)
 S3method(format,performance_model)
 S3method(format,performance_rmse)
@@ -453,6 +452,7 @@ S3method(r2_coxsnell,survreg)
 S3method(r2_coxsnell,svycoxph)
 S3method(r2_coxsnell,truncreg)
 S3method(r2_efron,default)
+S3method(r2_ferrari,default)
 S3method(r2_kullback,default)
 S3method(r2_kullback,glm)
 S3method(r2_loo_posterior,BFBayesFactor)
@@ -567,6 +567,7 @@ export(check_zeroinflation)
 export(compare_performance)
 export(cronbachs_alpha)
 export(display)
+export(fitted.BFBayesFactor)
 export(icc)
 export(item_difficulty)
 export(item_discrimination)
@@ -599,6 +600,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)

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

R/r2_ferarri.R

@@ -0,0 +1,49 @@
+#' @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)"]
+
+  # 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(m)
+
+  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)
+}

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

tests/testthat/test-r2_ferrari.R

@@ -0,0 +1,7 @@
+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)
+})