tests/testthat/test-attributable.R

In bdlnm: Bayesian Distributed Lag Non-Linear Models (B-DLNM)

test_that("attributable returns expected structure and summaries (backwards)", {
  skip_on_cran()
  skip_if_not(check_inla(), "INLA not available")

  expect_silent(
    attr <- attributable(
      mod,
      slondon,
      "date",
      "tmean",
      "mort_75plus",
      cen = cen
    )
  )

  # basic structure
  expect_type(attr, "list")
  expect_equal(
    names(attr),
    c(
      "af",
      "an",
      "aftotal",
      "antotal",
      "af.summary",
      "an.summary",
      "aftotal.summary",
      "antotal.summary"
    )
  )

  # sample count and names
  expect_equal(dim(attr$an), c(nrow(slondon), n_sim))
  expect_equal(dim(attr$af), c(nrow(slondon), n_sim))
  expect_equal(colnames(attr$an), paste0("sample", seq_len(n_sim)))
  expect_equal(colnames(attr$af), paste0("sample", seq_len(n_sim)))

  # summaries present and contain mean, sd and at least one quantile + mode
  expect_true(all(c("mean", "sd", "mode") %in% colnames(attr$an.summary)))
  expect_true(any(grepl("quant$", colnames(attr$an.summary))))
  expect_true(all(c("mean", "sd", "mode") %in% colnames(attr$af.summary)))
  expect_true(any(grepl("quant$", colnames(attr$af.summary))))

  #NA at the beginning
  expect_equal(
    names(which(is.na(attr$af.summary[, "0.5quant"]))),
    as.character(slondon$date[1:21])
  )
  expect_equal(
    names(which(is.na(attr$an.summary[, "0.5quant"]))),
    as.character(slondon$date[1:21])
  )
})

test_that("attributable returns expected structure and summaries (forward)", {
  skip_on_cran()
  skip_if_not(check_inla(), "INLA not available")

  expect_silent(
    attr <- attributable(
      mod,
      slondon,
      "date",
      "tmean",
      "mort_75plus",
      cen = cen,
      dir = "forw"
    )
  )

  # basic structure
  expect_type(attr, "list")
  expect_equal(
    names(attr),
    c(
      "af",
      "an",
      "aftotal",
      "antotal",
      "af.summary",
      "an.summary",
      "aftotal.summary",
      "antotal.summary"
    )
  )

  # sample count and names
  expect_equal(dim(attr$an), c(nrow(slondon), n_sim))
  expect_equal(dim(attr$af), c(nrow(slondon), n_sim))
  expect_equal(colnames(attr$an), paste0("sample", seq_len(n_sim)))
  expect_equal(colnames(attr$af), paste0("sample", seq_len(n_sim)))

  # summaries present and contain mean, sd and at least one quantile + mode
  expect_true(all(c("mean", "sd", "mode") %in% colnames(attr$an.summary)))
  expect_true(any(grepl("quant$", colnames(attr$an.summary))))
  expect_true(all(c("mean", "sd", "mode") %in% colnames(attr$af.summary)))
  expect_true(any(grepl("quant$", colnames(attr$af.summary))))

  #NA at the end
  expect_equal(sum(is.na(attr$af.summary[, "0.5quant"])), 0)
  expect_equal(
    names(which(is.na(attr$an.summary[, "0.5quant"]))),
    as.character(sort(rev(slondon$date)[1:21]))
  )
})


test_that("attributable returns filtered time-series matrices when filter is specified", {
  skip_on_cran()
  skip_if_not(check_inla(), "INLA not available")

  # filter only for summer
  summer_dates <- slondon$date[
    slondon$date >= as.Date("2011-06-01") &
      slondon$date <= as.Date("2011-09-30")
  ]
  slondon$summer <- ifelse(slondon$date %in% summer_dates, 1, 0)

  expect_warning(
    attr2 <- attributable(
      mod,
      slondon,
      "date",
      "tmean",
      "mort_75plus",
      "summer",
      cen = cen
    )
  )

  expect_equal(dim(attr2$af), c(length(summer_dates), n_sim))
  expect_equal(dim(attr2$an), c(length(summer_dates), n_sim))

  expect_equal(colnames(attr2$an), paste0("sample", seq_len(n_sim)))
  expect_equal(colnames(attr2$af), paste0("sample", seq_len(n_sim)))

  expect_equal(rownames(attr2$an), as.character(summer_dates))
  expect_equal(rownames(attr2$af), as.character(summer_dates))
  expect_equal(rownames(attr2$an.summary), as.character(summer_dates))
  expect_equal(rownames(attr2$af.summary), as.character(summer_dates))

  # no missings
  expect_equal(sum(is.na(attr2$af.summary[, "0.5quant"])), 0)
  expect_equal(sum(is.na(attr2$an.summary[, "0.5quant"])), 0)
})

test_that("attributable works when cases = NULL (only AF returned)", {
  skip_on_cran()
  skip_if_not(check_inla(), "INLA not available")

  # Expect a warning (informing that only AF will be calculated)
  expect_warning(
    attr3 <- attributable(mod, slondon, "date", "tmean", cen = cen)
  )

  expect_type(attr3, "list")
  expect_equal(names(attr3), c("af", "af.summary"))
  expect_equal(dim(attr3$af), c(nrow(slondon), n_sim))
  expect_equal(dim(attr3$af.summary), c(nrow(slondon), 6))
})


test_that("attributable gives error when time series are not ordered or not provided on a regular basis", {
  skip_on_cran()
  skip_if_not(check_inla(), "INLA not available")

  slondon2 <- slondon[order(slondon$tmean), ]
  expect_snapshot_error(attributable(
    mod,
    slondon2,
    "date",
    "tmean",
    "mort_75plus",
    cen = cen
  ))

  slondon2 <- slondon[-2, ]
  expect_snapshot_error(attributable(
    mod,
    slondon2,
    "date",
    "tmean",
    "mort_75plus",
    cen = cen
  ))

  # Works if date is provided on a weekly basis
  slondon2 <- slondon
  slondon2$date <- seq(
    as.Date("1900-01-01"),
    as.Date("2010-01-01"),
    by = "week"
  )[seq_len(nrow(slondon2))]
  expect_silent(attributable(
    mod,
    slondon2,
    "date",
    "tmean",
    "mort_75plus",
    cen = cen
  ))

  # Works if date is provided on a monthly basis
  slondon2 <- slondon
  slondon2$date <- seq(
    as.Date("1900-01-01"),
    as.Date("2010-01-01"),
    by = "month"
  )[seq_len(nrow(slondon2))]
  expect_silent(attributable(
    mod,
    slondon2,
    "date",
    "tmean",
    "mort_75plus",
    cen = cen
  ))

  # Works if date is provided on a yearly basis
  slondon2 <- slondon
  slondon2$date <- seq(
    as.Date("1500-01-01"),
    as.Date("2010-01-01"),
    by = "year"
  )[seq_len(nrow(slondon2))]
  expect_silent(attributable(
    mod,
    slondon2,
    "date",
    "tmean",
    "mort_75plus",
    cen = cen
  ))
})