tests/testthat/test-Household.R

In R4GoodPersonalFinances: Make Optimal Financial Decisions

test_that("adding household members", {
  
  h <- Household$new()

  expect_true(is.list(h$get_members()))
  expect_true(length(h$get_members()) == 0)
  
  h$add_member(
    HouseholdMember$new(
      name       = "test_member_1",  
      birth_date = "1980-07-15"
    )
  )
  expect_equal(
    length(h$get_members()), 
    1
  )
  expect_true(
    inherits(h$get_members()[["test_member_1"]], "HouseholdMember")
  )
  
  expect_error(
    h$add_member(
      HouseholdMember$new(
        name       = "test_member_1",  
        birth_date = "1980-07-15"
      )
    )
  )

  h$add_member(
    HouseholdMember$new(
      name       = "test_member_2",  
      birth_date = "1980-07-15"
    )
  )
  expect_equal(
    length(h$get_members()), 
    2
  )
  expect_true(
    inherits(h$get_members()[["test_member_1"]], "HouseholdMember")
  )
  expect_true(
    inherits(h$get_members()[["test_member_2"]], "HouseholdMember")
  )
})

test_that("calculating household max lifespan", {
  
  h <- Household$new()

  expect_error(
    h$get_lifespan(current_date = "2020-07-15")
  )
  
  h$add_member(
    HouseholdMember$new(
      name       = "test_member_older",  
      birth_date = "1980-07-15"
    )  
  )  
  expect_equal(
    h$get_lifespan(current_date = "2020-07-15"),
    60
  )

  h$add_member(
    HouseholdMember$new(
      name       = "test_member_younger",  
      birth_date = "1990-07-15"
    )
  )  
  expect_equal(
    h$get_lifespan(current_date = "2020-07-15"),
    70
  )  

  h$set_lifespan(90)
  expect_equal(
    h$get_lifespan(current_date = "2020-07-15"),
    90
  )
})

test_that("setting planned income", {

  household <- Household$new()
  household$add_member(
    HouseholdMember$new(
      name       = "test_member_older",  
      birth_date = "1980-07-15"
    )  
  )  
  household$add_member(
    HouseholdMember$new(
      name       = "younger",  
      birth_date = "1990-07-15"
    )
  )  
  
  expect_true(is.list(household$expected_income))
  expect_equal(
    length(household$expected_income),
    0
  )

  household$expected_income <- list(
    "income1" = c(
      "members$older$age >= 44 & members$older$age < 46 ~ 100",
      "members$older$age >= 46 ~ 300"
    ),
    "income2" = c(
      "members$younger$age >= 34 & members$younger$age < 36 ~ 44",
      "members$younger$age >= 36 ~ 55"
    )
  )
  expect_equal(
    length(household$expected_income),
    2
  )
})

test_that("setting planned non-discretionary spending", {

  household <- Household$new()
  household$add_member(
    HouseholdMember$new(
      name       = "test_member_older",  
      birth_date = "1980-07-15"
    )  
  )  
  household$add_member(
    HouseholdMember$new(
      name       = "younger",  
      birth_date = "1990-07-15"
    )
  )  
  
  expect_true(is.list(household$expected_spending))
  expect_equal(
    length(household$expected_spending),
    0
  )

  household$expected_spending <- list(
    "spending1" = c(
      "members$older$age >= 44 & members$older$age < 46 ~ 100",
      "members$older$age >= 46 ~ 300"
    ),
    "spending2" = c(
      "members$younger$age >= 34 & members$younger$age < 36 ~ 44",
      "members$younger$age >= 36 ~ 55"
    )
  )
  expect_equal(
    length(household$expected_spending),
    2
  )
})

test_that("setting household risk tolerance", {

  household <- Household$new()
  expect_equal(household$risk_tolerance, 0.5)

  household$risk_tolerance <- 0.35
  expect_equal(household$risk_tolerance, 0.35)
})

test_that("setting household consumption impatience preference", {

  household <- Household$new()
  expect_equal(household$consumption_impatience_preference, 0.04)

  household$consumption_impatience_preference <- 0.08
  expect_equal(household$consumption_impatience_preference, 0.08)
})

test_that("setting household smooth consumption preference", {

  household <- Household$new()
  expect_equal(household$smooth_consumption_preference, 1)

  household$smooth_consumption_preference <- 0.5
  expect_equal(household$smooth_consumption_preference, 0.5)
})

test_that("calculating joint Gompertz parameters for 1 member", {

  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

  household <- Household$new()
  household$add_member(members)
  
  survival <- household$calc_survival(current_date = test_current_date)
  expect_equal(survival$mode, 80, tolerance = 0.5)
  expect_equal(survival$dispersion, 10, tolerance = 0.5)
  expect_equal(
    survival$data |> 
    dplyr::filter(year == 85 - 65) |> 
    dplyr::pull(gompertz),
    0.2396, 
    tolerance = 0.001
  )
})

