tests/testthat/test-tfr.R

In poputils: Demographic Analysis and Data Manipulation

## 'remove_existing_tfr_col' --------------------------------------------------

test_that("'remove_existing_tfr_col' returns data untouched if no tfr col present, or if suffix used", {
  data <- expand.grid(sex = c("f", "m"), age = age_labels("five", min = 15, max = 50))
  ans_obtained <- remove_existing_tfr_col(data, suffix = NULL)
  ans_expected <- data
  expect_identical(ans_obtained, ans_expected)
  data$tfr <- runif(n = nrow(data))
  ans_obtained <- remove_existing_tfr_col(data, suffix = "x")
  ans_expected <- data
  expect_identical(ans_obtained, ans_expected)
})

test_that("'remove_existing_tfr_col' removes columns if tfr present", {
  data <- expand.grid(sex = c("f", "m"), age = age_labels("five", min = 15, max = 50))
  data$tfr <- runif(n = nrow(data))
  suppressMessages(ans_obtained <- remove_existing_tfr_col(data, suffix = NULL))
  ans_expected <- data[1:2]
  expect_identical(ans_obtained, ans_expected)
  data <- expand.grid(sex = c("f", "m"), age = age_labels("five", min = 15, max = 50))
  data$tfr.x <- runif(n = nrow(data))
  suppressMessages(ans_obtained <- remove_existing_tfr_col(data, suffix = "x"))
  ans_expected <- data[1:2]
  expect_identical(ans_obtained, ans_expected)
})


## 'tfr_inner' ----------------------------------------------------------------

test_that("'tfr' works with by = 1, no sex", {
  data <- data.frame(age = age_labels("five", min = 15, max = 50),
                     asfr = 1:7)
  ans_obtained <- tfr(data = data,
                      asfr = asfr,
                      denominator = 2,
                      suffix = "xx")
  ans_expected <- tibble::tibble(tfr.xx = 5 * sum(1:7) / 2)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'tfr' works with sex, by = 2", {
  data <- data.frame(age = rep(age_labels("five", min = 15, max = 50), 4),
                     sex = rep(rep(c("f", "m"), each = 7), 2),
                     reg = rep(c("a", "b"), each = 14),
                     asfr = runif(n = 28))
  ans_obtained <- tfr(data,
                      asfr = asfr,
                      sex = sex,
                      by = reg)
  ans_expected <- tibble::tibble(reg = c("a", "b"),
                                 tfr = 5 * c(sum(data$asfr[1:14]), sum(data$asfr[15:28])))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'tfr' with 'by' and tfr with 'group_by' give same answer", {
  data <- data.frame(age = rep(age_labels("five", min = 15, max = 50), 4),
                     sex = rep(rep(c("f", "m"), each = 7), 2),
                     reg = rep(c("a", "b"), each = 14),
                     asfr = runif(n = 28))
  ans_by <- tfr(data,
                      asfr = asfr,
                      sex = sex,
                by = reg)
  ans_group_by <- data |>
    dplyr::group_by(reg) |>
    tfr(asfr = asfr, sex = sex)
  expect_identical(ans_by, ans_group_by)
})

test_that("'tfr' throws appopriate error message by = 1", {
  data <- data.frame(age = age_labels("five", min = 15, max = 50),
                     asfr = c(1:6, -1))
  expect_error(tfr(data = data,
                   asfr = asfr,
                   denominator = 2,
                   suffix = "xx"),
               "`asfr` has negative value.")
})

test_that("'tfr' throws appropriate error when by = 2", {
  data <- data.frame(age = rep(age_labels("five", min = 15, max = 50), 4),
                     sex = rep(rep(c("f", "m"), each = 7), 2),
                     reg = rep(c("a", "b"), each = 14),
                     asfr = runif(n = 28))
  data$asfr[10] <- -1
  expect_error(tfr(data,
                   asfr = asfr,
                   sex = sex,
                   by = reg),
               "Problem calculating total fertility rate.")
})

test_that("'tfr' gives warning when TFR too high", {
  data <- data.frame(age = age_labels("five", min = 15, max = 50),
                     asfr = 1000:1006)
  expect_warning(tfr(data = data,
                     asfr = asfr,
                     denominator = 2,
                     suffix = "xx"),
                 "Value for TFR over 100.")
  expect_warning(tfr(data = data,
                     asfr = asfr,
                     denominator = 2),
                 "Value for TFR over 100.")
})


## 'tfr_inner' ----------------------------------------------------------------

test_that("'tfr_inner' works with no sex", {
  data <- data.frame(age = age_labels("five", min = 15, max = 50),
                     asfr = 1:7)
  empty_colnum <- integer()
  names(empty_colnum) <- character()
  ans_obtained <- tfr_inner(data,
                            asfr_colnum = c(asfr = 2L),
                            age_colnum = c(age = 1L),
                            sex_colnum = empty_colnum,
                            denominator = 2,
                            suffix = NULL)
  ans_expected <- tibble::tibble(tfr = 5 * sum(1:7) / 2)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'tfr_inner' works with sex, suffix", {
  data <- data.frame(age = rep(age_labels("five", min = 15, max = 50), 2),
                     sex = rep(c("f", "m"), each = 7),
                     asfr = c(1:7, 2:8))[c(1,3,2,4,5:14),]
  empty_colnum <- integer()
  names(empty_colnum) <- character()
  ans_obtained <- tfr_inner(data,
                            asfr_colnum = c(asfr = 3L),
                            age_colnum = c(age = 1L),
                            sex_colnum = c(sex = 2L),
                            denominator = 1,
                            suffix = "x")
  ans_expected <- tibble::tibble(tfr.x = 5 * sum(1:7, 2:8))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'tfr_inner' works with rvec, no sex", {
  data <- data.frame(age = 12:44,
                     asfr = rvec::runif_rvec(n = 33, n_draw = 10))
  empty_colnum <- integer()
  names(empty_colnum) <- character()
  ans_obtained <- tfr_inner(data,
                            asfr_colnum = c(asfr = 2L),
                            age_colnum = c(age = 1L),
                            sex_colnum = empty_colnum,
                            denominator = 1,
                            suffix = NULL)
  ans_expected <- tibble::tibble(tfr = sum(data$asfr))
  expect_identical(ans_obtained, ans_expected)
  expect_true(rvec::is_rvec(ans_obtained$tfr))
})

test_that("'tfr_inner' throws correct error with sex", {
  data <- data.frame(age = rep(age_labels("five", min = 15, max = 50), 2),
                     sex = rep(c("f", "m"), each = 7),
                     asfr = c(1:7, 2:8))
  data$asfr[[3]] <- -1
  empty_colnum <- integer()
  names(empty_colnum) <- character()
  expect_error(tfr_inner(data,
                         asfr_colnum = c(asfr = 3L),
                         age_colnum = c(age = 1L),
                         sex_colnum = c(sex = 2L),
                         denominator = 1,
                         suffix = "x"),
               "`asfr` has negative value")
})

test_that("'tfr_inner' checks age sexparately within sex", {
  data <- data.frame(age = rep(age_labels("five", min = 15, max = 50), 2),
                     sex = rep(c("f", "m"), each = 7),
                     asfr = c(1:7, 2:8))
  data <- data[-3,]
  empty_colnum <- integer()
  names(empty_colnum) <- character()
  expect_error(tfr_inner(data,
                         asfr_colnum = c(asfr = 3L),
                         age_colnum = c(age = 1L),
                         sex_colnum = c(sex = 2L),
                         denominator = 1,
                         suffix = "x"),
               "Age group \"25-29\" is missing.")
})