From 5b67f9332a6c676d9b0456eb34ceab403e7c26dd Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Mon, 18 Dec 2023 17:12:53 -0800 Subject: [PATCH 01/10] NA values with no input data --- R/calc_DD.R | 4 ++++ R/calc_Eref_CMD.R | 7 +++++++ 2 files changed, 11 insertions(+) diff --git a/R/calc_DD.R b/R/calc_DD.R index aa3ab5bc..18400173 100644 --- a/R/calc_DD.R +++ b/R/calc_DD.R @@ -10,6 +10,8 @@ calc_DD_m_above <- function(tm, k, a, b, t0, beta, c) { i <- which(tm >= k) DD_m[i] <- c + beta * tm[i] + DD_m[is.na(tm)] <- tm[is.na(tm)] ## use tm[is.na(tm)] to respect NA type + return(DD_m) } @@ -25,6 +27,8 @@ calc_DD_m_below <- function(tm, k, a, b, t0, beta, c) { i <- which(tm <= k) DD_m[i] <- c + beta * tm[i] + DD_m[is.na(tm)] <- tm[is.na(tm)] ## use tm[is.na(tm)] to respect NA type + return(DD_m) } diff --git a/R/calc_Eref_CMD.R b/R/calc_Eref_CMD.R index a14da181..aec13080 100644 --- a/R/calc_Eref_CMD.R +++ b/R/calc_Eref_CMD.R @@ -17,6 +17,9 @@ calc_Eref <- function(m, tmin, tmax, latitude) { calc_S0_I(day_julian[m], tmean[i], latitude[i]) * (tmean[i] + 17.8) * sqrt(tmax[i] - tmin[i]) * (1.18 - 0.0065 * latitude[i]) + + Eref[is.na(tmax)] <- tmax[is.na(tmax)] ## use tmax[is.na(tmax)] to respect NA type + return(Eref) } @@ -28,6 +31,10 @@ calc_CMD <- function(Eref, PPT) { CMD <- numeric(length(Eref)) i <- which(Eref > PPT) CMD[i] <- Eref[i] - PPT[i] + + ## return 0s to NaNs if missing values + CMD[is.na(Eref)] <- Eref[is.na(Eref)] ## use Eref[is.na(Eref)] to respect NA type + return(CMD) } From 524a16e651a4f412f8ea16a4d976cb235bbc9647 Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Mon, 18 Dec 2023 17:12:59 -0800 Subject: [PATCH 02/10] minor --- R/calc_EMT_EXT.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/calc_EMT_EXT.R b/R/calc_EMT_EXT.R index 8082b115..061fc7a9 100644 --- a/R/calc_EMT_EXT.R +++ b/R/calc_EMT_EXT.R @@ -11,7 +11,6 @@ calc_EMT <- function(t_min_list, td) { year_min <- do.call(pmin, t_min_list) - -23.02164 + 0.77908 * tmin1 + 0.67048 * tmin12 + 0.01075 * year_min^2 + 0.11565 * td } @@ -30,6 +29,5 @@ calc_EXT <- function(t_max_list, td) { year_max <- do.call(pmax, t_max_list) - 10.64245 + -1.92005 * tmax7 + 0.04816 * tmax7^2 + 2.51176 * tmax8 - 0.03088 * tmax8^2 - 0.01311 * year_max^2 + 0.33167 * td - 0.001 * td^2 } From 0475b63b09390e59c50f41cc0595b5930700e00a Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Mon, 18 Dec 2023 17:13:26 -0800 Subject: [PATCH 03/10] run calc funs in order of `appenders` --- R/append_clim_vars.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/append_clim_vars.R b/R/append_clim_vars.R index 8e6cf927..6226a05a 100644 --- a/R/append_clim_vars.R +++ b/R/append_clim_vars.R @@ -667,7 +667,9 @@ append_clim_vars <- function(dt, vars) { ) # Append vars except default one - for (var in vars[!vars %in% sprintf(c("PPT%02d", "Tmax%02d", "Tmin%02d"), sort(rep(1:12, 3)))]) { + vars2 <- vars[!vars %in% sprintf(c("PPT%02d", "Tmax%02d", "Tmin%02d"), sort(rep(1:12, 3)))] + vars2 <- vars2[order(match(vars2, names(appenders)))] ## run functions in the order of appenders + for (var in vars2) { f(var) } From 0efa32343369485dab78ee13f826114306049449 Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Mon, 18 Dec 2023 17:10:12 -0800 Subject: [PATCH 04/10] tests for calc_* (TBC) --- tests/testthat/test-calcfuns.R | 82 +++++++++++++++++++++++++++------- 1 file changed, 67 insertions(+), 15 deletions(-) diff --git a/tests/testthat/test-calcfuns.R b/tests/testthat/test-calcfuns.R index ec87fb16..0da42d7f 100644 --- a/tests/testthat/test-calcfuns.R +++ b/tests/testthat/test-calcfuns.R @@ -1,15 +1,15 @@ test_that("calc_* functions work", { - climr:::calc_DD_below_0(2, -14) + expect_identical(round(climr:::calc_DD_below_0(2, -14), 4), 393.9186) + expect_identical(climr:::calc_DD_below_0(2, NA_real_), NA_real_) + + expect_identical(round(climr:::calc_DD_above_5(2, -14, "All"), 4), 0.2144) + expect_identical(climr:::calc_DD_above_5(2, NA, "All"), NA_real_) - ## TODO: what are the correct outputs? + expect_identical(round(climr:::calc_DD_below_18(2, -14), 4), 892.0826) + expect_identical(climr:::calc_DD_below_18(2, NA_real_), NA_real_) - # expect_??? - - climr:::calc_DD_above_5(2, -14, "All") - - climr:::calc_DD_below_18(2, -14) - - climr:::calc_DD_above_18(2, -14, "All") + expect_identical(round(climr:::calc_DD_above_18(2, -14, "All"), 4), 0.0001) + expect_identical(climr:::calc_DD_above_18(2, NA, "All"), NA_real_) t_min_list <- list( "1" = -35, "2" = -32, "3" = -25, "4" = -10, @@ -17,15 +17,67 @@ test_that("calc_* functions work", { "11" = -20, "12" = -30 ) - climr:::calc_bFFP(td = 30, NFFD = 10, t_min_list = t_min_list) + expect_identical(round(climr:::calc_bFFP(td = 30, NFFD = 10, t_min_list = t_min_list), 4), + 214.5964) + expect_identical(climr:::calc_bFFP(td = 30, NFFD = NA, t_min_list = t_min_list), NA_real_) + expect_identical(climr:::calc_bFFP(td = NA, NFFD = 10, t_min_list = t_min_list), NA_real_) - climr:::calc_eFFP(NFFD = 10, t_min_list = t_min_list) + expect_identical(round(climr:::calc_eFFP(NFFD = 10, t_min_list = t_min_list), 4), + 265.4581) + expect_identical(climr:::calc_eFFP(NFFD = NA, t_min_list = t_min_list), NA_real_) - climr:::calc_FFP(bFFP = 214.5964, eFFP = 265.4581) + expect_identical(round(climr:::calc_FFP(bFFP = 214.5964, eFFP = 265.4581), 4), + 50.8617) + expect_identical(climr:::calc_FFP(bFFP = NA, eFFP = 265.4581), NA_real_) + expect_identical(climr:::calc_FFP(bFFP = 214.5964, eFFP = NA), NA_real_) - climr:::calc_NFFD(3, 2.05) + expect_identical(round(climr:::calc_NFFD(3, 2.05), 4), 21.1018) + expect_identical(climr:::calc_NFFD(3, NA_real_), NA_real_) + + expect_identical(round(climr:::calc_PAS(4, 2, 600), 4), 308.4204) + expect_identical(climr:::calc_PAS(4, NA, 600), NA_real_) + expect_identical(climr:::calc_PAS(4, 2, NA_real_), NA_real_) + + expect_identical(round(climr:::calc_RH(tmin = 10, tmax = 40), 4), 28.5378) + expect_identical(climr:::calc_RH(tmin = NA, tmax = 40), NA_real_) + expect_identical(climr:::calc_RH(tmin = 10, tmax = NA), NA_real_) +}) - climr:::calc_PAS(4, 2, 600) - climr:::calc_RH(tmin = 10, tmax = 40) +test_that("calc_* give sensible outputs", { + devtools::load_all() + library(pool) + library(data.table) + library(terra) + + set.seed(123) + dbCon <- data_connect() + xyz <- data.frame(lon = runif(10, -140, -106), lat = runif(10, 37, 61), elev = runif(10)) + + thebb <- get_bb(xyz) + + normalbc <- normal_input(dbCon = dbCon, normal = "normal_bc", bbox = thebb, cache = TRUE) + + gcm <- gcm_input(dbCon, bbox = thebb, + gcm = c("BCC-CSM2-MR"), + ssp = c("ssp126"), + period = "2041_2060", + max_run = 0, + cache = TRUE) + + n <- 20 + sample_xyz <- data.frame(lon = runif(n, xmin(normalbc$dem2_WNA), xmax(normalbc$dem2_WNA)), + lat = runif(n, ymin(normalbc$dem2_WNA), ymax(normalbc$dem2_WNA)), + elev = NA) + sample_xyz[, 3] <- terra::extract(normalbc$dem2_WNA, sample_xyz[, 1:2], method = "bilinear")[, -1L] + + ds_res_bc <- downscale(sample_xyz, normal = normalbc, gcm = gcm, var = list_variables()) + + sample_xyz$ID <- 1:nrow(sample_xyz) + ds_res_bc <- as.data.table(sample_xyz)[ds_res_bc, on = .(ID)] + ds_res_bc[, .(lat, lon, elev, Tmax, PPT01, CMD, Eref)] + + expect_true(all(is.na(ds_res_bc[is.na(elev), .SD, .SDcols = list_variables()]))) + + ## TODO: more sanity checks? }) From 1673436ac16964c8bf91fd2bccdf63011bae3152 Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Mon, 18 Dec 2023 11:21:25 -0800 Subject: [PATCH 05/10] test utils --- R/helper-testInit.R | 22 ++++++++++++++++++++++ tests/testthat/setup.R | 3 +++ 2 files changed, 25 insertions(+) create mode 100644 R/helper-testInit.R create mode 100644 tests/testthat/setup.R diff --git a/R/helper-testInit.R b/R/helper-testInit.R new file mode 100644 index 00000000..96257ff3 --- /dev/null +++ b/R/helper-testInit.R @@ -0,0 +1,22 @@ +# loads and libraries indicated + +testInit <- function(libraries = character()) { + + pf <- parent.frame() + + if (length(libraries)) { + libraries <- unique(libraries) + loadedAlready <- vapply(libraries, function(pkg) + any(grepl(paste0("package:", pkg), search())), FUN.VALUE = logical(1)) + libraries <- libraries[!loadedAlready] + + if (length(libraries)) { + pkgsLoaded <- unlist(lapply(libraries, requireNamespace, quietly = TRUE)) + if (!all(pkgsLoaded)) { + lapply(libraries[!pkgsLoaded], skip_if_not_installed) + } + suppressWarnings(lapply(libraries, withr::local_package, .local_envir = pf)) + } + } +} + diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R new file mode 100644 index 00000000..3c175cde --- /dev/null +++ b/tests/testthat/setup.R @@ -0,0 +1,3 @@ +# Preload all Suggests so that examples don't take tons of time +requireNamespace("parallel", quietly = TRUE) + From 4c0c1f66ec318c0ec9f1f1312fc760df6886d053 Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Mon, 18 Dec 2023 17:21:45 -0800 Subject: [PATCH 06/10] add set.seed --- tests/testthat/test-calcfuns.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-calcfuns.R b/tests/testthat/test-calcfuns.R index 0da42d7f..ebd78078 100644 --- a/tests/testthat/test-calcfuns.R +++ b/tests/testthat/test-calcfuns.R @@ -65,6 +65,7 @@ test_that("calc_* give sensible outputs", { max_run = 0, cache = TRUE) + set.seed(678) ## a situation with known NAs n <- 20 sample_xyz <- data.frame(lon = runif(n, xmin(normalbc$dem2_WNA), xmax(normalbc$dem2_WNA)), lat = runif(n, ymin(normalbc$dem2_WNA), ymax(normalbc$dem2_WNA)), From 23f81a4fe60072d6f0638aab35b41725ca2fb965 Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Mon, 18 Dec 2023 17:26:05 -0800 Subject: [PATCH 07/10] oops! --- tests/testthat/test-calcfuns.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test-calcfuns.R b/tests/testthat/test-calcfuns.R index ebd78078..e19e99ef 100644 --- a/tests/testthat/test-calcfuns.R +++ b/tests/testthat/test-calcfuns.R @@ -45,7 +45,6 @@ test_that("calc_* functions work", { test_that("calc_* give sensible outputs", { - devtools::load_all() library(pool) library(data.table) library(terra) From 1c6ab1b384a79b06bd6de5efa046e1f4c9cde597 Mon Sep 17 00:00:00 2001 From: cmahony Date: Tue, 19 Dec 2023 11:32:06 -0800 Subject: [PATCH 08/10] correction to the timespans of historical and future in the readme file. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 4be0da7b..e4a44c4b 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ climr provides the following data: - Historical observational time series (1902-2022), currently limited to the ClimateNA time series (Wang et al., 2016) -- Multiple historical (1851-2010) and future (2001-2100) climate model simulations for each of 13 CMIP6 global climate models, in monthly time series and 20-year normals +- Multiple historical (1851-2014) and future (2015-2100) climate model simulations for each of 13 CMIP6 global climate models, in monthly time series and 20-year normals - User selection of single or multiple climate variables, with derived variables following the ClimateNA methodology of Wang et al. (2016). From 024f047a1d41748f9bf9621a8ec0216a403f2c04 Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Tue, 19 Dec 2023 12:31:59 -0800 Subject: [PATCH 09/10] add withr to Suggests and GHA flow (used in testing) --- .github/workflows/R-CMD-check.yaml | 1 + DESCRIPTION | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 0a2f8713..9c793110 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -54,6 +54,7 @@ jobs: extra-packages: | any::rcmdcheck any::Rcpp + any::withr - uses: r-lib/actions/check-r-package@v2 with: diff --git a/DESCRIPTION b/DESCRIPTION index 9c39bbf4..a84ab084 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,8 @@ Imports: Suggests: parallel, rmarkdown, - testthat (>= 3.0.0) + testthat (>= 3.0.0), + withr Depends: R (>= 4.0) Config/testthat/edition: 3 From f61be148c44512005ea85fce01eaad385e9493da Mon Sep 17 00:00:00 2001 From: CeresBarros Date: Wed, 20 Dec 2023 13:35:03 -0800 Subject: [PATCH 10/10] make smaller test area --- tests/testthat/test-calcfuns.R | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-calcfuns.R b/tests/testthat/test-calcfuns.R index e19e99ef..b81ce53a 100644 --- a/tests/testthat/test-calcfuns.R +++ b/tests/testthat/test-calcfuns.R @@ -49,10 +49,10 @@ test_that("calc_* give sensible outputs", { library(data.table) library(terra) - set.seed(123) dbCon <- data_connect() - xyz <- data.frame(lon = runif(10, -140, -106), lat = runif(10, 37, 61), elev = runif(10)) + ## the following includes NAs for the test + xyz <- data.frame(lon = c(-128, -125, -128, -125), lat = c(50, 50, 48, 48), elev = runif(4)) thebb <- get_bb(xyz) normalbc <- normal_input(dbCon = dbCon, normal = "normal_bc", bbox = thebb, cache = TRUE) @@ -64,7 +64,7 @@ test_that("calc_* give sensible outputs", { max_run = 0, cache = TRUE) - set.seed(678) ## a situation with known NAs + set.seed(678) ## a situation with known NAs (ocean where elev is 0) n <- 20 sample_xyz <- data.frame(lon = runif(n, xmin(normalbc$dem2_WNA), xmax(normalbc$dem2_WNA)), lat = runif(n, ymin(normalbc$dem2_WNA), ymax(normalbc$dem2_WNA)), @@ -77,7 +77,11 @@ test_that("calc_* give sensible outputs", { ds_res_bc <- as.data.table(sample_xyz)[ds_res_bc, on = .(ID)] ds_res_bc[, .(lat, lon, elev, Tmax, PPT01, CMD, Eref)] + ## if elevation of inout climate data are NA, downscaled variables should be as well. expect_true(all(is.na(ds_res_bc[is.na(elev), .SD, .SDcols = list_variables()]))) + expect_true(all(is.na(ds_res_bc[is.na(PPT01), .SD, .SDcols = list_variables()]))) + ## conversely, if there is input data, there should be no NAs in downscaled vars + expect_true(all(!is.na(ds_res_bc[!is.na(PPT01), .SD, .SDcols = list_variables()]))) ## TODO: more sanity checks? })