From f571dddebb3b0a2da2af123e74100501ea1dd57d Mon Sep 17 00:00:00 2001 From: Droomelot De Gendt Date: Fri, 3 Jul 2026 14:06:17 +0200 Subject: [PATCH 1/4] test: add testing setup for functions that have a database connection --- .gitignore | 4 + DESCRIPTION | 2 + tests/testthat.R | 12 ++ tests/testthat/README.md | 58 ++++++ tests/testthat/setup.R | 2 + tests/testthat/test-get.R | 367 ++++++++++++++++++++++++++++++++++++++ 6 files changed, 445 insertions(+) create mode 100644 tests/testthat.R create mode 100644 tests/testthat/README.md create mode 100644 tests/testthat/setup.R create mode 100644 tests/testthat/test-get.R diff --git a/.gitignore b/.gitignore index 7cc3a87..48ffc95 100644 --- a/.gitignore +++ b/.gitignore @@ -39,6 +39,10 @@ rsconnect/ # pkgdown website is built by travis on gh-pages /docs/ +# testing snapshots created for local testing +/tests/testthat/_snaps/* + # Mac OS X .DS_Store inst/doc +.positai diff --git a/DESCRIPTION b/DESCRIPTION index 1f250df..d5d8329 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -38,6 +38,7 @@ Suggests: rmarkdown, scales, sf, + testthat (>= 3.0.0), tibble, tidyselect Remotes: @@ -46,3 +47,4 @@ LazyData: true Encoding: UTF-8 RoxygenNote: 7.3.3 VignetteBuilder: knitr +Config/testthat/edition: 3 diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..796a5ff --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(watina) + +test_check("watina") diff --git a/tests/testthat/README.md b/tests/testthat/README.md new file mode 100644 index 0000000..002e3fa --- /dev/null +++ b/tests/testthat/README.md @@ -0,0 +1,58 @@ +## Welcome + +First of all, thank you for writing or reviewing tests for `watina`! 👍 Having a strong, automated fallback safety net makes it much more secure for us to perform codebase changes. 😊 + +## Why these snapshots are not in Git 🔒 + +The `watina` package interacts heavily with the internal *Watina data warehouse* at INBO. Because the data retrieved via these queries can be confidential, **all generated test snapshot files (`_snaps/`) must never be committed to GitHub**. + +Our `.gitignore` is configured to keep all generated snapshot data files completely local to your machine. This prevents accidental data leaks in this public repository. + +## Snapshot Testing Workflow 🔄 + +Whether you are reviewing someone else's pull request or developing a feature yourself, the strategy is identical: you generate a local baseline from a stable state of the code and compare it against your changes. + +Since untracked local snapshot files persist across git branch switches, you can leverage testthat to automatically validate different versions of your code. + +### 1. Set up a database connection + +Create a database connection with the variable name 'watina_test_con'. If this variable is not found, the snapshot tests will be skipped. + +``` r +watina_test_con <- connect_watina() +``` + +### 1. Set up your ground truth baseline + +*When reviewing a PR, switch to the stable main branch (`git switch main`).* + +Run the snapshot tests: + +``` r +devtools::test(filter = "get") +``` + +This will create local snapshot files that are stored in tests/testthat/\_snaps. + +### 2. Modify your code + +Switch to your feature branch if you're reviewing a PR or apply your changes when developing a feature. + +### 3. Compare to the baseline + +Execute the test code with the applied changes: + +``` r +devtools::test(filter = "get") +``` + +**If the tests pass**: The data generated by the modified code is a perfect structural match with your baseline. + +**If the tests fail**: testthat will automatically open a Shiny app displaying a row-by-row visual diff highlighting any changes. You can decide to **accept** (if it were expected changes) or **decline** (if it were unintended changes). If you decline, alter your code to assure the output remains unchanged. + +## Testing Configuration + +To keep local development fast, the testing setup includes two boolean flags that act as manual on/off switches: + +- **SKIP_SNAPSHOT_TESTS**: Set to TRUE when working on non-database features (like documentation, evaluation or plot functions) to make devtools::test() complete instantly. Set to FALSE when you need to test database logic. +- **SKIP_DATA_VALIDATION_TESTS**: Controls the execution of extensive validation checks (e.g., retrieving all historical rows). Leave this set to TRUE for day-to-day work, and only switch it to FALSE when finalizing a major data warehouse migration to verify absolute database parity. diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R new file mode 100644 index 0000000..7e069bb --- /dev/null +++ b/tests/testthat/setup.R @@ -0,0 +1,2 @@ +SKIP_DATA_VALIDATION_TESTS = FALSE +SKIP_SNAPSHOT_TESTS = FALSE diff --git a/tests/testthat/test-get.R b/tests/testthat/test-get.R new file mode 100644 index 0000000..7de4171 --- /dev/null +++ b/tests/testthat/test-get.R @@ -0,0 +1,367 @@ +# 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. + +# HELPER FUNCTIONS ------------------------------------------------------------- +create_file_name <- function(function_name, test_name) { + file_end <- "data.csv" + + paste0(function_name, "_", test_name, "_", file_end) +} + +clean_up_table <- function(table) { + floor_0 <- c( + "x", + "y" + ) + round_2 <- c( + "soilsurf_ost", + "measuringref_ost", + "tubelength", + "filterlength", + "filterdepth" + ) + + floor_0 <- intersect(floor_0, colnames(table)) + round_2 <- intersect(round_2, colnames(table)) + + table <- table %>% + # Primary keys can change in DWH (exclude from comparison) + select(-ends_with("_wid")) %>% + mutate( + # Round to only view big numerical changes in comparison view + across(all_of(floor_0), floor), + across(all_of(round_2), ~ round(.x, digits = 2)) + ) %>% + # Order to ease comparison view + arrange( + pick(ends_with("_code")), + pick(ends_with("year")), + pick(ends_with("_ost")), + pick(ends_with("_lcl")), + pick(ends_with("_variable")) + ) + + return(table) +} + +write_file <- function(path, table) { + write.csv(clean_up_table(table), path, row.names = FALSE) +} + +test_data <- function(data, function_name, test_name) { + path <- tempfile(fileext = ".csv") + write_file(path, data) + expect_snapshot_file(path, create_file_name(function_name, test_name)) +} + +# TEST ------------------------------------------------------------------------- +test_that("Test different filters get_locs", { + suppressWarnings({ + file_names <- c( + "KAL_ZWA_locations", + "KAL_ZWA_observation_wells", + "bbox", + "area_codes", + "area_codes_loc_type", + "loc_validity", + "filterdepth_guess", + "filterdepth_na", + "loc_vec", + "obswells", + "obswell_aggr_latest", + "obswell_aggr_latest_fd", + "obswell_aggr_latest_sso", + "obswell_aggr_mean", + "mask", + "all", + "all_obswells" + ) + + for (f in file_names) { + announce_snapshot_file(name = create_file_name("locs", f)) + } + skip_if(SKIP_SNAPSHOT_TESTS) + skip_if_not( + exists("watina_test_con"), + message = "Geen actieve database connectie gevonden." + ) + + test_locs <- function(locs, test_name) { + test_data(locs, "locs", test_name) + } + + watina <- watina_test_con + + locs <- get_locs(watina, area_codes = c("KAL", "ZWA"), loc_validity = "VLD") + test_locs(locs, "KAL_ZWA_locations") + + locs <- get_locs( + watina, + area_codes = c("KAL", "ZWA"), + loc_validity = "VLD", + obswells = TRUE + ) + test_locs(locs, "KAL_ZWA_observation_wells") + + bbox <- c(xmin = 1.4e+5, xmax = 1.7e+5, ymin = 1.6e+5, ymax = 1.9e+5) + locs <- get_locs(watina, bbox = bbox) + test_locs(locs, "bbox") + + locs <- get_locs(watina, area_codes = c("KAL", "KBR")) + test_locs(locs, "area_codes") + + locs <- get_locs( + watina, + area_codes = c("KAL", "KBR"), + loc_type = c("P", "S") + ) + test_locs(locs, "area_codes_loc_type") + + locs <- get_locs( + watina, + loc_validity = c("ENT", "DEL", "CLD"), + loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") + ) + test_locs(locs, "loc_validity") + + locs <- get_locs(watina, area_codes = "WES", filterdepth_guess = TRUE) + test_locs(locs, "filterdepth_guess") + + locs <- get_locs( + watina, + area_codes = c("KAL", "KBR"), + loc_type = c("P", "S"), + filterdepth_na = TRUE + ) + test_locs(locs, "filterdepth_na") + + locs <- get_locs( + watina, + loc_vec = c("KBRP081", "KBRP090", "KBRP095", "KBRS001") + ) + test_locs(locs, "loc_vec") + + locs <- get_locs( + watina, + obswells = TRUE, + area_codes = c("KAL", "KBR"), + loc_type = c("P", "S") + ) + test_locs(locs, "obswells") + + locs <- get_locs( + watina, + area_codes = "WES", + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + test_locs(locs, "obswell_aggr_latest") + + locs <- get_locs( + watina, + area_codes = "WES", + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest_fd" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + test_locs(locs, "obswell_aggr_latest_fd") + + locs <- get_locs( + watina, + area_codes = "WES", + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest_sso" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + test_locs(locs, "obswell_aggr_latest_sso") + + locs <- get_locs( + watina, + area_codes = "WES", + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "mean" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + test_locs(locs, "obswell_aggr_mean") + + mymask <- + "https://geo.api.vlaanderen.be/VRBG/wfs" %>% + httr::parse_url() %>% + purrr::list_merge( + query = list( + request = "GetFeature", + typeName = "VRBG:Refprv", + cql_filter = "NAAM='West-Vlaanderen'", + srsName = "EPSG:31370", + outputFormat = "text/xml; subtype=gml/3.1.1" + ) + ) %>% + httr::build_url() %>% + sf::read_sf(crs = 31370) %>% + sf::st_cast("GEOMETRYCOLLECTION") + locs <- get_locs(watina, loc_validity = "VLD", mask = mymask, buffer = 0) + test_locs(locs, "mask") + + skip_if(SKIP_DATA_VALIDATION_TESTS) + + # Extensive test - all rows + locs <- get_locs( + watina, + loc_validity = c("VLD"), + loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") + ) + test_locs(locs, "all") + + # Extensive test - all rows in observations + locs <- get_locs( + watina, + obswells = TRUE, + loc_validity = c("VLD"), + loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") + ) + test_locs(locs, "all_obswells") + }) +}) + +test_that("Test different filters get_xg3", { + suppressWarnings({ + file_names <- c( + "KAL_2010", + "KAL_2010_ostend", + "all_2010" + ) + + for (f in file_names) { + announce_snapshot_file(name = create_file_name("xg3", f)) + } + skip_if(SKIP_SNAPSHOT_TESTS) + skip_if_not( + exists("watina_test_con"), + message = "Geen actieve database connectie gevonden." + ) + + test_xg3 <- function(xg3, test_name) { + test_data(xg3, "xg3", test_name) + } + + watina <- watina_test_con + + locs <- get_locs(watina, area_codes = "KAL") + xg3 <- locs %>% get_xg3(watina, 2010) %>% collect() + test_xg3(xg3, "KAL_2010") + + xg3 <- locs %>% get_xg3(watina, 2010, vert_crs = "ostend") %>% collect() + test_xg3(xg3, "KAL_2010_ostend") + + skip_if(SKIP_DATA_VALIDATION_TESTS) + + # Extensive test - all rows + locs <- get_locs( + watina, + loc_validity = c("VLD"), + loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") + ) + xg3 <- locs %>% get_xg3(watina, 2010) %>% collect() + test_xg3(xg3, "all_2010") + }) +}) + +test_that("Test different filters get_chem", { + suppressWarnings({ + file_names <- c( + "ZWA", + "ZWA_eq", + "ZWA_thresholdNA", + "ZWA_excludeNA", + "ZWA_thresholdNA_excludeNA", + "ZWA_range", + "all_20170101", + ) + + for (f in file_names) { + announce_snapshot_file(name = create_file_name("chem", f)) + } + skip_if(SKIP_SNAPSHOT_TESTS) + skip_if_not( + exists("watina_test_con"), + message = "Geen actieve database connectie gevonden." + ) + + test_chem <- function(chem, test_name) { + test_data(chem, "chem", test_name) + } + + watina <- watina_test_con + + locs <- get_locs(watina, area_codes = "ZWA") + + chem <- locs %>% + get_chem(watina, "1/1/2017", enddate = "31-12-2018") %>% + collect() + test_chem(chem, "ZWA") + + chem <- locs %>% + get_chem(watina, "1/1/2017", enddate = "31-12-2018", conc_type = "eq") %>% + collect() + test_chem(chem, "ZWA_eq") + + chem <- locs %>% + get_chem( + watina, + "1/1/2017", + enddate = "31-12-2018", + en_fecond_threshold = NA + ) %>% + collect() + test_chem(chem, "ZWA_thresholdNA") + + chem <- locs %>% + get_chem( + watina, + "1/1/2017", + enddate = "31-12-2018", + en_exclude_na = TRUE + ) %>% + collect() + test_chem(chem, "ZWA_excludeNA") + + chem <- locs %>% + get_chem( + watina, + "1/1/2017", + enddate = "31-12-2018", + en_exclude_na = TRUE, + en_fecond_threshold = NA + ) %>% + collect() + test_chem(chem, "ZWA_thresholdNA_excludeNA") + + chem <- locs %>% + get_chem( + watina, + "1/1/2017", + enddate = "31-12-2018", + en_range = c(-1, 1) + ) %>% + collect() + test_chem(chem, "ZWA_range") + + skip_if(SKIP_DATA_VALIDATION_TESTS) + + # Extensive test - all rows + locs <- get_locs( + watina, + loc_validity = c("VLD"), + loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") + ) + chem <- locs %>% get_chem(watina, "1/1/2017") %>% collect() + test_chem(chem, "all_20170101") + }) +}) From 0449feaab49ac7ab118f2b3ca4a71d043d300e06 Mon Sep 17 00:00:00 2001 From: Droomelot De Gendt Date: Fri, 3 Jul 2026 14:14:42 +0200 Subject: [PATCH 2/4] fix(get.R, get_chem): replace raw SQL filter with native dbpyr syntax to make it compatible with newer dbplyr versions --- DESCRIPTION | 1 + R/get.R | 16 ++++------------ 2 files changed, 5 insertions(+), 12 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d5d8329..06ca8d7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,6 +23,7 @@ Depends: Imports: assertthat, dplyr, + dbplyr (>= 2.3.4), inbodb, lubridate, rlang, diff --git a/R/get.R b/R/get.R index 671f945..c279e6a 100644 --- a/R/get.R +++ b/R/get.R @@ -1414,14 +1414,6 @@ get_chem <- function(locs, ) ) - sqlstring_en <- - paste0( - "elneutr BETWEEN ", - en_range[1], - " AND ", - en_range[2] - ) - # preparing for the application of the en_fecond_threshold: if (!is.na(en_fecond_threshold) & !is.null(en_fecond_threshold)) { if (any( @@ -1476,7 +1468,7 @@ get_chem <- function(locs, # I.1 applying the en_range condition: chem %>% filter( - (!is.na(.data$elneutr) & sql(sqlstring_en)) | + (!is.na(.data$elneutr) & between(.data$elneutr, !!en_range[1], !!en_range[2])) | .data$provide_eq_unit == "FALSE" ) } else { @@ -1484,7 +1476,7 @@ get_chem <- function(locs, chem %>% left_join(samples_fecond, by = "lab_sample_id") %>% filter( - (!is.na(.data$elneutr) & sql(sqlstring_en)) | + (!is.na(.data$elneutr) & between(.data$elneutr, !!en_range[1], !!en_range[2])) | .data$fecond >= en_fecond_threshold | .data$provide_eq_unit == "FALSE" ) %>% @@ -1497,7 +1489,7 @@ get_chem <- function(locs, chem %>% filter( is.na(.data$elneutr) | - sql(sqlstring_en) | + between(.data$elneutr, !!en_range[1], !!en_range[2]) | .data$provide_eq_unit == "FALSE" ) } else { @@ -1506,7 +1498,7 @@ get_chem <- function(locs, left_join(samples_fecond, by = "lab_sample_id") %>% filter( is.na(.data$elneutr) | - sql(sqlstring_en) | + between(.data$elneutr, !!en_range[1], !!en_range[2]) | .data$fecond >= en_fecond_threshold | .data$provide_eq_unit == "FALSE" ) %>% From 863929d2303faf7dbcb374f94df706758ca476da Mon Sep 17 00:00:00 2001 From: Droomelot De Gendt Date: Fri, 3 Jul 2026 14:48:39 +0200 Subject: [PATCH 3/4] build(get.R): add all necessary dependencies to function documentation, DESCRIPTION and NAMESPACE --- DESCRIPTION | 3 ++- NAMESPACE | 2 ++ R/get.R | 2 ++ tests/testthat/setup.R | 4 ++-- tests/testthat/test-get.R | 2 +- 5 files changed, 9 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 06ca8d7..861536b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,6 +33,7 @@ Imports: Suggests: DBI, ggplot2, + httr, knitr, KSgeneral, purrr, @@ -46,6 +47,6 @@ Remotes: inbo/inbodb LazyData: true Encoding: UTF-8 -RoxygenNote: 7.3.3 VignetteBuilder: knitr Config/testthat/edition: 3 +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 9435cea..e7936bd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,10 +23,12 @@ importFrom(assertthat,is.flag) importFrom(assertthat,is.number) importFrom(assertthat,is.string) importFrom(assertthat,noNA) +importFrom(dbplyr,.sql) importFrom(dplyr,"%>%") importFrom(dplyr,anti_join) importFrom(dplyr,arrange) importFrom(dplyr,as_tibble) +importFrom(dplyr,between) importFrom(dplyr,bind_cols) importFrom(dplyr,collect) importFrom(dplyr,contains) diff --git a/R/get.R b/R/get.R index c279e6a..9eda32a 100644 --- a/R/get.R +++ b/R/get.R @@ -1243,6 +1243,8 @@ get_xg3 <- function(locs, #' distinct #' sql #' rename +#' between +#' @importFrom dbplyr .sql get_chem <- function(locs, con, startdate, diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 7e069bb..f7324d5 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -1,2 +1,2 @@ -SKIP_DATA_VALIDATION_TESTS = FALSE -SKIP_SNAPSHOT_TESTS = FALSE +SKIP_DATA_VALIDATION_TESTS = TRUE +SKIP_SNAPSHOT_TESTS = TRUE diff --git a/tests/testthat/test-get.R b/tests/testthat/test-get.R index 7de4171..ddad3e8 100644 --- a/tests/testthat/test-get.R +++ b/tests/testthat/test-get.R @@ -282,7 +282,7 @@ test_that("Test different filters get_chem", { "ZWA_excludeNA", "ZWA_thresholdNA_excludeNA", "ZWA_range", - "all_20170101", + "all_20170101" ) for (f in file_names) { From 7b9e665f34e46fb6072f51e59887997271b97e98 Mon Sep 17 00:00:00 2001 From: Droomelot De Gendt Date: Mon, 13 Jul 2026 15:48:12 +0200 Subject: [PATCH 4/4] test(get_locs): create testing helper file --- .Rprofile | 7 + DESCRIPTION | 6 +- NAMESPACE | 1 - R/get.R | 1 - tests/testthat/README.md | 34 +++- tests/testthat/helper-get.R | 92 ++++++++++ tests/testthat/setup.R | 12 +- tests/testthat/test-get.R | 331 +++++++++++++++++------------------- 8 files changed, 296 insertions(+), 188 deletions(-) create mode 100644 .Rprofile create mode 100644 tests/testthat/helper-get.R diff --git a/.Rprofile b/.Rprofile new file mode 100644 index 0000000..1c39bc8 --- /dev/null +++ b/.Rprofile @@ -0,0 +1,7 @@ +options(test.run_snapshot = FALSE) +options(test.run_data_validation = 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("ℹī¸ See the testing README for more information.") diff --git a/DESCRIPTION b/DESCRIPTION index 861536b..26e5339 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,7 +23,6 @@ Depends: Imports: assertthat, dplyr, - dbplyr (>= 2.3.4), inbodb, lubridate, rlang, @@ -33,7 +32,7 @@ Imports: Suggests: DBI, ggplot2, - httr, + httr2, knitr, KSgeneral, purrr, @@ -42,7 +41,8 @@ Suggests: sf, testthat (>= 3.0.0), tibble, - tidyselect + tidyselect, + withr Remotes: inbo/inbodb LazyData: true diff --git a/NAMESPACE b/NAMESPACE index e7936bd..47dea1a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,7 +23,6 @@ importFrom(assertthat,is.flag) importFrom(assertthat,is.number) importFrom(assertthat,is.string) importFrom(assertthat,noNA) -importFrom(dbplyr,.sql) importFrom(dplyr,"%>%") importFrom(dplyr,anti_join) importFrom(dplyr,arrange) diff --git a/R/get.R b/R/get.R index 9eda32a..23e835f 100644 --- a/R/get.R +++ b/R/get.R @@ -1244,7 +1244,6 @@ get_xg3 <- function(locs, #' sql #' rename #' between -#' @importFrom dbplyr .sql get_chem <- function(locs, con, startdate, diff --git a/tests/testthat/README.md b/tests/testthat/README.md index 002e3fa..8ad7486 100644 --- a/tests/testthat/README.md +++ b/tests/testthat/README.md @@ -16,13 +16,13 @@ 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 'watina_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 -watina_test_con <- connect_watina() +test_con <- connect_watina() ``` -### 1. Set up your ground truth baseline +### 2. Set up your ground truth baseline *When reviewing a PR, switch to the stable main branch (`git switch main`).* @@ -34,11 +34,11 @@ devtools::test(filter = "get") This will create local snapshot files that are stored in tests/testthat/\_snaps. -### 2. Modify your code +### 3. Modify your code Switch to your feature branch if you're reviewing a PR or apply your changes when developing a feature. -### 3. Compare to the baseline +### 4. Compare to the baseline Execute the test code with the applied changes: @@ -50,9 +50,25 @@ devtools::test(filter = "get") **If the tests fail**: testthat will automatically open a Shiny app displaying a row-by-row visual diff highlighting any changes. You can decide to **accept** (if it were expected changes) or **decline** (if it were unintended changes). If you decline, alter your code to assure the output remains unchanged. -## Testing Configuration +## Testing Configuration ⚙ī¸ -To keep local development fast, the testing setup includes two boolean flags that act as manual on/off switches: +Testing behavior is managed dynamically through R session `options()`. When you open the project, your `.Rprofile` automatically initializes them. -- **SKIP_SNAPSHOT_TESTS**: Set to TRUE when working on non-database features (like documentation, evaluation or plot functions) to make devtools::test() complete instantly. Set to FALSE when you need to test database logic. -- **SKIP_DATA_VALIDATION_TESTS**: Controls the execution of extensive validation checks (e.g., retrieving all historical rows). Leave this set to TRUE for day-to-day work, and only switch it to FALSE when finalizing a major data warehouse migration to verify absolute database parity. +- **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. + +You can flip these switches directly in your RStudio console at any time. Never modify the default settings in the `.Rprofile`! + +``` r +# Activate snapshot tests +options(test.run_snapshot = TRUE) + +# Activate extensive data validation tests +options(test.run_data_validation = TRUE) + +# Return to default mode +options(test.run_snapshot = FALSE) +options(test.run_data_validation = 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). diff --git a/tests/testthat/helper-get.R b/tests/testthat/helper-get.R new file mode 100644 index 0000000..26a9198 --- /dev/null +++ b/tests/testthat/helper-get.R @@ -0,0 +1,92 @@ +fetch_watina_connection <- function() { + skip_if_not( + exists("test_con", envir = .GlobalEnv), + message = paste0( + "No active database connection found. ", + "Create connection by executing 'test_con <- connect_watina()'." + ) + ) + + return(get("test_con", envir = .GlobalEnv)) +} + +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") +} + +clean_up_table <- function(table) { + floor_0 <- c( + "x", + "y" + ) + round_2 <- c( + "soilsurf_ost", + "measuringref_ost", + "tubelength", + "filterlength", + "filterdepth" + ) + + table <- table %>% + # Primary keys can change in DWH (exclude from comparison) + select(-ends_with("_wid")) %>% + mutate( + # Round to only view big numerical changes in comparison view + across(any_of(floor_0), floor), + across(any_of(round_2), \(x) round(x, digits = 2)) + ) %>% + # Order to ease comparison view + arrange( + pick( + ends_with("_code"), + ends_with("year"), + ends_with("_ost"), + ends_with("_lcl"), + ends_with("_variable") + ) + ) + + return(table) +} + +write_file <- function(path, table) { + write.csv(clean_up_table(table), path, row.names = FALSE) +} + +expect_data <- function(data, function_name, test_name) { + path <- tempfile(fileext = ".csv") + write_file(path, data) + expect_snapshot_file(path, create_file_name(function_name, test_name)) +} + +expect_locs <- function(locs, test_name) { + expect_data(locs, "locs", test_name) +} + +expect_xg3 <- function(xg3, test_name) { + expect_data(xg3, "xg3", test_name) +} + +expect_chem <- function(chem, test_name) { + expect_data(chem, "chem", test_name) +} diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index f7324d5..ec042bb 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -1,2 +1,10 @@ -SKIP_DATA_VALIDATION_TESTS = TRUE -SKIP_SNAPSHOT_TESTS = TRUE +withr::local_options( + list( + test.skip_snapshot = !(getOption("test.run_snapshot", default = FALSE)), + test.skip_data_validation = !(getOption( + "test.run_data_validation", + default = FALSE + )) + ), + .local_envir = testthat::teardown_env() +) diff --git a/tests/testthat/test-get.R b/tests/testthat/test-get.R index ddad3e8..adddc0f 100644 --- a/tests/testthat/test-get.R +++ b/tests/testthat/test-get.R @@ -3,99 +3,25 @@ # therefore only stored locally via gitignore in the folder _snaps/. See the # testing README for the recommended workflow. -# HELPER FUNCTIONS ------------------------------------------------------------- -create_file_name <- function(function_name, test_name) { - file_end <- "data.csv" - - paste0(function_name, "_", test_name, "_", file_end) -} - -clean_up_table <- function(table) { - floor_0 <- c( - "x", - "y" - ) - round_2 <- c( - "soilsurf_ost", - "measuringref_ost", - "tubelength", - "filterlength", - "filterdepth" - ) - - floor_0 <- intersect(floor_0, colnames(table)) - round_2 <- intersect(round_2, colnames(table)) - - table <- table %>% - # Primary keys can change in DWH (exclude from comparison) - select(-ends_with("_wid")) %>% - mutate( - # Round to only view big numerical changes in comparison view - across(all_of(floor_0), floor), - across(all_of(round_2), ~ round(.x, digits = 2)) - ) %>% - # Order to ease comparison view - arrange( - pick(ends_with("_code")), - pick(ends_with("year")), - pick(ends_with("_ost")), - pick(ends_with("_lcl")), - pick(ends_with("_variable")) - ) - - return(table) -} - -write_file <- function(path, table) { - write.csv(clean_up_table(table), path, row.names = FALSE) -} - -test_data <- function(data, function_name, test_name) { - path <- tempfile(fileext = ".csv") - write_file(path, data) - expect_snapshot_file(path, create_file_name(function_name, test_name)) -} - -# TEST ------------------------------------------------------------------------- -test_that("Test different filters get_locs", { +# get_locs snapshot tests ------------------------------------------------------ +test_that("get_locs filters locations correctly using standard attributes", { suppressWarnings({ file_names <- c( "KAL_ZWA_locations", "KAL_ZWA_observation_wells", - "bbox", "area_codes", "area_codes_loc_type", "loc_validity", - "filterdepth_guess", - "filterdepth_na", - "loc_vec", - "obswells", - "obswell_aggr_latest", - "obswell_aggr_latest_fd", - "obswell_aggr_latest_sso", - "obswell_aggr_mean", - "mask", - "all", - "all_obswells" - ) - - for (f in file_names) { - announce_snapshot_file(name = create_file_name("locs", f)) - } - skip_if(SKIP_SNAPSHOT_TESTS) - skip_if_not( - exists("watina_test_con"), - message = "Geen actieve database connectie gevonden." + "loc_vec" ) + announce_files_locs(file_names) - test_locs <- function(locs, test_name) { - test_data(locs, "locs", test_name) - } - - watina <- watina_test_con + skip_if(getOption("test.skip_snapshot")) + watina <- fetch_watina_connection() + # Default validity - locations and observations locs <- get_locs(watina, area_codes = c("KAL", "ZWA"), loc_validity = "VLD") - test_locs(locs, "KAL_ZWA_locations") + expect_locs(locs, "KAL_ZWA_locations") locs <- get_locs( watina, @@ -103,53 +29,119 @@ test_that("Test different filters get_locs", { loc_validity = "VLD", obswells = TRUE ) - test_locs(locs, "KAL_ZWA_observation_wells") - - bbox <- c(xmin = 1.4e+5, xmax = 1.7e+5, ymin = 1.6e+5, ymax = 1.9e+5) - locs <- get_locs(watina, bbox = bbox) - test_locs(locs, "bbox") + expect_locs(locs, "KAL_ZWA_observation_wells") + # Area and location type filters locs <- get_locs(watina, area_codes = c("KAL", "KBR")) - test_locs(locs, "area_codes") + expect_locs(locs, "area_codes") locs <- get_locs( watina, area_codes = c("KAL", "KBR"), loc_type = c("P", "S") ) - test_locs(locs, "area_codes_loc_type") + expect_locs(locs, "area_codes_loc_type") + # Select all validity options and location types locs <- get_locs( watina, loc_validity = c("ENT", "DEL", "CLD"), loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") ) - test_locs(locs, "loc_validity") + expect_locs(locs, "loc_validity") + + # Exact location matching + locs <- get_locs( + watina, + loc_vec = c("KBRP081", "KBRP090", "KBRP095", "KBRS001") + ) + expect_locs(locs, "loc_vec") + }) +}) + +test_that("get_locs applies spatial queries correctly", { + suppressWarnings({ + file_names <- c( + "bbox", + "mask" + ) + announce_files_locs(file_names) + skip_if(getOption("test.skip_snapshot")) + watina <- fetch_watina_connection() + + # Bounding box filter + bbox <- c(xmin = 1.4e+5, xmax = 1.7e+5, ymin = 1.6e+5, ymax = 1.9e+5) + locs <- get_locs(watina, bbox = bbox) + expect_locs(locs, "bbox") + + # Spatial mask filter using httr2 + 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_validity = "VLD", mask = mymask, buffer = 0, collect = TRUE) + expect_locs(locs, "mask") + }) +}) + +test_that("get_locs calculates filterdepth correctly with different filters", { + suppressWarnings({ + file_names <- c( + "filterdepth_guess", + "filterdepth_na", + "obswells" + ) + announce_files_locs(file_names) + + skip_if(getOption("test.skip_snapshot")) + watina <- fetch_watina_connection() + + # Guessed filterdepth correctly calculated locs <- get_locs(watina, area_codes = "WES", filterdepth_guess = TRUE) - test_locs(locs, "filterdepth_guess") + expect_locs(locs, "filterdepth_guess") + # NA filterdepth filters correctly locs <- get_locs( watina, area_codes = c("KAL", "KBR"), loc_type = c("P", "S"), filterdepth_na = TRUE ) - test_locs(locs, "filterdepth_na") - - locs <- get_locs( - watina, - loc_vec = c("KBRP081", "KBRP090", "KBRP095", "KBRS001") - ) - test_locs(locs, "loc_vec") + expect_locs(locs, "filterdepth_na") + # Select observation wells locs <- get_locs( watina, obswells = TRUE, area_codes = c("KAL", "KBR"), loc_type = c("P", "S") ) - test_locs(locs, "obswells") + expect_locs(locs, "obswells") + }) +}) + +test_that("get_locs applies observation wells aggregation logic correctly", { + suppressWarnings({ + file_names <- c( + "obswell_aggr_latest", + "obswell_aggr_latest_fd", + "obswell_aggr_latest_sso", + "obswell_aggr_mean" + ) + announce_files_locs(file_names) + + skip_if(getOption("test.skip_snapshot")) + watina <- fetch_watina_connection() locs <- get_locs( watina, @@ -159,7 +151,7 @@ test_that("Test different filters get_locs", { obswell_aggr = "latest" ) %>% select(loc_code, contains("ost"), contains("filterdepth")) - test_locs(locs, "obswell_aggr_latest") + expect_locs(locs, "obswell_aggr_latest") locs <- get_locs( watina, @@ -169,7 +161,7 @@ test_that("Test different filters get_locs", { obswell_aggr = "latest_fd" ) %>% select(loc_code, contains("ost"), contains("filterdepth")) - test_locs(locs, "obswell_aggr_latest_fd") + expect_locs(locs, "obswell_aggr_latest_fd") locs <- get_locs( watina, @@ -179,7 +171,7 @@ test_that("Test different filters get_locs", { obswell_aggr = "latest_sso" ) %>% select(loc_code, contains("ost"), contains("filterdepth")) - test_locs(locs, "obswell_aggr_latest_sso") + expect_locs(locs, "obswell_aggr_latest_sso") locs <- get_locs( watina, @@ -189,27 +181,21 @@ test_that("Test different filters get_locs", { obswell_aggr = "mean" ) %>% select(loc_code, contains("ost"), contains("filterdepth")) - test_locs(locs, "obswell_aggr_mean") - - mymask <- - "https://geo.api.vlaanderen.be/VRBG/wfs" %>% - httr::parse_url() %>% - purrr::list_merge( - query = list( - request = "GetFeature", - typeName = "VRBG:Refprv", - cql_filter = "NAAM='West-Vlaanderen'", - srsName = "EPSG:31370", - outputFormat = "text/xml; subtype=gml/3.1.1" - ) - ) %>% - httr::build_url() %>% - sf::read_sf(crs = 31370) %>% - sf::st_cast("GEOMETRYCOLLECTION") - locs <- get_locs(watina, loc_validity = "VLD", mask = mymask, buffer = 0) - test_locs(locs, "mask") + expect_locs(locs, "obswell_aggr_mean") + }) +}) + +test_that("get_locs output matches exactly during extensive evaluation", { + suppressWarnings({ + file_names <- c( + "all", + "all_obswells" + ) + announce_files_locs(file_names) - skip_if(SKIP_DATA_VALIDATION_TESTS) + skip_if(getOption("test.skip_snapshot")) + skip_if(getOption("test.skip_data_validation")) + watina <- fetch_watina_connection() # Extensive test - all rows locs <- get_locs( @@ -217,7 +203,7 @@ test_that("Test different filters get_locs", { loc_validity = c("VLD"), loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") ) - test_locs(locs, "all") + expect_locs(locs, "all") # Extensive test - all rows in observations locs <- get_locs( @@ -226,54 +212,57 @@ test_that("Test different filters get_locs", { loc_validity = c("VLD"), loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") ) - test_locs(locs, "all_obswells") + expect_locs(locs, "all_obswells") }) }) -test_that("Test different filters get_xg3", { +# get_xg3 snapshot tests ------------------------------------------------------- +test_that("get_xg3 applies different filters correctly", { suppressWarnings({ file_names <- c( "KAL_2010", - "KAL_2010_ostend", - "all_2010" - ) - - for (f in file_names) { - announce_snapshot_file(name = create_file_name("xg3", f)) - } - skip_if(SKIP_SNAPSHOT_TESTS) - skip_if_not( - exists("watina_test_con"), - message = "Geen actieve database connectie gevonden." + "KAL_2010_ostend" ) + announce_files_xg3(file_names) - test_xg3 <- function(xg3, test_name) { - test_data(xg3, "xg3", test_name) - } - - watina <- watina_test_con + skip_if(getOption("test.skip_snapshot")) + watina <- fetch_watina_connection() locs <- get_locs(watina, area_codes = "KAL") + xg3 <- locs %>% get_xg3(watina, 2010) %>% collect() - test_xg3(xg3, "KAL_2010") + expect_xg3(xg3, "KAL_2010") xg3 <- locs %>% get_xg3(watina, 2010, vert_crs = "ostend") %>% collect() - test_xg3(xg3, "KAL_2010_ostend") + expect_xg3(xg3, "KAL_2010_ostend") + }) +}) - skip_if(SKIP_DATA_VALIDATION_TESTS) +test_that("get_xg3 output matches exactly during extensive evaluation", { + suppressWarnings({ + file_names <- c( + "KAL_2010", + "KAL_2010_ostend", + "all_2010" + ) + announce_files_xg3(file_names) + + skip_if(getOption("test.skip_snapshot")) + skip_if(getOption("test.skip_data_validation")) + watina <- fetch_watina_connection() - # Extensive test - all rows locs <- get_locs( watina, loc_validity = c("VLD"), loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") ) xg3 <- locs %>% get_xg3(watina, 2010) %>% collect() - test_xg3(xg3, "all_2010") + expect_xg3(xg3, "all_2010") }) }) -test_that("Test different filters get_chem", { +# get_chem snapshot tests ------------------------------------------------------ +test_that("get_chem applies different filters correctly", { suppressWarnings({ file_names <- c( "ZWA", @@ -281,36 +270,24 @@ test_that("Test different filters get_chem", { "ZWA_thresholdNA", "ZWA_excludeNA", "ZWA_thresholdNA_excludeNA", - "ZWA_range", - "all_20170101" - ) - - for (f in file_names) { - announce_snapshot_file(name = create_file_name("chem", f)) - } - skip_if(SKIP_SNAPSHOT_TESTS) - skip_if_not( - exists("watina_test_con"), - message = "Geen actieve database connectie gevonden." + "ZWA_range" ) + announce_files_chem(file_names) - test_chem <- function(chem, test_name) { - test_data(chem, "chem", test_name) - } - - watina <- watina_test_con + skip_if(getOption("test.skip_snapshot")) + watina <- fetch_watina_connection() locs <- get_locs(watina, area_codes = "ZWA") chem <- locs %>% get_chem(watina, "1/1/2017", enddate = "31-12-2018") %>% collect() - test_chem(chem, "ZWA") + expect_chem(chem, "ZWA") chem <- locs %>% get_chem(watina, "1/1/2017", enddate = "31-12-2018", conc_type = "eq") %>% collect() - test_chem(chem, "ZWA_eq") + expect_chem(chem, "ZWA_eq") chem <- locs %>% get_chem( @@ -320,7 +297,7 @@ test_that("Test different filters get_chem", { en_fecond_threshold = NA ) %>% collect() - test_chem(chem, "ZWA_thresholdNA") + expect_chem(chem, "ZWA_thresholdNA") chem <- locs %>% get_chem( @@ -330,7 +307,7 @@ test_that("Test different filters get_chem", { en_exclude_na = TRUE ) %>% collect() - test_chem(chem, "ZWA_excludeNA") + expect_chem(chem, "ZWA_excludeNA") chem <- locs %>% get_chem( @@ -341,7 +318,7 @@ test_that("Test different filters get_chem", { en_fecond_threshold = NA ) %>% collect() - test_chem(chem, "ZWA_thresholdNA_excludeNA") + expect_chem(chem, "ZWA_thresholdNA_excludeNA") chem <- locs %>% get_chem( @@ -351,17 +328,27 @@ test_that("Test different filters get_chem", { en_range = c(-1, 1) ) %>% collect() - test_chem(chem, "ZWA_range") + expect_chem(chem, "ZWA_range") + }) +}) - skip_if(SKIP_DATA_VALIDATION_TESTS) +test_that("get_chem output matches exactly during extensive evaluation", { + suppressWarnings({ + file_names <- c( + "all_20170101" + ) + announce_files_chem(file_names) + + skip_if(getOption("test.skip_snapshot")) + skip_if(getOption("test.skip_data_validation")) + watina <- fetch_watina_connection() - # Extensive test - all rows locs <- get_locs( watina, loc_validity = c("VLD"), loc_type = c("P", "S", "R", "N", "W", "D", "L", "B") ) chem <- locs %>% get_chem(watina, "1/1/2017") %>% collect() - test_chem(chem, "all_20170101") + expect_chem(chem, "all_20170101") }) })