tests/testthat/test-expose.R

In actxps: Create Actuarial Experience Studies: Prepare Data, Summarize Results, and Create Reports

study_py <- expose_py(census_dat, "2019-12-31", target_status = "Surrender")
study_cy <- expose_cy(census_dat, "2019-12-31", target_status = "Surrender")

test_that("Policy year exposure checks", {
  expect_gt(min(study_py$exposure), 0)
  expect_lte(max(study_py$exposure), 1)
  expect_equal(sum(is.na(study_py$exposure)), 0)
  expect_true(all(study_py$exposure[study_py$status == "Surrender"] == 1))
})

test_that("Calendar year exposure checks", {
  expect_gt(min(study_cy$exposure), 0)
  expect_lte(max(study_cy$exposure), 1)
  expect_equal(sum(is.na(study_cy$exposure)), 0)
  expect_true(all(study_cy$exposure[study_cy$status == "Surrender"] == 1))

})


check_period_end_pol <- expose_pw(toy_census, "2020-12-31",
                                  target_status = "Surrender") |>
  select(pol_num, pol_date_wk, pol_date_wk_end) |>
  group_by(pol_num) |>
  mutate(x = dplyr::lead(pol_date_wk)) |>
  ungroup() |>
  na.omit() |>
  filter(x != pol_date_wk_end + 1) |>
  nrow()

check_period_end_cal <- expose_cm(toy_census, "2020-12-31",
                                  target_status = "Surrender") |>
  select(pol_num, cal_mth, cal_mth_end) |>
  group_by(pol_num) |>
  mutate(x = dplyr::lead(cal_mth)) |>
  ungroup() |>
  na.omit() |>
  filter(x != cal_mth_end + 1) |>
  nrow()

test_that("Period start and end dates roll", {
  expect_true(all(study_py$pol_date_yr < study_py$pol_date_yr_end))
  expect_true(all(study_cy$cal_yr < study_cy$cal_yr_end))
  expect_equal(check_period_end_pol, 0)
  expect_equal(check_period_end_cal, 0)
})

leap_day <- data.frame(pol_num = 1L,
                       status = 'Active',
                       issue_date = as.Date("2020-02-29"),
                       term_date = NA_character_)

leap_expose <- expose_pm(leap_day, end_date = "2021-02-28")



march_1 <- data.frame(pol_num = 1L,
                      status = 'Active',
                      issue_date = as.Date("2019-03-01"),
                      term_date = NA_character_)
march_1_expose <- expose_pm(march_1, end_date = "2020-02-29")


test_that("Test leap day stability.", {
  expect_equal(nrow(leap_expose), 12)
  expect_equal(nrow(march_1_expose), 12)
})


with_start_date <- expose_py(census_dat,
                             "2019-12-31",
                             start_date = "2018-12-31",
                             target_status = "Surrender")

test_that("Start and end dates work.", {
  expect_gte(min(with_start_date$pol_date_yr), as.Date("2018-12-31"))
  expect_lte(max(with_start_date$pol_date_yr), as.Date("2019-12-31"))
})

test_that("All terminations have termination dates", {
  expect_equal(sum(study_py$status != "Active"),
               sum(!is.na(study_py$term_date)))
  expect_equal(sum(study_cy$status != "Active"),
               sum(!is.na(study_cy$term_date)))
})

exposed_strings <- expose(toy_census, "2020-12-31", "2016-04-01")
exposed_dates <- expose(toy_census, as.Date("2020-12-31"),
                        as.Date("2016-04-01"))

test_that("Expose date arguments can be passed strings.", {
  expect_identical(exposed_strings, exposed_dates)
})

renamer <- c("pol_num" = "a",
             "status" = "b",
             "issue_date" = "c",
             "term_date" = "d")
toy_census2 <- toy_census |> dplyr::rename_with(\(x) renamer[x])

test_that("Renaming and name conflict warnings work", {
  expect_error(expose(toy_census2, "2020-12-31"))
  expect_no_error(expose(toy_census2, "2020-12-31",
                         col_pol_num = "a",
                         col_status = "b",
                         col_issue_date = "c",
                         col_term_date = "d"))
  expect_warning(expose(toy_census |> mutate(exposure = 1), "2020-12-31"))
  expect_warning(expose(toy_census |> mutate(pol_yr = 1), "2020-12-31"))
  expect_warning(expose(toy_census |> mutate(pol_date_yr = 1), "2020-12-31"))
  expect_warning(expose(toy_census |> mutate(pol_date_yr_end = 1), "2020-12-31"))
  expect_warning(expose_cy(toy_census |> mutate(cal_yr = 1), "2020-12-31"))
  expect_warning(expose_cy(toy_census |> mutate(cal_yr_end = 1), "2020-12-31"))
})

test_that("Date format checks work", {
  toy_census3 <- toy_census
  toy_census3$issue_date[[1]] <- NA
  expect_error(expose_py(toy_census3, "2020-12-31"),
               regexp = "Missing values are not allowed in the `issue_date`")
})

test_that("An error is thrown if the default status is a target status", {
  all_deaths <- dplyr::tribble(
    ~pol_num, ~status, ~issue_date, ~term_date,
    1, "Death", as.Date("2011-05-27"), as.Date("2012-03-17"),
    2, "Death", as.Date("2011-05-27"), as.Date("2012-09-17"))
  expect_error(all_deaths |>
    expose(end_date = "2022-12-31", target_status = c("Death", "Surrender")),
    regexp = "`default_status` is not allowed to be the same as `target_status"
  )
})

