## prep data for tests below hosp <- read.csv(system.file("extdata/observed/hdgov_hosp_weekly.csv", package = "rplanes")) tmp_hosp <- hosp %>% dplyr::select(date, location, flu.admits) %>% dplyr::mutate(date = as.Date(date)) prepped_observed <- to_signal(tmp_hosp, outcome = "flu.admits", type = "observed", resolution = "weeks") prepped_seed <- plane_seed(prepped_observed, cut_date = "2022-05-07") test_that("plane_diff flags large jump", { ## create some data to test ## make large point estimates to ensure a big jump => trigger diff flag point_est <- c(100,120,140,160) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 20, ## make a large jump in hospitalizations to trigger diff component point = point_est, upper = point_est + 20 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_true(plane_diff("01", prepped_forecast, prepped_seed)$indicator) ## make point estimates that do not have a large jump point_est <- c(28,31,34,37) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 10, ## make a large jump in hospitalizations to trigger diff component point = point_est, upper = point_est + 10 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_false(plane_diff("01", prepped_forecast, prepped_seed)$indicator) }) test_that("plane_taper detects narrowing PI", { ## create some data to test point_est <- c(100,100,100,100) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, ## make the lower and upper bounds get narrower as horizon increases lower = point_est - c(20,15,10,5), point = point_est, upper = point_est + c(20,15,10,5) ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_true(plane_taper("01", prepped_forecast, prepped_seed)$indicator) point_est <- c(100,100,100,100) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, ## make the lower and upper bounds get wider as horizon increases lower = point_est - 20, point = point_est, upper = point_est + 20 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_false(plane_taper("01", prepped_forecast, prepped_seed)$indicator) }) test_that("plane_cover identifies 1 week-ahead PI miss", { ## create some data to test ## make the 1 week-ahead point estimate and PI (below) miss the last reported obs point_est <- c(100,120,140,160) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 5, point = point_est, upper = point_est + 5 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_true(plane_cover("01", prepped_forecast, prepped_seed)$indicator) ## create some data to test ## make the 1 week-ahead point estimate and PI (below) cover the last reported obs point_est <- c(28,31,34,37) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 28, point = point_est, upper = point_est + 28 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_false(plane_cover("01", prepped_forecast, prepped_seed)$indicator) }) test_that("plane_repeat detects too many repeating values", { ## create some data to test ## make sure the point estimates repeat point_est <- c(100,100,100,100) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 20, point = point_est, upper = point_est + 20 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) ## check with forecast alone (no prepend) expect_true(plane_repeat(input = prepped_forecast, location = "01", seed = prepped_seed, tolerance = 3, prepend = 0)$indicator) ## check with forecast and default prepend behavior expect_true(plane_repeat(input = prepped_forecast, location = "01", seed = prepped_seed,tolerance = 3, prepend = NULL)$indicator) ## check with a high tolerance expect_false(plane_repeat(input = prepped_forecast, location = "01", seed = prepped_seed, tolerance = 4, prepend = NULL)$indicator) ## create some data to test ## make sure the point estimates do not repeat point_est <- c(100,120,140,160) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 20, point = point_est, upper = point_est + 20 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_false(plane_repeat(input = prepped_forecast, location = "01", seed = prepped_seed)$indicator) ## create some data to test ## make sure the forecast repeats the last value point_est <- c(prepped_seed$`01`$last_value,prepped_seed$`01`$last_value,30,35) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 5, point = point_est, upper = point_est + 5 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_true(plane_repeat(input = prepped_forecast, location = "01", seed = prepped_seed, tolerance = 2)$indicator) }) test_that("plane_score returns summary based on components specified", { prepped_forecast <- read_forecast(system.file("extdata/forecast/2022-10-31-SigSci-TSENS.csv", package = "rplanes")) %>% dplyr::filter(location %in% c("02","04","05","13","US")) %>% to_signal(., outcome = "flu.admits", type = "forecast", horizon = 4) prepped_seed <- plane_seed(prepped_observed, cut_date = "2022-10-29") ## check that the score function returns an overall object and that all locs are present res <- plane_score(prepped_forecast, prepped_seed) expect_s3_class(res$scores_raw, "data.frame") expect_type(res$scores_raw$indicator, "logical") expect_equal(length(unique(res$scores_raw$location)), length(unique(prepped_forecast$data$location))) ## check that the score function can be filtered to certain components res <- plane_score(prepped_forecast, prepped_seed, components = c("taper")) scored_comps <- res$scores_raw$component %>% unique(.) %>% sort(.) expect_equal(scored_comps, "taper") ## check that the score function can be filtered to certain components res <- plane_score(prepped_forecast, prepped_seed, components = c("cover", "diff", "taper")) scored_comps <- res$scores_raw$component %>% unique(.) %>% sort(.) expect_equal(scored_comps, c("cover", "diff", "taper")) ## check that the score function is inheriting parameters ## looking at this by increasing sig_level for trend (should increase sensitivity for flagging) ## and comparing to a lower sig_level to see if there are more flags res_high_sens <- plane_score(prepped_forecast, prepped_seed, components = c("trend"), args = list(trend = list(sig_lvl = 0.99))) res_low_sens <- plane_score(prepped_forecast, prepped_seed, components = c("trend"), args = list(trend = list(sig_lvl = 0.01))) expect_gt(sum(res_high_sens$scores_raw$indicator), sum(res_low_sens$scores_raw$indicator)) }) test_that("plane_score handles components for signals appropriately", { prepped_seed <- plane_seed(prepped_observed, cut_date = "2023-05-20") ## check that the score function only uses diff component if selected which should be fine for observed res <- plane_score(prepped_observed, prepped_seed, components = "diff") expect_equal(unique(res$scores_raw$component), "diff") ## check that score function can pick out relevant components ## in this case only diff should be used because this is an observed signal res <- plane_score(prepped_observed, prepped_seed, components = c("diff","taper")) expect_equal(unique(res$scores_raw$component), "diff") ## check that score errors if forecast-only components are used with observed expect_error(plane_score(prepped_observed, prepped_seed, components = c("taper","cover"))) }) test_that("plane_score handles weights", { prepped_forecast <- read_forecast(system.file("extdata/forecast/2022-10-31-SigSci-TSENS.csv", package = "rplanes")) %>% dplyr::filter(location %in% c("02","04","05","13","US")) %>% to_signal(., outcome = "flu.admits", type = "forecast", horizon = 4) prepped_seed <- plane_seed(prepped_observed, cut_date = "2022-10-29") ## check that the score function weights sum up as expected res <- plane_score(prepped_forecast, prepped_seed, components = c("diff","repeat"), weights = c("diff" = 4, "repeat"= 1)) expect_equal(res$scores_summary$`02`$weights_denominator, 5) ## check that weight names are enforced expect_error(plane_score(prepped_forecast, prepped_seed, components = c("diff","repeat"), weights = c("diff" = 4, "foo"= 1))) expect_error(plane_score(prepped_forecast, prepped_seed, components = c("diff","repeat"), weights = c("diff" = 4, "cover"= 1))) ## check that weights are enforced to be >= 1 expect_error( plane_score(prepped_forecast, prepped_seed, components = c("diff","repeat"), weights = c("diff" = 0.5, "repeat"= 1))) }) test_that("plane_trend flags known changepoints and is sensitive to changes in sig.lvl", { prepped_seed2 <- plane_seed(prepped_observed, cut_date = "2022-10-29") # need this cut date to test plane_trend prepped_forecast <- read_forecast(system.file("extdata/forecast/2022-10-31-SigSci-TSENS.csv", package = "rplanes")) %>% dplyr::filter(location %in% c("02","04","05","13","US")) %>% to_signal(., outcome = "flu.admits", type = "forecast", horizon = 4) ## We know there is a changepoint at location 5 that should be flagged: expect_true(plane_trend(location = "05", input = prepped_forecast, seed = prepped_seed2, sig_lvl = .2)$indicator) ## We know that location 2 doesn't have any changepoints that should be flagged: expect_false(plane_trend(location = "02", input = prepped_forecast, seed = prepped_seed2, sig_lvl = .2)$indicator) ## Check that increasing the sensitivity by decreasing the significance level should produce different results: expect_false(identical(plane_trend(location = "05", input = prepped_forecast, seed = prepped_seed2, sig_lvl = .2)$indicator, plane_trend(location = "05", input = prepped_forecast, seed = prepped_seed2, sig_lvl = .05)$indicator)) }) test_that("plane_shape flags novel shapes", { prepped_seed3 <- plane_seed(prepped_observed, cut_date = "2022-10-29") # need this cut date to test plane_shape ## default method ## create some data to test ## make a forecast with increase;decrease;increase;decrease shape point_est <- c(400,10,600,15) prepped_forecast <- dplyr::tibble( location = "01", date = seq(as.Date("2022-11-05"), as.Date("2022-11-26"), by = 7), horizon = 1:4, lower = point_est - 50, ## make a novel shape in the point estimate point = point_est, upper = point_est + 50 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) expect_true(plane_shape("01", prepped_forecast, prepped_seed3)$indicator) ## dtw method prepped_forecast <- read_forecast(system.file("extdata/forecast/2022-10-31-SigSci-TSENS.csv", package = "rplanes")) %>% to_signal(., outcome = "flu.admits", type = "forecast", horizon = 4) ## We know there is a novel shape at location 13 that should be flagged: expect_true(plane_shape(location = "13", input = prepped_forecast, seed = prepped_seed3, method = "dtw")$indicator) ## We know that location 2 doesn't have any novel shapes that should be flagged: expect_false(plane_shape(location = "02", input = prepped_forecast, seed = prepped_seed3, method = "dtw")$indicator) }) test_that("plane_zero handles zeros correctly", { ## create some data to test ## make a point estimate zero point_est <- c(0,600,700,800) prepped_forecast <- dplyr::tibble( location = "US", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 20, point = point_est, upper = point_est + 20 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) ## US has no zeros => would expect TRUE expect_true(plane_zero(location = "US", input = prepped_forecast, seed = prepped_seed)$indicator) ## create some data to test ## make no point estimate zero point_est <- c(500,600,700,800) prepped_forecast <- dplyr::tibble( location = "US", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est - 20, point = point_est, upper = point_est + 20 ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) ## US has no zeros => would expect FALSE if no zeros in eval expect_false(plane_zero(location = "US", input = prepped_forecast, seed = prepped_seed)$indicator) ## create some data to test ## make all point estimates zero point_est <- c(0,0,0,0) prepped_forecast <- dplyr::tibble( location = "02", date = seq(as.Date("2022-05-14"), as.Date("2022-06-04"), by = 7), horizon = 1:4, lower = point_est + 10, point = point_est, upper = point_est ) %>% to_signal(outcome = "flu.admits", type = "forecast", horizon = 4) ## alaska has zeros => would expect FALSE if no zeros in eval expect_false(plane_zero(location = "02", input = prepped_forecast, seed = prepped_seed)$indicator) })