From 55a71e43f4e373dd51b0b5ff566b3dadf02226a6 Mon Sep 17 00:00:00 2001 From: Droomelot De Gendt Date: Wed, 8 Jul 2026 16:16:41 +0200 Subject: [PATCH 1/3] test(test-get.R): add tests to validate dwh migration (use static subset of closed locations) --- tests/testthat/helper-get.R | 4 + tests/testthat/setup.R | 4 + tests/testthat/test-get.R | 195 ++++++++++++++++++++++++++++++++++++ 3 files changed, 203 insertions(+) diff --git a/tests/testthat/helper-get.R b/tests/testthat/helper-get.R index 26a9198..05e0708 100644 --- a/tests/testthat/helper-get.R +++ b/tests/testthat/helper-get.R @@ -90,3 +90,7 @@ expect_xg3 <- function(xg3, test_name) { expect_chem <- function(chem, test_name) { expect_data(chem, "chem", test_name) } + +expect_migration <- function(data, test_name) { + expect_data(data, "dwh_migration", test_name) +} diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index ec042bb..2d06f29 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -4,6 +4,10 @@ withr::local_options( test.skip_data_validation = !(getOption( "test.run_data_validation", default = FALSE + )), + test.skip_dwh_migration = !(getOption( + "test.run_dwh_migration", + default = FALSE )) ), .local_envir = testthat::teardown_env() diff --git a/tests/testthat/test-get.R b/tests/testthat/test-get.R index adddc0f..4fcd71e 100644 --- a/tests/testthat/test-get.R +++ b/tests/testthat/test-get.R @@ -352,3 +352,198 @@ test_that("get_chem output matches exactly during extensive evaluation", { expect_chem(chem, "all_20170101") }) }) + +# DWH MIGRATION TEST ----------------------------------------------------------- +test_that("Test to evaluate DWH migration", { + suppressWarnings({ + file_names <- c( + "all", + "all_obswells" + ) + announce_files_locs(file_names) + + skip_if(getOption("test.skip_dwh_migration")) + watina <- fetch_watina_connection() + + # Selected locations for DWH migration testing: + # - location is locked (Status = 'afgesloten') + # - with a sufficient amount of observations (COUNT(peilpunten) >= 1000) + testing_locations <- c( + "BLAP028", + "BOBP020", + "BGNP008", + "BGNP009", + "BGNP011", + "BGNP012", + "BGNP020", + "BGNP021", + "BGNP025", + "BGNP028", + "BGNP031", + "BGNP035", + "BGNP036", + "CABP005", + "BRSP005", + "DUNS002", + "DUNS003", + "DURP004", + "GRMP013", + "GWZP010", + "IJSP032", + "KAMP002", + "KAMP041", + "KAMP206", + "KAMS021", + "KALP144", + "KALP154", + "KRGP038", + "KRGP039", + "POLP002", + "POLP006", + "KBRP128", + "KBRS003", + "KBRS007", + "KBRS009", + "UKPP025", + "VLBP021", + "VLBP023", + "VLBS004", + "ZSCP122", + "ZSCP132", + "ZSCP133", + "ZWAS232" + ) + # DWH W0002_10_Watina has only validity VLD + testing_validity <- c("VLD") + # Include all loc_types + testing_types <- c("P", "S", "R", "N", "W", "D", "L", "B") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + area_codes = c("KAL", "ZWA") + ) + expect_migration(locs, "locs_area_codes") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + bbox = c(xmin = 1.4e+5, xmax = 1.7e+5, ymin = 1.6e+5, ymax = 1.9e+5) + ) + expect_migration(locs, "locs_bbox") + + wfs_url <- "https://geo.api.vlaanderen.be/VRBG/wfs" %>% + httr2::request() %>% + httr2::req_url_query( + request = "GetFeature", + typeName = "VRBG:Refprv", + cql_filter = "NAAM='West-Vlaanderen'", + srsName = "EPSG:31370", + outputFormat = "text/xml; subtype=gml/3.1.1" + ) + mymask <- sf::read_sf(wfs_url$url, crs = 31370) %>% + sf::st_cast("GEOMETRYCOLLECTION") + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + mask = mymask, + buffer = 0 + ) + expect_migration(locs, "locs_mask") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_guess = TRUE + ) + expect_migration(locs, "locs_filterdepth_guess") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE + ) + expect_migration(locs, "locs_filterdepth_na") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_migration(locs, "locs_obswell_aggr_latest") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest_fd" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_migration(locs, "locs_obswell_aggr_latest_fd") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest_sso" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_migration(locs, "locs_obswell_aggr_latest_sso") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "mean" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_migration(locs, "locs_obswell_aggr_mean") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types + ) + expect_migration(locs, "locs") + + obswells <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + obswells = TRUE + ) + expect_migration(obswells, "obswells") + + xg3 <- locs %>% get_xg3(watina, 2010) %>% collect() + expect_migration(xg3, "xg3") + + chem <- locs %>% get_chem(watina, "1/1/2017") %>% collect() + expect_migration(chem, "chem") + }) +}) From be906d7b397284e310883b3c9ea3732a2bf12eb6 Mon Sep 17 00:00:00 2001 From: Droomelot De Gendt Date: Tue, 14 Jul 2026 10:41:14 +0200 Subject: [PATCH 2/3] test: create separate testing file for migration --- .Rprofile | 2 + tests/testthat/README.md | 23 ++- tests/testthat/helper-get.R | 6 + tests/testthat/test-dwh-migration.R | 229 ++++++++++++++++++++++++++++ tests/testthat/test-get.R | 203 +----------------------- 5 files changed, 263 insertions(+), 200 deletions(-) create mode 100644 tests/testthat/test-dwh-migration.R diff --git a/.Rprofile b/.Rprofile index 1c39bc8..2c943f5 100644 --- a/.Rprofile +++ b/.Rprofile @@ -1,7 +1,9 @@ options(test.run_snapshot = FALSE) options(test.run_data_validation = FALSE) +options(test.run_dwh_migration = FALSE) message("ℹ️ test: snapshot and data validation tests are default set to 'RUN = FALSE'") message("ℹ️ Run options(test.run_snapshot = TRUE) in the console to activate the snaphot tests.") message("ℹ️ Run options(test.run_data_validation = TRUE) in the console to activate the data validation tests.") +message("ℹ️ Run options(test.run_dwh_migration = TRUE) in the console to activate the data warehouse migration tests.") message("ℹ️ See the testing README for more information.") diff --git a/tests/testthat/README.md b/tests/testthat/README.md index 8ad7486..0fdf141 100644 --- a/tests/testthat/README.md +++ b/tests/testthat/README.md @@ -16,7 +16,7 @@ Since untracked local snapshot files persist across git branch switches, you can ### 1. Set up a database connection -Create a database connection with the variable name 'test_con'. If this variable is not found, the snapshot tests will be skipped. +Create a database connection with the variable name `test_con`. If this variable is not found, the snapshot tests will be skipped. ``` r test_con <- connect_watina() @@ -26,13 +26,19 @@ test_con <- connect_watina() *When reviewing a PR, switch to the stable main branch (`git switch main`).* -Run the snapshot tests: +Run the standard snapshot tests: ``` r devtools::test(filter = "get") ``` -This will create local snapshot files that are stored in tests/testthat/\_snaps. +Or, if you are verifying a data warehouse migration, run the migration tests: + +``` r +devtools::test(filter = "dwh-migration") +``` + +This will create local snapshot files that are stored in `tests/testthat/_snaps`. ### 3. Modify your code @@ -43,7 +49,11 @@ Switch to your feature branch if you're reviewing a PR or apply your changes whe Execute the test code with the applied changes: ``` r +# standard snapshot tests devtools::test(filter = "get") + +# data warehouse migration tests +devtools::test(filter = "dwh-migration") ``` **If the tests pass**: The data generated by the modified code is a perfect structural match with your baseline. @@ -56,6 +66,7 @@ Testing behavior is managed dynamically through R session `options()`. When you - **test.run_snapshot** (*default is FALSE*): Toggle to test database query changes. When FALSE, database snapshot tests are skipped. - **test.run_data_validation** (*default is FALSE*): Toggle to execute extensive end-to-end table checks (e.g., retrieving all historical rows). Keep FALSE unless verifying a major data warehouse migration. +- **test.run_dwh_migration** (*default is FALSE*): Toggle to execute tests specifically written to evaluate data warehouse changes. These tests include a static validation set with locations that are unlikely to have data changes in the future. Keep FALSE unless verifying a data warehouse change. You can flip these switches directly in your RStudio console at any time. Never modify the default settings in the `.Rprofile`! @@ -66,9 +77,13 @@ options(test.run_snapshot = TRUE) # Activate extensive data validation tests options(test.run_data_validation = TRUE) +# Activate data warehouse migration tests +options(test.run_dwh_migration = TRUE) + # Return to default mode options(test.run_snapshot = FALSE) options(test.run_data_validation = FALSE) +options(test.run_dwh_migration = FALSE) ``` -💡 Under the hood: When you run `devtools::test()`, `setup.R` automatically reads these console options. If no active database connection (`test_con`) is found in your Global Environment, database tests will always automatically skip for safety (e.g., on GitHub Actions). +💡 Under the hood: When you run `devtools::test()`, `setup.R` automatically reads these console options and maps them to internal skip flags (e.g. converting `test.run_snapshot = FALSE` into `test.skip_snapshot = TRUE`). If no active database connection (`test_con`) is found in your Global Environment, database tests will always automatically skip for safety (e.g., on GitHub Actions). diff --git a/tests/testthat/helper-get.R b/tests/testthat/helper-get.R index 05e0708..ce17818 100644 --- a/tests/testthat/helper-get.R +++ b/tests/testthat/helper-get.R @@ -34,6 +34,10 @@ announce_files_chem <- function(file_names) { announce_files(file_names, "chem") } +announce_files_migration <- function(file_names) { + announce_files(file_names, "dwh_migration") +} + clean_up_table <- function(table) { floor_0 <- c( "x", @@ -59,7 +63,9 @@ clean_up_table <- function(table) { arrange( pick( ends_with("_code"), + ends_with("_id"), ends_with("year"), + ends_with("date"), ends_with("_ost"), ends_with("_lcl"), ends_with("_variable") diff --git a/tests/testthat/test-dwh-migration.R b/tests/testthat/test-dwh-migration.R new file mode 100644 index 0000000..36de0ef --- /dev/null +++ b/tests/testthat/test-dwh-migration.R @@ -0,0 +1,229 @@ +# DWH MIGRATION TEST ----------------------------------------------------------- +# Selected locations for DWH migration testing: +# - location is locked (Status = 'afgesloten') +# - with a sufficient amount of observations (COUNT(peilpunten) >= 1000) +testing_locations <- c( + "BLAP028", + "BOBP020", + "BGNP008", + "BGNP009", + "BGNP011", + "BGNP012", + "BGNP020", + "BGNP021", + "BGNP025", + "BGNP028", + "BGNP031", + "BGNP035", + "BGNP036", + "CABP005", + "BRSP005", + "DUNS002", + "DUNS003", + "DURP004", + "GRMP013", + "GWZP010", + "IJSP032", + "KAMP002", + "KAMP041", + "KAMP206", + "KAMS021", + "KALP144", + "KALP154", + "KRGP038", + "KRGP039", + "POLP002", + "POLP006", + "KBRP128", + "KBRS003", + "KBRS007", + "KBRS009", + "UKPP025", + "VLBP021", + "VLBP023", + "VLBS004", + "ZSCP122", + "ZSCP132", + "ZSCP133", + "ZWAS232" +) + +# DWH W0002_10_Watina has only validity VLD +testing_validity <- c("VLD") +# Include all loc_types +testing_types <- c("P", "S", "R", "N", "W", "D", "L", "B") + +test_that("get_locs, get_xg3 and get_chem work with default filters and dwh settings", { + suppressWarnings({ + file_names <- c( + "locs", + "obswells", + "xg3", + "chem" + ) + announce_files_migration(file_names) + + skip_if(getOption("test.skip_dwh_migration")) + watina <- fetch_watina_connection() + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types + ) + expect_migration(locs, "locs") + + obswells <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + obswells = TRUE + ) + expect_migration(obswells, "obswells") + + xg3 <- locs %>% get_xg3(watina, 2010) %>% collect() + expect_migration(xg3, "xg3") + + chem <- locs %>% get_chem(watina, "1/1/2017") %>% collect() + expect_migration(chem, "chem") + }) +}) + +test_that("get_locs works with different filters and dwh settings", { + suppressWarnings({ + file_names <- c( + "locs_area_codes", + "locs_bbox", + "locs_mask", + "locs_filterdepth_guess", + "locs_filterdepth_na" + ) + announce_files_migration(file_names) + + skip_if(getOption("test.skip_dwh_migration")) + watina <- fetch_watina_connection() + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + area_codes = c("KAL", "ZWA") + ) + expect_migration(locs, "locs_area_codes") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + bbox = c(xmin = 1.4e+5, xmax = 1.7e+5, ymin = 1.6e+5, ymax = 1.9e+5) + ) + expect_migration(locs, "locs_bbox") + + wfs_url <- "https://geo.api.vlaanderen.be/VRBG/wfs" %>% + httr2::request() %>% + httr2::req_url_query( + request = "GetFeature", + typeName = "VRBG:Refprv", + cql_filter = "NAAM='West-Vlaanderen'", + srsName = "EPSG:31370", + outputFormat = "text/xml; subtype=gml/3.1.1" + ) + mymask <- sf::read_sf(wfs_url$url, crs = 31370) %>% + sf::st_cast("GEOMETRYCOLLECTION") + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + mask = mymask, + buffer = 0, + collect = TRUE + ) + expect_migration(locs, "locs_mask") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_guess = TRUE + ) + expect_migration(locs, "locs_filterdepth_guess") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE + ) + expect_migration(locs, "locs_filterdepth_na") + }) +}) + +test_that("get_locs applies different aggregation logic correctly with dwh settings", { + suppressWarnings({ + file_names <- c( + "locs_obswell_aggr_latest", + "locs_obswell_aggr_latest_fd", + "locs_obswell_aggr_latest_sso", + "locs_obswell_aggr_mean" + ) + announce_files_migration(file_names) + + skip_if(getOption("test.skip_dwh_migration")) + watina <- fetch_watina_connection() + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_migration(locs, "locs_obswell_aggr_latest") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest_fd" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_migration(locs, "locs_obswell_aggr_latest_fd") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest_sso" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_migration(locs, "locs_obswell_aggr_latest_sso") + + locs <- get_locs( + watina, + loc_vec = testing_locations, + loc_validity = testing_validity, + loc_type = testing_types, + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "mean" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_migration(locs, "locs_obswell_aggr_mean") + }) +}) diff --git a/tests/testthat/test-get.R b/tests/testthat/test-get.R index 4fcd71e..937f16e 100644 --- a/tests/testthat/test-get.R +++ b/tests/testthat/test-get.R @@ -89,7 +89,13 @@ test_that("get_locs applies spatial queries correctly", { mymask <- sf::read_sf(wfs_url$url, crs = 31370) %>% sf::st_cast("GEOMETRYCOLLECTION") - locs <- get_locs(watina, loc_validity = "VLD", mask = mymask, buffer = 0, collect = TRUE) + locs <- get_locs( + watina, + loc_validity = "VLD", + mask = mymask, + buffer = 0, + collect = TRUE + ) expect_locs(locs, "mask") }) }) @@ -352,198 +358,3 @@ test_that("get_chem output matches exactly during extensive evaluation", { expect_chem(chem, "all_20170101") }) }) - -# DWH MIGRATION TEST ----------------------------------------------------------- -test_that("Test to evaluate DWH migration", { - suppressWarnings({ - file_names <- c( - "all", - "all_obswells" - ) - announce_files_locs(file_names) - - skip_if(getOption("test.skip_dwh_migration")) - watina <- fetch_watina_connection() - - # Selected locations for DWH migration testing: - # - location is locked (Status = 'afgesloten') - # - with a sufficient amount of observations (COUNT(peilpunten) >= 1000) - testing_locations <- c( - "BLAP028", - "BOBP020", - "BGNP008", - "BGNP009", - "BGNP011", - "BGNP012", - "BGNP020", - "BGNP021", - "BGNP025", - "BGNP028", - "BGNP031", - "BGNP035", - "BGNP036", - "CABP005", - "BRSP005", - "DUNS002", - "DUNS003", - "DURP004", - "GRMP013", - "GWZP010", - "IJSP032", - "KAMP002", - "KAMP041", - "KAMP206", - "KAMS021", - "KALP144", - "KALP154", - "KRGP038", - "KRGP039", - "POLP002", - "POLP006", - "KBRP128", - "KBRS003", - "KBRS007", - "KBRS009", - "UKPP025", - "VLBP021", - "VLBP023", - "VLBS004", - "ZSCP122", - "ZSCP132", - "ZSCP133", - "ZWAS232" - ) - # DWH W0002_10_Watina has only validity VLD - testing_validity <- c("VLD") - # Include all loc_types - testing_types <- c("P", "S", "R", "N", "W", "D", "L", "B") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - area_codes = c("KAL", "ZWA") - ) - expect_migration(locs, "locs_area_codes") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - bbox = c(xmin = 1.4e+5, xmax = 1.7e+5, ymin = 1.6e+5, ymax = 1.9e+5) - ) - expect_migration(locs, "locs_bbox") - - wfs_url <- "https://geo.api.vlaanderen.be/VRBG/wfs" %>% - httr2::request() %>% - httr2::req_url_query( - request = "GetFeature", - typeName = "VRBG:Refprv", - cql_filter = "NAAM='West-Vlaanderen'", - srsName = "EPSG:31370", - outputFormat = "text/xml; subtype=gml/3.1.1" - ) - mymask <- sf::read_sf(wfs_url$url, crs = 31370) %>% - sf::st_cast("GEOMETRYCOLLECTION") - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - mask = mymask, - buffer = 0 - ) - expect_migration(locs, "locs_mask") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - filterdepth_guess = TRUE - ) - expect_migration(locs, "locs_filterdepth_guess") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - filterdepth_na = TRUE - ) - expect_migration(locs, "locs_filterdepth_na") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - filterdepth_na = TRUE, - filterdepth_guess = TRUE, - obswell_aggr = "latest" - ) %>% - select(loc_code, contains("ost"), contains("filterdepth")) - expect_migration(locs, "locs_obswell_aggr_latest") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - filterdepth_na = TRUE, - filterdepth_guess = TRUE, - obswell_aggr = "latest_fd" - ) %>% - select(loc_code, contains("ost"), contains("filterdepth")) - expect_migration(locs, "locs_obswell_aggr_latest_fd") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - filterdepth_na = TRUE, - filterdepth_guess = TRUE, - obswell_aggr = "latest_sso" - ) %>% - select(loc_code, contains("ost"), contains("filterdepth")) - expect_migration(locs, "locs_obswell_aggr_latest_sso") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - filterdepth_na = TRUE, - filterdepth_guess = TRUE, - obswell_aggr = "mean" - ) %>% - select(loc_code, contains("ost"), contains("filterdepth")) - expect_migration(locs, "locs_obswell_aggr_mean") - - locs <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types - ) - expect_migration(locs, "locs") - - obswells <- get_locs( - watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, - obswells = TRUE - ) - expect_migration(obswells, "obswells") - - xg3 <- locs %>% get_xg3(watina, 2010) %>% collect() - expect_migration(xg3, "xg3") - - chem <- locs %>% get_chem(watina, "1/1/2017") %>% collect() - expect_migration(chem, "chem") - }) -}) From 1f06f04e9417c09d7f738a54a81b2475d86cc9ca Mon Sep 17 00:00:00 2001 From: Droomelot De Gendt Date: Tue, 14 Jul 2026 17:58:57 +0200 Subject: [PATCH 3/3] test(dwh-migration): add variables to helper file --- tests/testthat/README.md | 2 +- tests/testthat/{helper-get.R => helper.R} | 107 ++++++++++++++----- tests/testthat/test-dwh-migration.R | 124 +++++++--------------- 3 files changed, 120 insertions(+), 113 deletions(-) rename tests/testthat/{helper-get.R => helper.R} (61%) diff --git a/tests/testthat/README.md b/tests/testthat/README.md index 0fdf141..eb81b5b 100644 --- a/tests/testthat/README.md +++ b/tests/testthat/README.md @@ -38,7 +38,7 @@ Or, if you are verifying a data warehouse migration, run the migration tests: devtools::test(filter = "dwh-migration") ``` -This will create local snapshot files that are stored in `tests/testthat/_snaps`. +The tests will create local snapshot files that are stored in `tests/testthat/_snaps`. ### 3. Modify your code diff --git a/tests/testthat/helper-get.R b/tests/testthat/helper.R similarity index 61% rename from tests/testthat/helper-get.R rename to tests/testthat/helper.R index ce17818..e3e0c05 100644 --- a/tests/testthat/helper-get.R +++ b/tests/testthat/helper.R @@ -1,3 +1,4 @@ +# Watina connection for testing ------------------------------------------------ fetch_watina_connection <- function() { skip_if_not( exists("test_con", envir = .GlobalEnv), @@ -10,34 +11,13 @@ fetch_watina_connection <- function() { return(get("test_con", envir = .GlobalEnv)) } +# Clean up snapshot files ------------------------------------------------------ create_file_name <- function(function_name, test_name) { file_end <- "data.csv" paste0(function_name, "_", test_name, "_", file_end) } -announce_files <- function(file_names, function_name) { - for (f in file_names) { - announce_snapshot_file(name = create_file_name(function_name, f)) - } -} - -announce_files_locs <- function(file_names) { - announce_files(file_names, "locs") -} - -announce_files_xg3 <- function(file_names) { - announce_files(file_names, "xg3") -} - -announce_files_chem <- function(file_names) { - announce_files(file_names, "chem") -} - -announce_files_migration <- function(file_names) { - announce_files(file_names, "dwh_migration") -} - clean_up_table <- function(table) { floor_0 <- c( "x", @@ -75,13 +55,34 @@ clean_up_table <- function(table) { return(table) } -write_file <- function(path, table) { - write.csv(clean_up_table(table), path, row.names = FALSE) +# Announce snapshot files ------------------------------------------------------ +# Assure snapshot files are not deleted when tests are skipped +announce_files <- function(file_names, function_name) { + for (f in file_names) { + announce_snapshot_file(name = create_file_name(function_name, f)) + } +} + +announce_files_locs <- function(file_names) { + announce_files(file_names, "locs") +} + +announce_files_xg3 <- function(file_names) { + announce_files(file_names, "xg3") +} + +announce_files_chem <- function(file_names) { + announce_files(file_names, "chem") } +announce_files_migration <- function(file_names) { + announce_files(file_names, "dwh_migration") +} + +# Expect snapshot tests -------------------------------------------------------- expect_data <- function(data, function_name, test_name) { path <- tempfile(fileext = ".csv") - write_file(path, data) + write.csv(clean_up_table(data), path, row.names = FALSE) expect_snapshot_file(path, create_file_name(function_name, test_name)) } @@ -100,3 +101,59 @@ expect_chem <- function(chem, test_name) { expect_migration <- function(data, test_name) { expect_data(data, "dwh_migration", test_name) } + +# Settings for DWH migration tests --------------------------------------------- +# Selected locations for DWH migration testing: +# - location is locked (Status = 'afgesloten') +# - with a sufficient amount of observations (COUNT(peilpunten) >= 1000) +dwh_test_locations <- c( + "BLAP028", + "BOBP020", + "BGNP008", + "BGNP009", + "BGNP011", + "BGNP012", + "BGNP020", + "BGNP021", + "BGNP025", + "BGNP028", + "BGNP031", + "BGNP035", + "BGNP036", + "CABP005", + "BRSP005", + "DUNS002", + "DUNS003", + "DURP004", + "GRMP013", + "GWZP010", + "IJSP032", + "KAMP002", + "KAMP041", + "KAMP206", + "KAMS021", + "KALP144", + "KALP154", + "KRGP038", + "KRGP039", + "POLP002", + "POLP006", + "KBRP128", + "KBRS003", + "KBRS007", + "KBRS009", + "UKPP025", + "VLBP021", + "VLBP023", + "VLBS004", + "ZSCP122", + "ZSCP132", + "ZSCP133", + "ZWAS232" +) + +# DWH W0002_10_Watina has only validity VLD +dwh_test_validity <- c("VLD") +# Include all loc_types +dwh_test_types <- c("P", "S", "R", "N", "W", "D", "L", "B") + diff --git a/tests/testthat/test-dwh-migration.R b/tests/testthat/test-dwh-migration.R index 36de0ef..d0683c9 100644 --- a/tests/testthat/test-dwh-migration.R +++ b/tests/testthat/test-dwh-migration.R @@ -1,57 +1,7 @@ -# DWH MIGRATION TEST ----------------------------------------------------------- -# Selected locations for DWH migration testing: -# - location is locked (Status = 'afgesloten') -# - with a sufficient amount of observations (COUNT(peilpunten) >= 1000) -testing_locations <- c( - "BLAP028", - "BOBP020", - "BGNP008", - "BGNP009", - "BGNP011", - "BGNP012", - "BGNP020", - "BGNP021", - "BGNP025", - "BGNP028", - "BGNP031", - "BGNP035", - "BGNP036", - "CABP005", - "BRSP005", - "DUNS002", - "DUNS003", - "DURP004", - "GRMP013", - "GWZP010", - "IJSP032", - "KAMP002", - "KAMP041", - "KAMP206", - "KAMS021", - "KALP144", - "KALP154", - "KRGP038", - "KRGP039", - "POLP002", - "POLP006", - "KBRP128", - "KBRS003", - "KBRS007", - "KBRS009", - "UKPP025", - "VLBP021", - "VLBP023", - "VLBS004", - "ZSCP122", - "ZSCP132", - "ZSCP133", - "ZWAS232" -) - -# DWH W0002_10_Watina has only validity VLD -testing_validity <- c("VLD") -# Include all loc_types -testing_types <- c("P", "S", "R", "N", "W", "D", "L", "B") +# DEVELOPER NOTE: +# Snapshots generated by the following tests can contain sensitive data and are +# therefore only stored locally via gitignore in the folder _snaps/. See the +# testing README for the recommended workflow. test_that("get_locs, get_xg3 and get_chem work with default filters and dwh settings", { suppressWarnings({ @@ -68,17 +18,17 @@ test_that("get_locs, get_xg3 and get_chem work with default filters and dwh sett locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types ) expect_migration(locs, "locs") obswells <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, obswells = TRUE ) expect_migration(obswells, "obswells") @@ -107,18 +57,18 @@ test_that("get_locs works with different filters and dwh settings", { locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, area_codes = c("KAL", "ZWA") ) expect_migration(locs, "locs_area_codes") locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, bbox = c(xmin = 1.4e+5, xmax = 1.7e+5, ymin = 1.6e+5, ymax = 1.9e+5) ) expect_migration(locs, "locs_bbox") @@ -136,9 +86,9 @@ test_that("get_locs works with different filters and dwh settings", { sf::st_cast("GEOMETRYCOLLECTION") locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, mask = mymask, buffer = 0, collect = TRUE @@ -147,18 +97,18 @@ test_that("get_locs works with different filters and dwh settings", { locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, filterdepth_guess = TRUE ) expect_migration(locs, "locs_filterdepth_guess") locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, filterdepth_na = TRUE ) expect_migration(locs, "locs_filterdepth_na") @@ -180,9 +130,9 @@ test_that("get_locs applies different aggregation logic correctly with dwh setti locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, filterdepth_na = TRUE, filterdepth_guess = TRUE, obswell_aggr = "latest" @@ -192,9 +142,9 @@ test_that("get_locs applies different aggregation logic correctly with dwh setti locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, filterdepth_na = TRUE, filterdepth_guess = TRUE, obswell_aggr = "latest_fd" @@ -204,9 +154,9 @@ test_that("get_locs applies different aggregation logic correctly with dwh setti locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, filterdepth_na = TRUE, filterdepth_guess = TRUE, obswell_aggr = "latest_sso" @@ -216,9 +166,9 @@ test_that("get_locs applies different aggregation logic correctly with dwh setti locs <- get_locs( watina, - loc_vec = testing_locations, - loc_validity = testing_validity, - loc_type = testing_types, + loc_vec = dwh_test_locations, + loc_validity = dwh_test_validity, + loc_type = dwh_test_types, filterdepth_na = TRUE, filterdepth_guess = TRUE, obswell_aggr = "mean"