# split exposure tests

test_that("expose_split() fails when passed non-calendar exposures", {
  expect_error(expose_split(1, regexp = "must be an `exposed_df`"))
  expect_error(expose_py(toy_census, "2022-12-31") |> expose_split(),
               regexp = "must contain calendar exposures")
  expect_no_error(expose_cy(toy_census, "2022-12-31") |> expose_split())
})


study_split <- expose_split(study_cy) |> add_transactions(withdrawals)
study_cy <- add_transactions(study_cy, withdrawals)

py_sum_check <- function(py, split) {
  py_sums <- py |>
    dplyr::summarize(exposure = sum(exposure),
                     .by = c(pol_num, pol_yr))
  split_sums <- split |>
    dplyr::summarize(exposure_pol = sum(exposure_pol),
                     .by = c(pol_num, pol_yr))
  py_sums |> inner_join(split_sums, by = c("pol_num", "pol_yr"),
                        relationship = "one-to-one") |>
    filter(!dplyr::near(exposure, exposure_pol)) |>
    nrow()
}

test_that("expose_split() is consistent with expose_cy()", {
  expect_equal(sum(study_cy$exposure), sum(study_split$exposure_cal))
  expect_equal(sum(study_cy$status != "Active"),
               sum(study_split$status != "Active"))
  expect_equal(sum(study_cy$trx_amt_Base),
               sum(study_split$trx_amt_Base))
  expect_equal(sum(study_cy$trx_amt_Rider),
               sum(study_split$trx_amt_Rider))
  expect_true(all(between(study_split$exposure_cal, 0, 1)))
  expect_true(all(between(study_split$exposure_pol, 0, 1)))
  expect_equal(py_sum_check(study_py, study_split), 0)

})

study_py2 <- expose_py(census_dat, "2019-02-27", target_status = "Surrender",
                       start_date = "2010-06-15")
study_cy2 <- expose_cq(census_dat, "2019-02-27", target_status = "Surrender",
                       start_date = "2010-06-15")
study_split2 <- expose_split(study_cy2)

test_that(
  paste0("expose_split() is consistent with expose_cy() when using ",
         "atypical start and end dates"),
  {
    expect_equal(sum(study_cy2$exposure), sum(study_split2$exposure_cal))
    expect_equal(sum(study_cy2$status != "Active"),
                 sum(study_split2$status != "Active"))
    expect_true(all(between(study_split2$exposure_cal, 0, 1)))
    expect_true(all(between(study_split2$exposure_pol, 0, 1)))
    expect_equal(py_sum_check(study_py2, study_split2), 0)
  })

# odd census
odd_census <- dplyr::tribble(
  ~pol_num, ~status, ~issue_date, ~term_date,
  # death in first month
  "D1", "Death", "2022-04-15", "2022-04-25",
  # death in first year
  "D2", "Death", "2022-04-15", "2022-09-25",
  # death after 18 months
  "D3", "Death", "2022-04-15", "2023-09-25",
  # surrender in first month
  "S1", "Surrender", "2022-11-10", "2022-11-20",
  # surrender in first year
  "S2", "Surrender", "2022-11-10", "2023-3-20",
  # surrender after 18 months
  "S3", "Surrender", "2022-11-10", "2024-3-20",
  # active
  "A", "Active", "2022-6-20", NA
)

odd_study <- expose_cm(odd_census, "2024-05-19", target_status = "Surrender",
                       default_status = "Active", start_date = "2022-04-10")
odd_py <- expose_py(odd_census, "2024-05-19", target_status = "Surrender",
                    default_status = "Active", start_date = "2022-04-10")
odd_split <- expose_split(odd_study)

test_that("expose_split() checks with odd dates", {
  expect_equal(sum(odd_study$exposure), sum(odd_split$exposure_cal))
  expect_equal(sum(odd_study$status != "Active"),
               sum(odd_split$status != "Active"))
  expect_true(all(between(odd_split$exposure_cal, 0, 1)))
  expect_true(all(between(odd_split$exposure_pol, 0, 1)))
  expect_equal(odd_py |> dplyr::pull(exposure) |> sum(),
               odd_split |> dplyr::pull(exposure_pol) |> sum())
})

test_that("expose_split() warns about transactions attached too early", {
  expect_warning(
    expose_split(study_cy),
    regexp = "This will lead to duplication of transactions")
})

test_that("split exposures error when passed to summary functions without clarifying the exposure basis", {
  expect_error(exp_stats(study_split),
               regexp = "A `split_exposed_df` was passed without clarifying")
  expect_error(trx_stats(study_split),
               regexp = "A `split_exposed_df` was passed without clarifying")
})

check_period_end_split <- expose_cy(toy_census, "2020-12-31",
                                    target_status = "Surrender") |>
  expose_split() |>
  select(pol_num, cal_yr, cal_yr_end) |>
  group_by(pol_num) |>
  mutate(x = dplyr::lead(cal_yr)) |>
  ungroup() |>
  na.omit() |>
  filter(x != cal_yr_end + 1) |>
  nrow()

test_that("Split period start and end dates roll", {
  expect_true(all(study_split$cal_yr <= study_split$cal_yr_end))
  expect_equal(check_period_end_split, 0)
})