From 202b3409498c2747a13f92716e05bf900f8e7df2 Mon Sep 17 00:00:00 2001
From: Daniel <mail@danielluedecke.de>
Date: Sat, 6 Jul 2024 11:30:15 +0200
Subject: [PATCH] add for glmmTMB

---
 NAMESPACE                        |  1 +
 R/r2.R                           |  3 +++
 R/r2_ferarri.R                   | 17 ++++++++++++++++-
 tests/testthat/test-r2_ferrari.R | 14 ++++++++++++++
 4 files changed, 34 insertions(+), 1 deletion(-)

diff --git a/NAMESPACE b/NAMESPACE
index 4dbc2eb02..fbec2c8e3 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -453,6 +453,7 @@ 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)
diff --git a/R/r2.R b/R/r2.R
index 94982b401..c34c016c6 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_ferarri(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
index e53bbf213..cf6097591 100644
--- a/R/r2_ferarri.R
+++ b/R/r2_ferarri.R
@@ -28,7 +28,22 @@ 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)
 
@@ -39,7 +54,7 @@ r2_ferrari.default <- function(model, ...) {
 
   # linear predictor for the mean
   eta <- as.vector(x %*% t(mm))
-  y <- insight::get_response(m)
+  y <- insight::get_response(model)
 
   ferrari <- stats::cor(eta, insight::link_function(model)(y))^2
   out <- list(R2 = c(`Ferrari's R2` = ferrari))
diff --git a/tests/testthat/test-r2_ferrari.R b/tests/testthat/test-r2_ferrari.R
index de23aa3ba..6e666d60a 100644
--- a/tests/testthat/test-r2_ferrari.R
+++ b/tests/testthat/test-r2_ferrari.R
@@ -5,3 +5,17 @@ test_that("r2_ferarri", {
   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)
+})