Add tests for survival models

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: modelbased
 Title: Estimation of Model-Based Predictions, Contrasts and Means
-Version: 0.11.1.1
+Version: 0.11.1.2
 Authors@R:
     c(person(given = "Dominique",
              family = "Makowski",
@@ -39,7 +39,7 @@ BugReports: https://github.com/easystats/modelbased/issues
 Depends:
     R (>= 3.6)
 Imports:
-    bayestestR (>= 0.15.3),
+    bayestestR (>= 0.16.0),
     datawizard (>= 1.0.2),
     insight (>= 1.3.0),
     parameters (>= 0.25.0),
@@ -91,6 +91,7 @@ Suggests:
     RWiener,
     sandwich,
     see (>= 0.11.0),
+    survival,
     testthat (>= 3.2.1),
     vdiffr,
     withr

R/format.R

@@ -41,18 +41,18 @@
   }
 
   # arrange columns (not for contrast now)
   by <- rev(attr(x, "focal_terms", exact = TRUE))
   # add "Level" columns from contrasts
   if (all(c("Level1", "Level2") %in% colnames(x))) {
     by <- unique(by, c("Level1", "Level2"))
   }
   # add "group" columns from multivariate models
   if ("group" %in% colnames(x)) {
     by <- unique("group", by)
   }
   # check which columns actually exist
   if (!is.null(by)) {
     by <- intersect(by, colnames(x))
   }
   # sort
   if (length(by)) {
@@ -207,9 +207,9 @@
 
 
 #' @export
 format.marginaleffects_contrasts <- function(x, model = NULL, p_adjust = NULL, comparison = NULL, ...) {
   predict <- attributes(x)$predict
   by <- attributes(x)$by
   contrast <- attributes(x)$contrast
   contrast_filter <- attributes(x)$contrast_filter
   focal_terms <- attributes(x)$focal_terms
@@ -268,13 +268,13 @@
     # If we have, for example, `contrast = c("vs", "am"), by = "gear='5'"`, the
     # `by` column is the one with one unique value only, we thus have to update
     # `by`, and also `contrast` (the latter not(!) for numerics)...
     by <- by[lengths(lapply(dgrid[by], unique)) > 1]
 
     # for slopes, we have our "levels" in the by-variable, because `by` indicates
     # the levels for which slopes are contrasted - thus, we replace contrast with by
     if (inherits(x, "estimate_slopes")) {
       contrast <- by
       by <- NULL
     }
 
     # for contrasts, we also filter variables with one unique value, but we
@@ -285,7 +285,7 @@
     contrast <- contrast[keep_contrasts]
 
     # set to NULL, if all by-values have been removed here
     if (!length(by)) by <- NULL
 
     # if we have no contrasts left, e.g. due to `contrast = "time = factor(2)"`,
     # we error here - we have no contrasts to show
@@ -661,6 +661,8 @@
     estimate_name <- tools::toTitleCase(predict_type)
   } else if (!predict_type %in% c("none", "link") && (info$is_binomial || info$is_bernoulli)) {
     estimate_name <- "Probability"
+  } else if (predict_type == "survival" && info$is_survival) {
+    estimate_name <- "Probability"
   } else if (predict_type %in% c("zprob", "zero")) {
     estimate_name <- "Probability"
   } else if (predict_type %in% c("response", "invlink(link)") && (info$is_beta || info$is_orderedbeta)) {

tests/testthat/test-estimate_means.R

@@ -464,3 +464,40 @@ test_that("estimate_means, error on invalid type", {
     regex = "The option provided"
   )
 })
+
+
+test_that("estimate_means, coxph-survival", {
+  skip_if_not_installed("survival")
+  model <- survival::coxph(
+    survival::Surv(dtime, death) ~ hormon + age + I(age^2),
+    data = survival::rotterdam
+  )
+  emm <- estimate_means(
+    model,
+    c("dtime=c(1000, 2000, 3000, 4000)", "hormon"),
+    predict = "survival"
+  )
+  expect_named(
+    emm,
+    c("dtime", "hormon", "Probability", "SE", "CI_low", "CI_high", "z")
+  )
+  expect_equal(
+    emm$Probability,
+    c(0.8982, 0.86121, 0.7775, 0.70451, 0.68016, 0.58485, 0.58174, 0.47051),
+    tolerance = 1e-4
+  )
+  emm <- estimate_means(
+    model,
+    "hormon",
+    predict = "risk"
+  )
+  expect_named(
+    emm,
+    c("hormon", "Mean", "SE", "CI_low", "CI_high", "z")
+  )
+  expect_equal(
+    emm$Mean,
+    c(0.82661, 1.15039),
+    tolerance = 1e-4
+  )
+})