tests/testthat/test-cal-estimate-linear.R

In topepo/probably: Tools for Post-Processing Predicted Values

test_that("Linear estimates work - data.frame", {
  skip_if_not_installed("modeldata")

  sl_linear <- cal_estimate_linear(boosting_predictions_oob, outcome, smooth = FALSE)
  expect_cal_type(sl_linear, "regression")
  expect_cal_method(sl_linear, "Linear calibration")
  expect_cal_estimate(sl_linear, "butchered_glm")
  expect_cal_rows(sl_linear, 2000)
  expect_snapshot(print(sl_linear))

  sl_linear_group <- boosting_predictions_oob |>
    dplyr::mutate(group = .pred > 0.5) |>
    cal_estimate_linear(outcome, smooth = FALSE, .by = group)

  expect_cal_type(sl_linear_group, "regression")
  expect_cal_method(sl_linear_group, "Linear calibration")
  expect_cal_estimate(sl_linear_group, "butchered_glm")
  expect_cal_rows(sl_linear_group, 2000)
  expect_snapshot(print(sl_linear_group))

  expect_snapshot_error(
    boosting_predictions_oob |>
      dplyr::mutate(group1 = 1, group2 = 2) |>
      cal_estimate_linear(outcome, smooth = FALSE, .by = c(group1, group2))
  )

})

test_that("Linear estimates work - tune_results", {
  tl_linear <- cal_estimate_linear(testthat_cal_reg(), outcome, smooth = FALSE)
  expect_cal_type(tl_linear, "regression")
  expect_cal_method(tl_linear, "Linear calibration")
  expect_cal_estimate(tl_linear, "butchered_glm")
  expect_snapshot(print(tl_linear))

})

test_that("Linear estimates errors - grouped_df", {
  expect_snapshot_error(
    cal_estimate_linear(dplyr::group_by(mtcars, vs))
  )
})

# ----------------------------- Linear Spline --------------------------------
test_that("Linear spline estimates work - data.frame", {
  skip_if_not_installed("modeldata")

  sl_gam <- cal_estimate_linear(boosting_predictions_oob, outcome)
  expect_cal_type(sl_gam, "regression")
  expect_cal_method(sl_gam, "Generalized additive model calibration")
  expect_cal_estimate(sl_gam, "butchered_gam")
  expect_cal_rows(sl_gam, 2000)
  expect_snapshot(print(sl_gam))

  sl_gam_group <- boosting_predictions_oob |>
    dplyr::mutate(group = .pred > 0.5) |>
    cal_estimate_linear(outcome, .by = group)

  expect_cal_type(sl_gam_group, "regression")
  expect_cal_method(sl_gam_group, "Generalized additive model calibration")
  expect_cal_estimate(sl_gam_group, "butchered_gam")
  expect_cal_rows(sl_gam_group, 2000)
  expect_snapshot(print(sl_gam_group))

  expect_snapshot_error(
    boosting_predictions_oob |>
      dplyr::mutate(group1 = 1, group2 = 2) |>
      cal_estimate_linear(outcome, .by = c(group1, group2))
  )
})

test_that("Linear spline estimates work - tune_results", {
  tl_gam <- cal_estimate_linear(testthat_cal_reg(), outcome)
  expect_cal_type(tl_gam, "regression")
  expect_cal_method(tl_gam, "Generalized additive model calibration")
  expect_cal_estimate(tl_gam, "butchered_gam")
  expect_snapshot(print(tl_gam))

  expect_equal(
    testthat_cal_reg_count(),
    nrow(cal_apply(testthat_cal_reg(), tl_gam))
  )
})

test_that("Linear spline switches to linear if too few unique", {
  skip_if_not_installed("modeldata")

  boosting_predictions_oob$.pred <- rep(
    x = 1:5,
    length.out = nrow(boosting_predictions_oob)
  )

  expect_snapshot(
    sl_gam <- cal_estimate_linear(boosting_predictions_oob, outcome, smooth = TRUE)
  )
  sl_lm <- cal_estimate_linear(boosting_predictions_oob, outcome, smooth = FALSE)

  expect_identical(
    sl_gam$estimates,
    sl_lm$estimates
  )

  expect_snapshot(
    sl_gam <- cal_estimate_linear(boosting_predictions_oob, outcome, .by = id, smooth = TRUE)
  )
  sl_lm <- cal_estimate_linear(boosting_predictions_oob, outcome, .by = id, smooth = FALSE)

  expect_identical(
    sl_gam$estimates,
    sl_lm$estimates
  )
})

test_that("Linear spline switches to linear if too few unique", {
  skip_if_not_installed("modeldata")

  boosting_predictions_oob$.pred <- rep(
    x = 1:5,
    length.out = nrow(boosting_predictions_oob)
  )

  expect_snapshot(
    sl_gam <- cal_estimate_linear(boosting_predictions_oob, outcome, smooth = TRUE)
  )
  sl_lm <- cal_estimate_linear(boosting_predictions_oob, outcome, smooth = FALSE)

  expect_identical(
    sl_gam$estimate,
    sl_lm$estimate
  )

  expect_snapshot(
    sl_gam <- cal_estimate_linear(boosting_predictions_oob, outcome, .by = id, smooth = TRUE)
  )
  sl_lm <- cal_estimate_linear(boosting_predictions_oob, outcome, .by = id, smooth = FALSE)

  expect_identical(
    sl_gam$estimate,
    sl_lm$estimate
  )
})