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/.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..26e5339 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,17 +32,21 @@ Imports: Suggests: DBI, ggplot2, + httr2, knitr, KSgeneral, purrr, rmarkdown, scales, sf, + testthat (>= 3.0.0), tibble, - tidyselect + tidyselect, + withr 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..47dea1a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,6 +27,7 @@ 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 671f945..23e835f 100644 --- a/R/get.R +++ b/R/get.R @@ -1243,6 +1243,7 @@ get_xg3 <- function(locs, #' distinct #' sql #' rename +#' between get_chem <- function(locs, con, startdate, @@ -1414,14 +1415,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 +1469,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 +1477,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 +1490,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 +1499,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" ) %>% 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..8ad7486 --- /dev/null +++ b/tests/testthat/README.md @@ -0,0 +1,74 @@ +## 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 'test_con'. If this variable is not found, the snapshot tests will be skipped. + +``` r +test_con <- connect_watina() +``` + +### 2. 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. + +### 3. Modify your code + +Switch to your feature branch if you're reviewing a PR or apply your changes when developing a feature. + +### 4. 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 ⚙️ + +Testing behavior is managed dynamically through R session `options()`. When you open the project, your `.Rprofile` automatically initializes them. + +- **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 new file mode 100644 index 0000000..ec042bb --- /dev/null +++ b/tests/testthat/setup.R @@ -0,0 +1,10 @@ +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 new file mode 100644 index 0000000..adddc0f --- /dev/null +++ b/tests/testthat/test-get.R @@ -0,0 +1,354 @@ +# 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. + +# 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", + "area_codes", + "area_codes_loc_type", + "loc_validity", + "loc_vec" + ) + announce_files_locs(file_names) + + 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") + expect_locs(locs, "KAL_ZWA_locations") + + locs <- get_locs( + watina, + area_codes = c("KAL", "ZWA"), + loc_validity = "VLD", + obswells = TRUE + ) + expect_locs(locs, "KAL_ZWA_observation_wells") + + # Area and location type filters + locs <- get_locs(watina, area_codes = c("KAL", "KBR")) + expect_locs(locs, "area_codes") + + locs <- get_locs( + watina, + area_codes = c("KAL", "KBR"), + loc_type = c("P", "S") + ) + 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") + ) + 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) + 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 + ) + expect_locs(locs, "filterdepth_na") + + # Select observation wells + locs <- get_locs( + watina, + obswells = TRUE, + area_codes = c("KAL", "KBR"), + loc_type = c("P", "S") + ) + 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, + area_codes = "WES", + filterdepth_na = TRUE, + filterdepth_guess = TRUE, + obswell_aggr = "latest" + ) %>% + select(loc_code, contains("ost"), contains("filterdepth")) + expect_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")) + expect_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")) + expect_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")) + 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(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") + ) + expect_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") + ) + expect_locs(locs, "all_obswells") + }) +}) + +# get_xg3 snapshot tests ------------------------------------------------------- +test_that("get_xg3 applies different filters correctly", { + suppressWarnings({ + file_names <- c( + "KAL_2010", + "KAL_2010_ostend" + ) + announce_files_xg3(file_names) + + skip_if(getOption("test.skip_snapshot")) + watina <- fetch_watina_connection() + + locs <- get_locs(watina, area_codes = "KAL") + + xg3 <- locs %>% get_xg3(watina, 2010) %>% collect() + expect_xg3(xg3, "KAL_2010") + + xg3 <- locs %>% get_xg3(watina, 2010, vert_crs = "ostend") %>% collect() + expect_xg3(xg3, "KAL_2010_ostend") + }) +}) + +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() + + 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() + expect_xg3(xg3, "all_2010") + }) +}) + +# get_chem snapshot tests ------------------------------------------------------ +test_that("get_chem applies different filters correctly", { + suppressWarnings({ + file_names <- c( + "ZWA", + "ZWA_eq", + "ZWA_thresholdNA", + "ZWA_excludeNA", + "ZWA_thresholdNA_excludeNA", + "ZWA_range" + ) + announce_files_chem(file_names) + + 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() + expect_chem(chem, "ZWA") + + chem <- locs %>% + get_chem(watina, "1/1/2017", enddate = "31-12-2018", conc_type = "eq") %>% + collect() + expect_chem(chem, "ZWA_eq") + + chem <- locs %>% + get_chem( + watina, + "1/1/2017", + enddate = "31-12-2018", + en_fecond_threshold = NA + ) %>% + collect() + expect_chem(chem, "ZWA_thresholdNA") + + chem <- locs %>% + get_chem( + watina, + "1/1/2017", + enddate = "31-12-2018", + en_exclude_na = TRUE + ) %>% + collect() + expect_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() + expect_chem(chem, "ZWA_thresholdNA_excludeNA") + + chem <- locs %>% + get_chem( + watina, + "1/1/2017", + enddate = "31-12-2018", + en_range = c(-1, 1) + ) %>% + collect() + expect_chem(chem, "ZWA_range") + }) +}) + +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() + + 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() + expect_chem(chem, "all_20170101") + }) +})