tests/testthat/test-HouseholdMember.R

In R4GoodPersonalFinances: Make Optimal Financial Decisions

test_that("setting birth date", {

  test_birth_date <- "1980-07-15"
  
  member <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )
  
  expect_true(
    inherits(member, "HouseholdMember")
  )
  
  expect_true(
    inherits(member$get_birth_date(), "Date")
  )
  
  expect_equal(
    as.character(member$get_birth_date()), 
    test_birth_date
  )

  expect_equal(
    member$get_name(),
    "test_name"
  )
})

test_that("setting max age", {
  
  test_birth_date <- "1980-07-15"
  test_max_age    <- 120

  members <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )
  expect_equal(members$max_age, 100)

  members$max_age <- test_max_age
  expect_equal(
    members$max_age,
    test_max_age
  )
})

test_that("calculating age", {

  test_birth_date   <- "1980-07-15"
  test_current_date <- 
    c("2020-07-15", "2025-01-01", "2080-07-15", 
      "2080-07-16", "2081-07-11", "2081-07-18")

  members <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )
  expect_equal(members$max_age, 100)
  
  expect_snapshot_value(
    style = "json2",
    members$calc_age(current_date = test_current_date)
  )
})

test_that("calculating max lifespan", {
  
  test_birth_date   <- "1980-07-15"
  test_current_date <- 
    c("2020-07-15", "2025-01-01", "2080-07-15", "2080-07-16")
  
  members <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )

  expect_snapshot_value(
    style = "json2",
    members$get_lifespan(current_date = test_current_date)
  )
})

test_that("setting gompertz parameters", {
  
  test_birth_date   <- "1980-07-15"
  test_current_date <- "2020-07-15"
  
  members <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )
  expect_null(members$mode)
  expect_null(members$dispersion)

  members$mode <- 88
  expect_equal(members$mode, 88)

  members$dispersion <- 10
  expect_equal(members$dispersion, 10)
})

test_that("calculating gompertz survival probability", {

  test_birth_date   <- "1955-07-15"
  test_current_date <- "2020-07-15"
  
  members <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )
  members$mode       <- 80
  members$dispersion <- 10
  
  expect_equal(
    members$calc_survival_probability(
      target_age   = 85,
      current_date = test_current_date
    ),
    0.2404, 
    tolerance = 0.001
  )
})

test_that("setting age event", {
  
  test_birth_date <- "1955-07-15"
  
  members <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )

  expect_true(is.list(members$get_events()))
  expect_equal(NROW(members$get_events()), 0)
  
  members$set_event("retirement", 65)
  expect_equal(members$get_events()$retirement$start_age, 65)
  expect_equal(members$get_events()$retirement$end_age, Inf)
  
  members$set_event("social_security", 70)
  expect_equal(members$get_events()$social_security$start_age, 70)
  expect_equal(members$get_events()$social_security$end_age, Inf)
  
  members$set_event("kid", 20, years = 20)
  expect_equal(members$get_events()$kid$start_age, 20)
  expect_equal(members$get_events()$kid$end_age, 40 - 1)
  
  expect_equal(NROW(members$get_events()), 3)
})

test_that("cloning works", {

  test_birth_date <- "1955-07-15"
  members <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )
  
  members$set_event("retirement", 65)
  expect_equal(members$get_events()$retirement$start_age, 65)
  
  cloned_hm <- members$clone(deep = TRUE)
  cloned_hm$set_event("retirement", 100)
  expect_equal(cloned_hm$get_events()$retirement$start_age, 100)
})

test_that("calculating life expectancy", {

  member <- HouseholdMember$new(
    name       = "Isabela",
    birth_date = Sys.Date() - lubridate::years(25),
    mode       = 91,
    dispersion = 8.88
  )

  expect_equal(
    round(member$calc_life_expectancy()), 
    86
  )
})