From 977bc062910e547e23f28983896962d3d880707b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rasmus=20Skytte=20Randl=C3=B8v?= Date: Mon, 9 Oct 2023 10:44:19 +0200 Subject: [PATCH] test: test the DiseasyModel class --- tests/testthat/test-DiseasyModel.R | 323 +++++++++++++++++++++++++++++ 1 file changed, 323 insertions(+) create mode 100644 tests/testthat/test-DiseasyModel.R diff --git a/tests/testthat/test-DiseasyModel.R b/tests/testthat/test-DiseasyModel.R new file mode 100644 index 00000000..48bee0f2 --- /dev/null +++ b/tests/testthat/test-DiseasyModel.R @@ -0,0 +1,323 @@ +test_that("initialize works", { + + # Creating an empty model module + m <- DiseasyModel$new() + + # Store the current hash + hash_new_instance <- m$hash + + # Check modules can be loaded into new instance + act <- DiseasyActivity$new() + s <- DiseasySeason$new() + obs <- DiseasyObservables$new() + + m_a <- DiseasyModel$new(activity = act) + m_s <- DiseasyModel$new(season = s) + m_o <- DiseasyModel$new(observables = obs) + + modules <- list(m, m_a, m_s, m_o) + expect_equal(length(unique(purrr::map(modules, ~ .x$hash))), length(modules)) + + + # Check a label can be set + m_l <- DiseasyModel$new(label = "test") + expect_equal(m_l$hash, m$hash) # label should not change the hash + + rm(m, m_a, m_s, m_o, m_l) +}) + + +test_that("load_module works", { + + # Check that observable is loaded into objects that can take it + m <- DiseasyModel$new(season = TRUE) + checkmate::expect_class(purrr::pluck(m, "season"), "DiseasySeason") + expect_null(purrr::pluck(m, "season", "observables")) + + obs <- DiseasyObservables$new() + m$load_module(obs) + checkmate::expect_class(purrr::pluck(m, "season"), "DiseasySeason") + checkmate::expect_class(purrr::pluck(m, "season", "observables"), "DiseasyObservables") + + rm(m) + + #.. and the other way around + m <- DiseasyModel$new(observables = TRUE) + checkmate::expect_class(purrr::pluck(m, "observables"), "DiseasyObservables") + expect_null(purrr::pluck(m, "season")) + + s <- DiseasySeason$new() + m$load_module(s) + checkmate::expect_class(purrr::pluck(m, "season"), "DiseasySeason") + checkmate::expect_class(purrr::pluck(m, "season", "observables"), "DiseasyObservables") + + rm(m) + + + + # Check loading of modules with booleans + mr <- DiseasyModel$new() + + # Prepare empty modules + act <- DiseasyActivity$new() + s <- DiseasySeason$new() + obs <- DiseasyObservables$new() + + expect_equal(DiseasyModel$new()$hash, mr$hash) + + mr$load_module(act) + expect_equal(DiseasyModel$new(activity = TRUE)$hash, mr$hash) + + mr$load_module(s) + expect_equal(DiseasyModel$new(activity = TRUE, season = TRUE)$hash, mr$hash) + + mr$load_module(obs) + expect_equal(DiseasyModel$new(activity = TRUE, season = TRUE, observables = TRUE)$hash, mr$hash) + + rm(mr) + + + + + # Test hash generation works as expected + # Creating an empty model module + m <- DiseasyModel$new() + hash_new_instance <- m$hash + + # Load modules into the module + act <- DiseasyActivity$new() + act$set_activity_units(dk_activity_units) + + scenario_1 <- data.frame(date = as.Date(character(0)), opening = character(0), closing = character(0)) |> + dplyr::add_row(date = as.Date("2020-01-01"), opening = "basis", closing = NA) |> + dplyr::add_row(date = as.Date("2020-03-12"), opening = NA, closing = "basis") |> + dplyr::add_row(date = as.Date("2020-03-12"), opening = "lockdown_2020", closing = NA) |> + dplyr::add_row(date = as.Date("2020-04-15"), opening = "secondary_education_phase_1_2020", closing = NA) + + act$change_activity(scenario_1) + + s <- DiseasySeason$new() + obs <- DiseasyObservables$new() + + # Loading DiseasyActivity + m$load_module(act) + hash_activity_loaded <- m$hash + expect_false(hash_activity_loaded == hash_new_instance) + + # Loading DiseasySeason + m$load_module(s) + hash_activity_season_loaded <- m$hash + expect_false(hash_activity_season_loaded == hash_new_instance) + expect_false(hash_activity_season_loaded == hash_activity_loaded) + + # Loading DiseasyObservables + m$load_module(obs) + hash_activity_season_observables_loaded <- m$hash # nolint: object_length_linter + expect_false(hash_activity_season_observables_loaded == hash_new_instance) + expect_false(hash_activity_season_observables_loaded == hash_activity_loaded) + expect_false(hash_activity_season_observables_loaded == hash_activity_season_loaded) + + + # Check reloading modules works + m$load_module(act) + expect_equal(m$hash, hash_activity_season_observables_loaded) + + m$load_module(s) + expect_equal(m$hash, hash_activity_season_observables_loaded) + + m$load_module(obs) + expect_equal(m$hash, hash_activity_season_observables_loaded) + + # Check loading of altered module changes the hash + act_alt <- DiseasyActivity$new() + act_alt$set_activity_units(dk_activity_units) + act_alt$change_activity(head(scenario_1, 3)) + m$load_module(act_alt) + expect_false(m$hash == hash_activity_season_observables_loaded) + + s_alt <- DiseasySeason$new(reference_date = as.Date("2020-03-01")) + m$load_module(act) + expect_equal(m$hash, hash_activity_season_observables_loaded) + m$load_module(s_alt) + expect_false(m$hash == hash_activity_season_observables_loaded) + + obs_alt <- DiseasyObservables$new(last_queryable_date = as.Date("2020-03-01")) + m$load_module(s) + expect_equal(m$hash, hash_activity_season_observables_loaded) + m$load_module(obs_alt) + expect_false(m$hash == hash_activity_season_observables_loaded) + + rm(m, s, act, obs, s_alt, act_alt, obs_alt) + +}) + + +test_that("cloning works", { + + # Creating modules for the model module + act <- DiseasyActivity$new() + act$set_activity_units(dk_activity_units) + + scenario_1 <- data.frame(date = as.Date(character(0)), opening = character(0), closing = character(0)) |> + dplyr::add_row(date = as.Date("2020-01-01"), opening = "basis", closing = NA) |> + dplyr::add_row(date = as.Date("2020-03-12"), opening = NA, closing = "basis") |> + dplyr::add_row(date = as.Date("2020-03-12"), opening = "lockdown_2020", closing = NA) |> + dplyr::add_row(date = as.Date("2020-04-15"), opening = "secondary_education_phase_1_2020", closing = NA) + + act$change_activity(scenario_1) + + s <- DiseasySeason$new() + obs <- DiseasyObservables$new() + + + + # Create instance of the DiseasyModel with the modules + m <- DiseasyModel$new(activity = act, + season = s, + observables = obs) + hash_loaded <- m$hash + + + # Create a simple clone + m_c <- m$clone() + expect_equal(m_c$hash, hash_loaded) # Hash should be the same + + + + # If we load a new module into the clone, we want new hashes in the clone + act_alt <- DiseasyActivity$new() + act_alt$set_activity_units(dk_activity_units) + act_alt$change_activity(head(scenario_1, 3)) + m_c$load_module(act_alt) + expect_equal(m$hash, hash_loaded) # Hash should be the same for the original instance + expect_false(m_c$hash == hash_loaded) # Hash should be changed for the clone instance + + s_alt <- DiseasySeason$new(reference_date = as.Date("2020-03-01")) + m_c$load_module(act) + expect_equal(m_c$hash, hash_loaded) # Hash should now be reset + m_c$load_module(s_alt) + expect_equal(m$hash, hash_loaded) # Hash should be the same for the original instance + expect_false(m_c$hash == hash_loaded) # Hash should be changed for the clone instance + + obs_alt <- DiseasyObservables$new(last_queryable_date = as.Date("2020-03-01")) + m_c$load_module(s) + expect_equal(m_c$hash, hash_loaded) # Hash should now be reset + m_c$load_module(obs_alt) + expect_equal(m$hash, hash_loaded) # Hash should be the same for the original instance + expect_false(m_c$hash == hash_loaded) # Hash should be changed for the clone instance + + + + # If we change the module inside of one, it should not change in the other + m_c$load_module(obs) + expect_equal(m_c$hash, hash_loaded) # Hash should now be reset + + + # - activity + m_c$activity$reset_scenario() + expect_equal(m$hash, hash_loaded) # Hash should be the same for the original instance + expect_false(m_c$hash == hash_loaded)# Hash should be changed for the clone instance + expect_false(act$hash == m_c$activity$hash) # module hashes should also be different + + # - season + m_c$load_module(act) + expect_equal(m_c$hash, hash_loaded) # Hash should now be reset + m_c$season$set_reference_date(as.Date("2020-03-01")) + expect_equal(m$hash, hash_loaded) # Hash should be the same for the original instance + expect_false(m_c$hash == hash_loaded)# Hash should be changed for the clone instance + expect_false(s$hash == m_c$season$hash) # module hashes should also be different + + # - observables + m_c$load_module(s) + expect_equal(m_c$hash, hash_loaded) # Hash should now be reset + m_c$observables$set_last_queryable_date(as.Date("2020-03-01")) + expect_equal(m$hash, hash_loaded) # Hash "202should be the same for the original instance + expect_false(m_c$hash == hash_loaded)# Hash should be changed for the clone instance + expect_false(obs$hash == m_c$observables$hash) # module hashes should also be different + + rm(m, m_c, s, act, obs, s_alt, act_alt, obs_alt) +}) + + +test_that("get_results gives error", { + + # Creating an empty module + m <- DiseasyModel$new() + + # Test the get_results + expect_error(m$get_results(), + class = "simpleError", + regex = "Each model must implement their own `get_results` methods") +}) + + +test_that("active binding: activity works", { + + # Creating an empty module + m <- DiseasyModel$new() + + # Retrieve the activity + expect_equal(m$activity, NULL) + + # Try to set activity through the binding + # test_that cannot capture this error, so we have to hack it + expect_identical(tryCatch(m$activity <- DiseasyActivity$new(), error = \(e) e), + simpleError("`$activity` is read only")) + expect_equal(m$activity, NULL) + + rm(m) +}) + + +test_that("active binding: observables works", { + + # Creating an empty module + m <- DiseasyModel$new() + + # Retrieve the observables + expect_equal(m$observables, NULL) + + # Try to set observables through the binding + # test_that cannot capture this error, so we have to hack it + expect_identical(tryCatch(m$observables <- DiseasyObservables$new(), error = \(e) e), + simpleError("`$observables` is read only")) + expect_equal(m$observables, NULL) + + rm(m) +}) + + +test_that("active binding: season works", { + + # Creating an empty module + m <- DiseasyModel$new() + + # Retrieve the season + expect_equal(m$season, NULL) + + # Try to set season through the binding + # test_that cannot capture this error, so we have to hack it + expect_identical(tryCatch(m$season <- DiseasySeason$new(), error = \(e) e), + simpleError("`$season` is read only")) + expect_equal(m$season, NULL) + + rm(m) +}) + + +test_that("active binding: parameters works", { + + # Creating an empty module + m <- DiseasyModel$new() + + # Retrieve the parameters + expect_equal(m$parameters, NULL) + + # Try to set parameters through the binding + # test_that cannot capture this error, so we have to hack it + expect_identical(tryCatch(m$parameters <- list(test = 2), error = \(e) e), + simpleError("`$parameters` is read only")) + expect_equal(m$parameters, NULL) + + rm(m) +})