test_predict.R
In flexsurv: Flexible Parametric Survival and Multi-State Models

test_that('survival predictions', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")

  # Single time predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'survival', t = 500)
  p <- predict(fitw, ovarian, type = 'survival', times = 500)
  expect_equal(s$est, p$.pred_survival)

  # Multiple time predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'survival', t = c(500, 1000))
  p <- predict(fitw, ovarian, type = 'survival', times = c(500, 1000))
  expect_equal(s$est, tidyr::unnest(p, .pred)$.pred_survival)
})

test_that('hazard predictions', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")

  # Single time predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'hazard', t = 500)
  p <- predict(fitw, ovarian, type = 'hazard', times = 500)
  expect_equal(s$est, p$.pred_hazard)

  # Multiple time predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'hazard', t = c(500, 1000))
  p <- predict(fitw, ovarian, type = 'hazard', times = c(500, 1000))
  expect_equal(s$est, tidyr::unnest(p, .pred)$.pred_hazard)
})

test_that('cumhaz predictions', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")

  # Single time predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'cumhaz', t = 500)
  p <- predict(fitw, ovarian, type = 'cumhaz', times = 500)
  expect_equal(s$est, p$.pred_cumhaz)

  # Multiple time predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'cumhaz', t = c(500, 1000))
  p <- predict(fitw, ovarian, type = 'cumhaz', times = c(500, 1000))
  expect_equal(s$est, tidyr::unnest(p, .pred)$.pred_cumhaz)
})

test_that('rmst predictions', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")

  # Single time predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'rmst', t = 500)
  p <- predict(fitw, ovarian, type = 'rmst', times = 500)
  expect_equal(s$est, p$.pred_rmst)

  # Multiple time predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'rmst',
               t = c(500, 1000))
  p <- predict(fitw, ovarian, type = 'rmst', times = c(500, 1000))
  expect_equal(s$est, tidyr::unnest(p, .pred)$.pred_rmst)
})

test_that('response/mean predictions', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'mean')
  p <- predict(fitw, ovarian, type = 'response')
  expect_equal(s$est, p$.pred_time)

  p <- predict(fitw, ovarian, type = 'mean')
  expect_equal(s$est, p$.pred_time)
})

test_that('quantile predictions', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")

  # Single quantile predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'quantile', t = 500,
               quantiles = c(0.5))
  p <- predict(fitw, ovarian, type = 'quantile', times = 500,
               p = c(0.5))
  expect_equal(s$est, p$.pred_quantile)

  # Multiple quantiles predictions
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'quantile',
               quantile = c(0.1, 0.9))
  p <- predict(fitw, ovarian, type = 'quantile', p = c(0.1, 0.9))
  expect_equal(s$est, tidyr::unnest(p, .pred)$.pred_quantile)
})

test_that('link predictions', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")
  s <- summary(fitw, ovarian, tidy = TRUE, type = 'link')
  p <- predict(fitw, ovarian, type = 'link')
  expect_equal(s$est, p$.pred_link)

  p <- predict(fitw, ovarian, type = 'linear')
  expect_equal(s$est, p$.pred_link)

  p <- predict(fitw, ovarian, type = 'lp')
  expect_equal(s$est, p$.pred_link)
})

test_that('test order (of age) stays the same', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")
  s <- summary(fitw, newdata = ovarian, type = 'survival', t = 500, tidy = TRUE)
  expect_equal(ovarian$age, s$age)
})

test_that('predictions with missing data (gengamma)', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "gengamma")
  ovarian_miss <- ovarian
  ovarian_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = ovarian_miss, type = 'mean')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'link')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = ovarian_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(ovarian_miss))
})

test_that('predictions with missing data (genf)', {
  # Use cancer data because genf is non-identifiable with ovarian data
  fitw <- flexsurvreg(Surv(time, status) ~ age,
                      data = cancer, dist = "genf")
  cancer_miss <- cancer
  cancer_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = cancer_miss, type = 'mean')
  expect_equal(nrow(p), nrow(cancer_miss))

  p <- predict(fitw, newdata = cancer_miss, type = 'link')
  expect_equal(nrow(p), nrow(cancer_miss))

  p <- predict(fitw, newdata = cancer_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(cancer_miss))

  p <- predict(fitw, newdata = cancer_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(cancer_miss))

  p <- predict(fitw, newdata = cancer_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(cancer_miss))

  p <- predict(fitw, newdata = cancer_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(cancer_miss))

  p <- predict(fitw, newdata = cancer_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(cancer_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = cancer_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(cancer_miss))
})

test_that('predictions with missing data (weibull)', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "weibull")
  ovarian_miss <- ovarian
  ovarian_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = ovarian_miss, type = 'mean')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'link')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = ovarian_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(ovarian_miss))
})

test_that('predictions with missing data (gamma)', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "gamma")
  ovarian_miss <- ovarian
  ovarian_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = ovarian_miss, type = 'mean')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'link')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = ovarian_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(ovarian_miss))
})

test_that('predictions with missing data (exponential)', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "exp")
  ovarian_miss <- ovarian
  ovarian_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = ovarian_miss, type = 'mean')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'link')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = ovarian_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(ovarian_miss))
})

test_that('predictions with missing data (llogis)', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "llogis")
  ovarian_miss <- ovarian
  ovarian_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = ovarian_miss, type = 'mean')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'link')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = ovarian_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(ovarian_miss))
})

test_that('predictions with missing data (lnorm)', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "lnorm")
  ovarian_miss <- ovarian
  ovarian_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = ovarian_miss, type = 'mean')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'link')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = ovarian_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(ovarian_miss))
})

test_that('predictions with missing data (gompertz)', {
  fitw <- flexsurvreg(Surv(futime, fustat) ~ age,
                      data = ovarian, dist = "gompertz")
  ovarian_miss <- ovarian
  ovarian_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = ovarian_miss, type = 'mean')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'link')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = ovarian_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(ovarian_miss))
})

test_that('predictions with missing data (spline)', {
  fitw <- flexsurvspline(Surv(futime, fustat) ~ age, data = ovarian, k = 3)
  ovarian_miss <- ovarian
  ovarian_miss$age[[5]] <- NA

  # Single predictions
  p <- predict(fitw, newdata = ovarian_miss, type = 'mean')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'link')
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'rmst', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'quantile', p = 0.5)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'hazard', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'cumhaz', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  p <- predict(fitw, newdata = ovarian_miss, type = 'survival', times = 500)
  expect_equal(nrow(p), nrow(ovarian_miss))

  # Multiple predictions
  p <- predict(fitw, newdata = ovarian_miss,
               type = 'survival', times = c(500, 1000))
  expect_equal(nrow(p), nrow(ovarian_miss))
})