test_that("calculating joint Gompertz parameters for 2 members", {
  
  test_current_date <- "2020-01-01"
  hm1 <- 
    HouseholdMember$new(
      name       = "member1",
      birth_date = "1955-01-01"
    )
  expect_equal(
    hm1$calc_age(current_date = test_current_date), 
    65, 
    tolerance = 0.01
  )
  hm1$mode       <- 88
  hm1$dispersion <- 10.65

  hm2 <- 
    HouseholdMember$new(
      name = "member2",
      birth_date = "1955-01-01"
    )
  expect_equal(
    hm2$calc_age(current_date = test_current_date), 
    65, 
    tolerance = 0.01
  )
  hm2$mode       <- 91
  hm2$dispersion <- 8.88

  household <- Household$new()
  household$add_member(hm1)
  household$add_member(hm2)
  household$set_lifespan(45)
  
  params <- household$calc_survival(current_date = test_current_date) 
expect_equal(
     params$mode, 
    93.22423,
    tolerance = 1e-5
   )
   expect_equal(
     params$dispersion, 
    5.38006535,
    tolerance = 1e-8
   )
})

test_that("calculating joint Gompertz parameters for 3 members", {
  
  test_current_date <- "2020-01-01"
  hm1 <- 
    HouseholdMember$new(
      name       = "member1",
      birth_date = "1955-01-01"
    )
  expect_equal(
    hm1$calc_age(current_date = test_current_date), 
    65, 
    tolerance = 0.01
  )
  hm1$mode       <- 88
  hm1$dispersion <- 10.65

  hm2 <- 
    HouseholdMember$new(
      name = "member2",
      birth_date = "1955-01-01"
    )
  expect_equal(
    hm2$calc_age(current_date = test_current_date), 
    65, 
    tolerance = 0.01
  )
  hm2$mode       <- 91
  hm2$dispersion <- 8.88

  hm3 <- 
    HouseholdMember$new(
      name = "member3",
      birth_date = "1955-01-01"
    )
  expect_equal(
    hm3$calc_age(current_date = test_current_date), 
    65, 
    tolerance = 0.01
  )
  hm3$mode       <- 95
  hm3$dispersion <- 8.88

  household <- Household$new()
  household$add_member(hm1)
  household$add_member(hm2)
  household$add_member(hm3)
  household$set_lifespan(45)
 
  params <- household$calc_survival(current_date = test_current_date)

  expect_true(is.double(params$data[[hm1$get_name()]]))
  expect_true(is.double(params$data[[hm2$get_name()]]))
  expect_true(is.double(params$data[[hm3$get_name()]]))

  expect_equal(
    params$mode, 
    95.691272,
    tolerance = 1e-6
  )
  expect_equal(
    params$dispersion, 
    3.8796684,
    tolerance = 1e-7
  )
})

test_that("getting min_age - age of the youngest member", {

  test_current_date <- "2020-01-01"
  hm1 <- 
    HouseholdMember$new(
      name       = "member1",
      birth_date = "1955-01-01"
    )
  hm2 <- 
    HouseholdMember$new(
      name = "member2",
      birth_date = "1965-01-01"
    )
  hm3 <- 
    HouseholdMember$new(
      name = "member3",
      birth_date = "1975-01-01"
    )
  household <- Household$new()
  household$add_member(hm1)
  household$add_member(hm2)
  household$add_member(hm3) 

  hm1$calc_age(current_date = test_current_date)
  hm2$calc_age(current_date = test_current_date)
  hm3$calc_age(current_date = test_current_date)

  expect_equal(
    household$get_min_age(current_date = test_current_date),
    45,
    tolerance = 0.01
  )
})

test_that("cloning works", {

  skip_if_not(interactive())
  skip_on_ci()
  skip_on_cran()

  test_birth_date   <- "1955-07-15"
  members <- HouseholdMember$new(
    name       = "test_name",
    birth_date = test_birth_date
  )
  members$set_event("retirement", 65)
  household <- Household$new()
  household$add_member(members)
  expect_equal(
    household$get_members()$test_name$get_events()$retirement$start_age,
    65
  )

  household_hash <- rlang::hash(household)
  expect_equal(
    rlang::hash(household), 
    household_hash
  )

  household_bis <- unserialize(serialize(household, NULL))

  expect_equal(
    rlang::hash(household_bis), 
    household_hash
  )
  expect_equal(
    rlang::hash(household), 
    household_hash
  )

  household_bis$get_members()$test_name$set_event("retirement", 100)
  expect_equal(
    household_bis$get_members()$test_name$get_events()$retirement$start_age,
    100
  )
  expect_equal(
    household$get_members()$test_name$get_events()$retirement$start_age,
    65
  )

  expect_equal(rlang::hash(household), household_hash)
})