# standard formula for testing f <- deaths ~ gender + age_group + year test_that("Error checks trigger", { expect_error(rpart_exposure(data = 1), regexp = "`data` must be a data frame") expect_error(rpart_exposure(deaths ~ age_group, data = us_deaths, exposure_col = "x"), regexp = "A column named `x` must be present") expect_error(rpart_exposure(cbind(deaths, population) ~ age_group, data = us_deaths, exposure_col = "population"), regexp = "The left-hand side of `formula`") }) rpart_base <- rpart::rpart( cbind(population, deaths) ~ gender + age_group + year, data = us_deaths, method = 'poisson', cp = 0.01) rpart_expo <- rpart_exposure(f, exposure_col = "population", data = us_deaths, cp = 0.01) test_that("rpart_exposure() model works", { expect_identical(predict(rpart_base), predict(rpart_expo)) }) test_that("control and ... return identical results", { rpart_expo_ctrl <- rpart_exposure( f, exposure_col = "population", data = us_deaths, control = rpart::rpart.control(cp = 0.001, maxdepth = 3, minsplit = 4)) rpart_expo_dots <- rpart_exposure(f, exposure_col = "population", data = us_deaths, cp = 0.001, maxdepth = 3, minsplit = 4) expect_identical(predict(rpart_expo_ctrl), predict(rpart_expo_dots)) }) test_that("weights and costs work", { rpart_wt <- rpart_exposure(f, exposure_col = "population", data = us_deaths, cp = 0.01, weights = us_deaths$population) expect_false(identical(predict(rpart_expo), predict(rpart_wt))) rpart_costs <- rpart_exposure(f, exposure_col = "population", data = us_deaths, cp = 0.01, cost = c(1, 100, 1)) expect_false(identical(predict(rpart_expo), predict(rpart_costs))) }) test_that("decision_tree_exposure() works", { # rpart_exposure rpart_expo <- decision_tree_exposure() |> set_engine("rpart_exposure", exposure_col = "population") |> fit(f, data = us_deaths) expect_identical(predict(rpart_base) |> unname(), predict(rpart_expo, us_deaths)$.pred) expect_identical(predict(rpart_base), predict(rpart_expo, us_deaths, type = "raw")) }) rec <- recipes::recipe(deaths ~ gender + age_group + year + population, data = us_deaths) |> recipes::step_rename(exposure = population) test_that("decision_tree_exposure() works with recipes", { # rpart_exposure rpart_expo <- workflows::workflow() |> workflows::add_recipe(rec) |> workflows::add_model(decision_tree_exposure() |> set_engine("rpart_exposure")) |> fit(data = us_deaths) expect_identical(predict(rpart_base) |> unname(), predict(rpart_expo, us_deaths)$.pred) }) test_that("finalize works", { mod_spec <- decision_tree_exposure(cost_complexity = tune(), tree_depth = tune(), min_n = tune()) |> set_engine("rpart_exposure") wf <- workflows::workflow() |> workflows::add_model(mod_spec) |> workflows::add_recipe(rec) param_grid <- data.frame(cost_complexity = 0.001, tree_depth = 25, min_n = 5) expect_no_error(tune::finalize_workflow(wf, param_grid) |> fit(us_deaths)) expect_equal(tune::finalize_model(mod_spec, param_grid)$args |> lapply(rlang::eval_tidy), as.list(param_grid)) })