Support for cch models

.github/workflows/R-CMD-check.yaml

@@ -41,7 +41,7 @@ jobs:
 
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: any::rcmdcheck, glmmTMB=?ignore
+          extra-packages: any::rcmdcheck, glmmTMB=?source, lme4=?source
           needs: check
 
       - uses: r-lib/actions/check-r-package@v2

NAMESPACE

@@ -6,6 +6,7 @@ S3method(model_get_assign,model_fit)
 S3method(model_get_assign,vglm)
 S3method(model_get_coefficients_type,LORgee)
 S3method(model_get_coefficients_type,biglm)
+S3method(model_get_coefficients_type,cch)
 S3method(model_get_coefficients_type,clm)
 S3method(model_get_coefficients_type,clmm)
 S3method(model_get_coefficients_type,clogit)
@@ -39,6 +40,7 @@ S3method(model_get_model_matrix,LORgee)
 S3method(model_get_model_matrix,betareg)
 S3method(model_get_model_matrix,biglm)
 S3method(model_get_model_matrix,brmsfit)
+S3method(model_get_model_matrix,cch)
 S3method(model_get_model_matrix,clm)
 S3method(model_get_model_matrix,default)
 S3method(model_get_model_matrix,fixest)
@@ -68,6 +70,7 @@ S3method(model_get_response,model_fit)
 S3method(model_get_response_variable,default)
 S3method(model_get_terms,betareg)
 S3method(model_get_terms,brmsfit)
+S3method(model_get_terms,cch)
 S3method(model_get_terms,default)
 S3method(model_get_terms,glmmTMB)
 S3method(model_get_terms,model_fit)

NEWS.md

@@ -3,6 +3,7 @@
 **New supported models**
 
 - Support for `mmrm::mmrm()` models (#228)
+- Support for `survival::cch()` models (#242)
 
 **New features**
 

R/custom_tidiers.R

@@ -79,6 +79,8 @@
 #' @export
 #' @family custom_tieders
 tidy_with_broom_or_parameters <- function(x, conf.int = TRUE, conf.level = .95, ...) {
+  exponentiate_later <- FALSE
+
   # load broom.mixed if available
   if (any(c("glmerMod", "lmerMod", "glmmTMB", "glmmadmb", "stanreg", "brmsfit") %in% class(x))) {
     .assert_package("broom.mixed", fn = "broom.helpers::tidy_with_broom_or_parameters()")
@@ -126,6 +128,16 @@
     }
   }
 
+  # specific case for cch models
+  # exponentiate and conf.int not supported by broom::tidy()
+  if (inherits(x, "cch")) {
+    if (isTRUE(tidy_args$exponentiate)) {
+      exponentiate_later <- TRUE
+    }
+    tidy_args$exponentiate <- NULL
+    tidy_args$conf.int <- NULL
+  }
+
   # for betareg, if exponentiate = TRUE, forcing tidy_parameters,
   # by adding `component = "all" to the arguments`
   if (inherits(x, "betareg")) {
@@ -210,6 +222,17 @@
       )
     }
   }
+
+  # cleaning in conf.int = FALSE
+  if (isFALSE(conf.int)) {
+    res <- res %>%
+      dplyr::select(-dplyr::any_of(c("conf.low", "conf.high")))
+  }
+
+  if (exponentiate_later) {
+    res <- .exponentiate(res)
+  }
+
   res
 }
 

R/helpers.R

@@ -53,3 +53,19 @@
   names(x) <- saved_names
   x
 }
+
+# copied from broom
+.exponentiate <- function (data, col = "estimate")
+{
+  data <- data %>%
+    dplyr::mutate(
+      dplyr::across(dplyr::all_of(col), exp)
+    )
+  if ("conf.low" %in% colnames(data)) {
+    data <- data %>%
+      dplyr::mutate(
+        dplyr::across(dplyr::any_of(c("conf.low", "conf.high")), exp)
+      )
+  }
+  data
+}

R/model_get_coefficients_type.R

@@ -146,6 +146,12 @@
   "prop_hazard"
 }
 
+#' @export
+#' @rdname model_get_coefficients_type
+model_get_coefficients_type.cch <- function(model) {
+  "prop_hazard"
+}
+
 #' @export
 #' @rdname model_get_coefficients_type
 model_get_coefficients_type.model_fit <- function(model) {

R/model_get_model_matrix.R

@@ -130,3 +130,12 @@
     data = model %>% model_get_model_frame()
   )
 }
+
+#' @export
+#' @rdname model_get_model_matrix
+model_get_model_matrix.cch <- function(model, ...) {
+  stats::model.matrix.default(
+    model$call$formula %>% stats::formula(),
+    data = model %>% model_get_model_frame()
+  )
+}

R/model_get_terms.R

@@ -55,3 +55,18 @@
 model_get_terms.betareg <- function(model) {
   model_get_terms(model$terms$full)
 }
+
+#' @export
+#' @rdname model_get_terms
+model_get_terms.betareg <- function(model) {
+  model_get_terms(model$terms$full)
+}
+
+#' @export
+#' @rdname model_get_model_matrix
+model_get_terms.cch <- function(model, ...) {
+  stats::terms.formula(
+    model$call$formula %>% stats::formula(),
+    data = model %>% model_get_model_frame()
+  )
+}

data-raw/DATASET.R

@@ -53,7 +53,8 @@ supported_models <-
     "`mmrm::mmrm()`", "",
     "`pscl::zeroinfl()`", "Use `tidy_zeroinfl()` as `tidy_fun`.",
     "`pscl::hurdle()`", "Use `tidy_zeroinfl()` as `tidy_fun`.",
-    "`betareg::betareg()`", "Use `tidy_parameters()` as `tidy_fun` with `component` argument to control with coefficients to return. `broom::tidy()` does not support the `exponentiate` argument for betareg models, use `tidy_parameters()` instead." # nolint
+    "`betareg::betareg()`", "Use `tidy_parameters()` as `tidy_fun` with `component` argument to control with coefficients to return. `broom::tidy()` does not support the `exponentiate` argument for betareg models, use `tidy_parameters()` instead.", # nolint
+    "`survival::cch()`", "`Experimental support."
   ) %>%
   dplyr::arrange(.data$model, .locale = "en")
 

tests/testthat/test-tidy_plus_plus.R

@@ -966,3 +966,6 @@ test_that("tidy_post_fun argument of `tidy_plus_plus()`", {
   )
   expect_equal(nrow(res), 2L)
 })
+
+# test for survival::cch() not working, model.frame() not working
+# in the test_that environment for this type of model