tests/testthat/test-cifplot-printEachEvent.R

In cifmodeling: Visualization and Polytomous Modeling of Survival and Competing Risks

test_that("panel.per.event ignored for non-CR outcomes with warning", {
  skip_on_cran()
  data(diabetes.complications)
  diabetes.complications$status <- as.integer(diabetes.complications$epsilon > 0)
  expect_warning(
    {
      plt <- cifplot(
        survival::Surv(t, status) ~ fruitq1,
        data           = diabetes.complications,
        outcome.type   = "survival",
        add.risktable   = FALSE,
        panel.per.event = TRUE
      )
      expect_s3_class(plt, "cifplot")
      expect_s3_class(plt$plot, "ggplot")
    },
    "panel.per.event=TRUE is only for COMPETING-RISK"
  )
})

test_that("cifplot(panel.per.event=TRUE) returns a patchwork object", {
  skip_on_cran()
  data(diabetes.complications)
  plt <- cifplot(
    Event(t, epsilon) ~ fruitq1,
    data           = diabetes.complications,
    outcome.type   = "competing-risk",
    code.events    = c(1, 2, 0),
    add.risktable   = FALSE,
    panel.per.event = TRUE
  )
  expect_s3_class(plt, "cifpanel")
  expect_true(inherits(plt$patchwork, "patchwork"))
  expect_equal(length(plt$list.plot), 2L)
  expect_true(all(vapply(plt$list.plot, function(p) inherits(p, "ggplot"), logical(1))))
  expect_identical(
    vapply(plt$list.plot, function(p) p$labels$y %||% NA_character_, character(1)),
    c(
      "Cumulative incidence of interest",
      "Cumulative incidence of competing risk"
    )
  )
})

test_that("cifplot(panel.per.event=TRUE) returns two panels and passes y labels", {
  skip()
  data(diabetes.complications)
  plt <- cifplot(
    Event(t, epsilon) ~ fruitq1,
    data = diabetes.complications,
    outcome.type = "competing-risk",
    code.events = c(1, 2, 0),
    panel.per.event = TRUE,
    label.y = "Left axis"
  )

  expect_s3_class(plt, "cifpanel")
  expect_length(plt$list.plot, 2L)

  titles <- vapply(plt$list.plot, function(p) p$labels$title %||% NA_character_, character(1))
  expect_true(all(is.na(titles)))

  ylabels <- vapply(plt$list.plot, function(p) p$labels$y %||% NA_character_, character(1))
  expect_equal(ylabels, c("Left axis", "Left axis"))
})