diff --git a/base/db/DESCRIPTION b/base/db/DESCRIPTION index 0e302137980..e8d4f273b84 100644 --- a/base/db/DESCRIPTION +++ b/base/db/DESCRIPTION @@ -66,13 +66,15 @@ Suggests: data.table, here, knitr, + mockery, RPostgreSQL, RPostgres, RSQLite, rcrossref, rmarkdown (>= 2.19), testthat (>= 2.0.0), - tidyverse + tidyverse, + withr X-Comment-Remotes: Installing markdown from GitHub because as of 2023-02-05, this is the easiest way to get version >= 2.19 onto Docker images that use older @@ -80,7 +82,8 @@ X-Comment-Remotes: When building on a system that finds a new enough version on CRAN, OK to remove the Remotes line and this comment. Remotes: - github::rstudio/rmarkdown@v2.20 + github::rstudio/rmarkdown@v2.20, + github::r-lib/mockery@v0.4.3 License: BSD_3_clause + file LICENSE VignetteBuilder: knitr Copyright: Authors diff --git a/base/db/R/assign.treatments.R b/base/db/R/assign.treatments.R index 5e22285e837..d75f6b20b3a 100644 --- a/base/db/R/assign.treatments.R +++ b/base/db/R/assign.treatments.R @@ -13,7 +13,7 @@ ##' Assigns all control treatments the same value, then assigns unique treatments ##' within each site. Each site is required to have a control treatment. ##' The algorithm (incorrectly) assumes that each site has a unique set of experimental -##' treatments. This assumption is required by the data in BETTdb that does not always consistently name treatments or quantity them in the managements table. Also it avoids having the need to estimate treatment by site interactions in the meta analysis model. This model uses data in the control treatment to estimate model parameters so the impact of the assumption is minimal. +##' treatments. This assumption is required by the data in BETYdb that does not always consistently name treatments or quantity them in the managements table. Also it avoids having the need to estimate treatment by site interactions in the meta analysis model. This model uses data in the control treatment to estimate model parameters so the impact of the assumption is minimal. ##' @name assign.treatments ##' @title assign.treatments ##' @param data input data diff --git a/base/db/R/dbfiles.R b/base/db/R/dbfiles.R index 28509daef8f..e0f9556779b 100644 --- a/base/db/R/dbfiles.R +++ b/base/db/R/dbfiles.R @@ -71,7 +71,7 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, "SELECT * FROM inputs WHERE site_id=", siteid, " AND name= '", name, "' AND format_id=", formatid, - parent + parent, ";" ), con = con ) @@ -120,26 +120,26 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, "INSERT INTO inputs ", "(site_id, format_id, name) VALUES (", siteid, ", ", formatid, ", '", name, - "'", ") RETURNING id" + "'", ") RETURNING id;" ) } else if (parent == "" && !is.null(startdate)) { cmd <- paste0( "INSERT INTO inputs ", "(site_id, format_id, start_date, end_date, name) VALUES (", siteid, ", ", formatid, ", '", startdate, "', '", enddate, "','", name, - "') RETURNING id" + "') RETURNING id;" ) } else if (is.null(startdate)) { cmd <- paste0( "INSERT INTO inputs ", "(site_id, format_id, name, parent_id) VALUES (", - siteid, ", ", formatid, ", '", name, "',", parentid, ") RETURNING id" + siteid, ", ", formatid, ", '", name, "',", parentid, ") RETURNING id;" ) } else { cmd <- paste0( "INSERT INTO inputs ", "(site_id, format_id, start_date, end_date, name, parent_id) VALUES (", - siteid, ", ", formatid, ", '", startdate, "', '", enddate, "','", name, "',", parentid, ") RETURNING id" + siteid, ", ", formatid, ", '", startdate, "', '", enddate, "','", name, "',", parentid, ") RETURNING id;" ) } # This is the id that we just registered @@ -150,7 +150,7 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, inputid <- db.query( query = paste0( "SELECT id FROM inputs WHERE site_id=", siteid, - " AND format_id=", formatid + " AND format_id=", formatid, ";" ), con = con )$id diff --git a/base/db/R/query.dplyr.R b/base/db/R/query.dplyr.R index b0501a9abcb..d1f0a1a401a 100644 --- a/base/db/R/query.dplyr.R +++ b/base/db/R/query.dplyr.R @@ -61,7 +61,7 @@ dplyr.count <- function(df) { #' @param unit string containing CF-style time unit including origin (e.g. "days since 2010-01-01") #' @export ncdays2date <- function(time, unit) { - date <- lubridate::parse_date_time(unit, c("ymd_hms", "ymd_h", "ymd")) + date <- lubridate::parse_date_time(unit, c("ymd_HMS", "ymd_H", "ymd")) days <- PEcAn.utils::ud_convert(time, unit, paste("days since ", date)) seconds <- PEcAn.utils::ud_convert(days, "days", "seconds") return(as.POSIXct.numeric(seconds, origin = date, tz = "UTC")) @@ -124,7 +124,7 @@ workflows <- function(bety, ensemble = FALSE) { #' @export workflow <- function(bety, workflow_id) { workflows(bety) %>% - dplyr::filter(.data$workflow_id == !!.data$workflow_id) + dplyr::filter(.data$workflow_id == !!workflow_id) } # workflow diff --git a/base/db/R/query.file.path.R b/base/db/R/query.file.path.R index 071b6af12b8..ceb79f99685 100644 --- a/base/db/R/query.file.path.R +++ b/base/db/R/query.file.path.R @@ -8,11 +8,11 @@ ##' @author Betsy Cowdery query.file.path <- function(input.id, host_name, con){ machine.host <- PEcAn.DB::default_hostname(host_name) - machine <- db.query(query = paste0("SELECT * from machines where hostname = '",machine.host,"'"), con = con) + machine <- db.query(query = paste0("SELECT * from machines where hostname = '",machine.host,"';"), con = con) dbfile <- db.query( query = paste( "SELECT file_name,file_path from dbfiles where container_id =", input.id, - " and container_type = 'Input' and machine_id =", machine$id + " and container_type = 'Input' and machine_id =", machine$id, ";" ), con = con ) diff --git a/base/db/R/query.yields.R b/base/db/R/query.yields.R index d28c8bf10dd..4f07ef01b74 100644 --- a/base/db/R/query.yields.R +++ b/base/db/R/query.yields.R @@ -24,13 +24,20 @@ query.yields <- function(trait = 'yield', spstr, extra.columns = '', con = NULL, ids_are_cultivars = FALSE, ...){ member_column <- if (ids_are_cultivars) {"cultivar_id"} else {"specie_id"} + + if(!is.null(extra.columns)) { + if(!is.character(extra.columns) || length(extra.columns) != 1) { + PEcAn.logger::logger.severe("`extra.columns` must be a string") + } + } + query <- paste("select yields.id, yields.citation_id, yields.site_id, treatments.name, yields.date, yields.time, yields.cultivar_id, yields.specie_id, yields.mean, yields.statname, yields.stat, yields.n, variables.name as vname, month(yields.date) as month,", - extra.columns, + if(extra.columns != '') { paste(extra.columns, ",", sep = "") } else {""}, "treatments.control, sites.greenhouse from yields left join treatments on (yields.treatment_id = treatments.id) @@ -38,7 +45,7 @@ query.yields <- function(trait = 'yield', spstr, extra.columns = '', con = NULL, left join variables on (yields.variable_id = variables.id) where ", member_column, " in (", spstr,");", sep = "") if(!trait == 'yield'){ - query <- gsub(");", paste(" and variables.name in ('", trait,"');", sep = ""), query) + query <- gsub(";", paste(" and variables.name in ('", trait,"');", sep = ""), query) } return(fetch.stats2se(connection = con, query = query)) diff --git a/base/db/man/assign.treatments.Rd b/base/db/man/assign.treatments.Rd index 30365dc8468..c1b6509217d 100644 --- a/base/db/man/assign.treatments.Rd +++ b/base/db/man/assign.treatments.Rd @@ -19,7 +19,7 @@ Change treatments to sequential integers Assigns all control treatments the same value, then assigns unique treatments within each site. Each site is required to have a control treatment. The algorithm (incorrectly) assumes that each site has a unique set of experimental -treatments. This assumption is required by the data in BETTdb that does not always consistently name treatments or quantity them in the managements table. Also it avoids having the need to estimate treatment by site interactions in the meta analysis model. This model uses data in the control treatment to estimate model parameters so the impact of the assumption is minimal. +treatments. This assumption is required by the data in BETYdb that does not always consistently name treatments or quantity them in the managements table. Also it avoids having the need to estimate treatment by site interactions in the meta analysis model. This model uses data in the control treatment to estimate model parameters so the impact of the assumption is minimal. } \author{ David LeBauer, Carl Davidson, Alexey Shiklomanov diff --git a/base/db/tests/testthat/test.assign.treatments.R b/base/db/tests/testthat/test.assign.treatments.R new file mode 100644 index 00000000000..a51c40f4804 --- /dev/null +++ b/base/db/tests/testthat/test.assign.treatments.R @@ -0,0 +1,33 @@ +test_that("`assign.treatments` correctly assigns control treatment", { + data <- data.frame( + site_id = c(1, 1, 2, 2, 3, 3), + citation_id = c(101, 101, 201, 201, 301, 301), + control = c(1, 0, 0, 1, 0, 0), + trt_id = NA + ) + + updated_data <- assign.treatments(data) + expect_equal(updated_data$trt_id, c("control", NA, NA, "control", "control", "control")) +}) + +test_that("`assign.treatments` gives an error if no control treatment is set for a site", { + data <- data.frame( + site_id = c(1, 1, 2, 2, 3, 3), + citation_id = c(101, 101, 201, 201, 301, 301), + control = c(0, 0, 0, 1, 0, 0), + trt_id = c(NA, NA, NA, NA, "not_control", NA) + ) + + expect_error(assign.treatments(data), "No control treatment set") +}) + +test_that("`drop.columns` able to drop specified columns from data", { + data <- data.frame( + id = c(1, 2, 3), + name = c("a", "b", "c"), + value = c(1.2, 4.5, 6.7) + ) + + updated_data <- drop.columns(data, c("name", "not_a_column")) + expect_equal(colnames(updated_data), c("id", "value")) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.check.lists.R b/base/db/tests/testthat/test.check.lists.R new file mode 100644 index 00000000000..e434c29a2e7 --- /dev/null +++ b/base/db/tests/testthat/test.check.lists.R @@ -0,0 +1,23 @@ +test_that("`check.lists` returns false for appropriate cases", { + x <- data.frame(id = c(1, 2, 3)) + y <- data.frame(id = c(1, 2, 3, 4)) + + # for unequal number of rows + expect_false(check.lists(x, y)) + + # for wrong filename passed + expect_false(check.lists(x, y, filename = "wrong.csv")) + + # if x and y are actually unequal + y <- data.frame(id = c(1, 2, 4)) + expect_false(check.lists(x, y, filename = "species.csv")) +}) + +test_that("`check.lists` able to correctly work for matching data frames to lists read from csv files", { + withr::with_tempfile("tf", fileext = ".csv",{ + x <- data.frame(id = c(1, 2, 3)) + y <- data.frame(id = c(1, 2, 3)) + write.csv(y, file = tf) + expect_true(check.lists(x, read.csv(tf), filename = "species.csv")) + }) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.convert_input.R b/base/db/tests/testthat/test.convert_input.R new file mode 100644 index 00000000000..29513187c9e --- /dev/null +++ b/base/db/tests/testthat/test.convert_input.R @@ -0,0 +1,39 @@ +test_that("`convert_input()` able to call the respective download function for a data item with the correct arguments", { + mocked_res <- mockery::mock(list(c("A", "B"))) + + mockery::stub(convert_input, 'dbfile.input.check', data.frame()) + mockery::stub(convert_input, 'db.query', data.frame(id = 1)) + mockery::stub(convert_input, 'PEcAn.remote::remote.execute.R', mocked_res) + mockery::stub(convert_input, 'purrr::map_dfr', data.frame(missing = c(FALSE), empty = c(FALSE))) + + convert_input( + input.id = NA, + outfolder = "test", + formatname = NULL, + mimetype = NULL, + site.id = 1, + start_date = "2011-01-01", + end_date = "2011-12-31", + pkg = 'PEcAn.data.atmosphere', + fcn = 'download.AmerifluxLBL', + con = NULL, + host = data.frame(name = "localhost"), + browndog = NULL, + write = FALSE, + lat.in = 40, + lon.in = -88 + ) + + args <- mockery::mock_args(mocked_res) + expect_equal( + args[[1]]$script, + "PEcAn.data.atmosphere::download.AmerifluxLBL(lat.in=40, lon.in=-88, overwrite=FALSE, outfolder='test/', start_date='2011-01-01', end_date='2011-12-31')" + ) +}) + +test_that("`.get.file.deletion.commands()` able to return correct file deletion commands", { + res <- .get.file.deletion.commands(c("test")) + expect_equal(res$move.to.tmp, "dir.create(c('./tmp'), recursive=TRUE, showWarnings=FALSE); file.rename(from=c('test'), to=c('./tmp/test'))") + expect_equal(res$delete.tmp, "unlink(c('./tmp'), recursive=TRUE)") + expect_equal(res$replace.from.tmp, "file.rename(from=c('./tmp/test'), to=c('test'));unlink(c('./tmp'), recursive=TRUE)") +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.covariate.functions.R b/base/db/tests/testthat/test.covariate.functions.R new file mode 100644 index 00000000000..27fccd4eabe --- /dev/null +++ b/base/db/tests/testthat/test.covariate.functions.R @@ -0,0 +1,32 @@ +test_that("`append.covariate` able to append new column for covariates in given data based on id", { + data <- data.frame( + id = c(1, 2, 3, 4), + name = c("a", "b", "c", "d") + ) + covariates.data <- data.frame( + trait_id = c( 1, 2, 3, 4, 4), + level = c("A", "B", "C", "D", "E"), + name = c("a", "b", "c", "d", "e") + ) + updated_data <- append.covariate(data, "new_covariates_col", covariates.data) + expect_equal(updated_data$new_covariates_col, c("A", "B", "C", "D")) + expect_equal(colnames(updated_data), c("id", "new_covariates_col", "name")) +}) + +test_that("`filter_sunleaf_traits`able to filter out upper canopy leaves", { + data <- data.frame( + id = c(1, 2, 3, 4), + name = c("a", "b", "c", "d") + ) + covariates <- data.frame( + trait_id = c(1, 2, 3, 4), + name = c("leaf", "canopy_layer", "canopy_layer", "sunlight"), + level = c(1.2, 0.5, 0.7, 0.67) + ) + + updated_data <- filter_sunleaf_traits(data, covariates) + expect_equal(updated_data$name, c("a", "c", "d")) + + # temporary column gets removed + expect_equal(colnames(updated_data), c("id", "name")) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.dbfiles.R b/base/db/tests/testthat/test.dbfiles.R new file mode 100644 index 00000000000..4880a074cd8 --- /dev/null +++ b/base/db/tests/testthat/test.dbfiles.R @@ -0,0 +1,150 @@ +test_that("`dbfile.input.insert()` able to create correct sql queries to insert a file into dbfiles table", { + + mocked_res <- mockery::mock(data.frame(), 1, data.frame(id = 2023)) + mockery::stub(dbfile.input.insert, 'get.id', 1) + mockery::stub(dbfile.input.insert, 'db.query', mocked_res) + mockery::stub( + dbfile.input.insert, + 'dbfile.check', + data.frame(id = 101, file_name = 'test-file', file_path = 'trait.data.Rdata') + ) + + res <- dbfile.input.insert( + in.path = 'trait.data.Rdata', + in.prefix = 'test-file', + siteid = 'test-site', + startdate = '2021-01-01', + enddate = '2022-01-01', + mimetype = 'application/x-RData', + formatname = 'traits', + con = NULL + ) + + expect_equal(res$dbfile.id, 101) + expect_equal(res$input.id, 2023) + args <- mockery::mock_args(mocked_res) + + # finding appropriate input + expect_true( + grepl( + "WHERE site_id=test-site AND name= 'trait.data.Rdata' AND format_id=1;", + args[[1]]$query + ) + ) + + # parent == "" and startdate not NULL + expect_true( + grepl( + "VALUES \\(test-site, 1, '2021-01-01', '2022-01-01','trait.data.Rdata'\\)", + args[[2]]$query + ) + ) + + # startdate not NULL + expect_true( + grepl( + "WHERE site_id=test-site AND format_id=1 AND start_date='2021-01-01' AND end_date='2022-01-01'", + args[[3]]$query + ) + ) +}) + +test_that("`dbfile.input.check()` able to form the right query to check the dbfiles table to see if a file exists as an input", { + + mocked_res <- mockery::mock(NULL) + mockery::stub(dbfile.input.check, 'get.id', 1) + mockery::stub(dbfile.input.check, 'db.query', mocked_res) + + dbfile.input.check('US-Akn', '2021-01-01', '2022-01-01', 'application/x-RData', 'traits', con = NULL) + args <- mockery::mock_args(mocked_res) + expect_true( + grepl( + "WHERE site_id=US-Akn AND format_id=1", + args[[1]]$query + ) + ) +}) + +test_that("`dbfile.posterior.insert()` able to make a correct query to insert a file into dbfiles table as a posterior", { + mocked_res <- mockery::mock(NULL, NULL, data.frame(id = 10)) + mockery::stub(dbfile.posterior.insert, 'get.id', 1) + mockery::stub(dbfile.posterior.insert, 'dbfile.insert', 1010) + mockery::stub(dbfile.posterior.insert, 'db.query', mocked_res) + + dbfile.posterior.insert('trait.data.Rdata', 'test-pft', 'application/x-RData', 'traits', con = NULL) + args <- mockery::mock_args(mocked_res) + expect_true(grepl("INSERT INTO posteriors \\(pft_id, format_id\\) VALUES \\(1, 1\\)", args[[2]]$query)) + +}) + +test_that("`dbfile.posterior.check()` able to form the correct query to retrieve correct posterior id to run further checks", { + mocked_res <- mockery::mock(data.frame(id = 2020)) + mockery::stub(dbfile.posterior.check, 'get.id', 1) + mockery::stub(dbfile.posterior.check, 'db.query', mocked_res) + mockery::stub(dbfile.posterior.check, 'dbfile.check', data.frame(id = 1, filename = 'test_1', pathname = 'path_1')) + + dbfile.posterior.check('testpft', 'application/x-RData', 'traits', con = NULL) + + args <- mockery::mock_args(mocked_res) + expect_true( + grepl( + "SELECT id FROM posteriors WHERE pft_id=1 AND format_id=1", + args[[1]]$query + ) + ) +}) + +test_that("`dbfile.insert()` able to add correct parameter values to the insert database query and return a file id", { + mocked_res <- mockery::mock(data.frame(), data.frame(id = 2020)) + mockery::stub(dbfile.insert, 'get.id', 1) + mockery::stub(dbfile.insert, 'db.query', mocked_res) + + res <- dbfile.insert(in.path = '/test/file/path', in.prefix = 'testfile.txt', 'Input', 7, con = NULL) + args <- mockery::mock_args(mocked_res) + expect_equal(res, 2020) + expect_true(grepl("VALUES \\('Input', 7, 'testfile.txt', '/test/file/path', 1\\) RETURNING id", args[[2]]$query)) +}) + +test_that("`dbfile.check()` able to return the most recent entries from `dbfiles` table associated with a container and machine", { + mockery::stub(dbfile.check, 'get.id', 1) + mockery::stub( + dbfile.check, + 'dplyr::tbl', + data.frame( + container_type = c('Input', 'Input', 'Model'), + container_id = c(7, 7, 7), + machine_id = c(1, 1, 2), + updated_at = c(20201112, 20210101, 20210102), + id = c(2, 3, 4), + filename = c('test_1', 'test_2', 'test_3'), + pathname = c('path_1', 'path_2', 'path_3') + ) + ) + res <- dbfile.check("Input", 7, con = NULL) + + expect_equal( + res, + data.frame(container_type = 'Input', container_id = 7, machine_id = 1, updated_at = 20210101, id = 3, filename = 'test_2', pathname = 'path_2') + ) +}) + +test_that("`dbfile.file()` able to return a correctly formed file path from entries in the `dbfiles` table for a particular container and machine", { + mockery::stub(dbfile.file, 'dbfile.check', data.frame(file_path = 'test/dir/path', file_name = 'test_file')) + expect_equal(dbfile.file('Input', 7, con = NULL), file.path('test/dir/path/test_file')) +}) + +test_that("`dbfile.id()` able to construct a correct database query to get id for a dbfile given the container type and filepath", { + mocked_res <- mockery::mock(data.frame(id = 1), data.frame(container_id = 2020)) + mockery::stub(dbfile.id, 'db.query', mocked_res) + + res <- dbfile.id('Model', '/usr/local/bin/sipnet', con = NULL) + args <- mockery::mock_args(mocked_res) + + expect_equal(res, 2020) + expect_true( + grepl( + "WHERE container_type='Model' AND file_path='/usr/local/bin' AND file_name='sipnet' AND machine_id=1", + args[[2]]$query + ) + ) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.derive.traits.R b/base/db/tests/testthat/test.derive.traits.R index ae4b4ba93c9..4ba88caf3ed 100644 --- a/base/db/tests/testthat/test.derive.traits.R +++ b/base/db/tests/testthat/test.derive.traits.R @@ -6,13 +6,6 @@ # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html #------------------------------------------------------------------------------- -test_that("take.samples works",{ - expect_equal(take.samples(summary = data.frame(mean = 1, stat = NA)), 1) - set.seed(0) - test.sample <- take.samples(summary = data.frame(mean = 1, stat = 1), - sample.size = 2) - expect_equal(test.sample, c(2.26295428488079, 0.673766639294351)) -}) test_that("derive.traits works",{ set.seed(0) diff --git a/base/db/tests/testthat/test.insert.R b/base/db/tests/testthat/test.insert.R index 95dd80a459e..168bb4f4ae6 100644 --- a/base/db/tests/testthat/test.insert.R +++ b/base/db/tests/testthat/test.insert.R @@ -47,3 +47,11 @@ test_that( } ) }) + +test_that("`match_colnames()` returns intersection of column names of a dataframe to a table", { + mockery::stub(match_colnames, 'dplyr::tbl', data.frame(id = 1, name = 'test', value = 1)) + expect_equal( + match_colnames(values = data.frame(id = 1, name = 'test'), table = 'test', con = 1), + c('id', 'name') + ) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.met_inputs.R b/base/db/tests/testthat/test.met_inputs.R new file mode 100644 index 00000000000..49d75b7b379 --- /dev/null +++ b/base/db/tests/testthat/test.met_inputs.R @@ -0,0 +1,10 @@ +test_that("`met_inputs()` able to correctly place input parameters in the database query to retrieve available met inputs", { + mocked_res <- mockery::mock(0) + mockery::stub(met_inputs, 'db.query', mocked_res) + met_inputs(dbcon = NULL, site_id = 100, model_id = 200, hostname = "pecan") + args <- mockery::mock_args(mocked_res) + + expect_true( + grepl("inputs.site_id = \\$1.*machines.hostname = \\$2.*models.id = \\$3", args[[1]][[1]]) + ) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.query.data.R b/base/db/tests/testthat/test.query.data.R new file mode 100644 index 00000000000..87cafba5787 --- /dev/null +++ b/base/db/tests/testthat/test.query.data.R @@ -0,0 +1,20 @@ +test_that("`query.data()` able to correctly form the query and return result in SE", { + mocked_function <- mockery::mock(data.frame(Y=rep(1,5), stat=rep(1,5), n=rep(4,5), mean = rep(3,5), statname=c('SD', 'MSE', 'LSD', 'HSD', 'MSD'))) + mockery::stub(query.data, 'db.query', mocked_function, 2) + result <- query.data(con = 1, trait = "test_trait", spstr = "test_spstr", store.unconverted = TRUE) + args <- mockery::mock_args(mocked_function) + expect_true( + grepl( + paste( + "ST_X\\(ST_CENTROID\\(sites\\.geometry\\)\\) AS lon,", + "ST_Y\\(ST_CENTROID\\(sites\\.geometry\\)\\) AS lat,.*", + "where specie_id in \\(test_spstr\\).*", + "variables.name in \\('test_trait'\\);" + ), + args[[1]]$query + ) + ) + expect_equal(result$mean_unconverted, result$mean) + expect_equal(result$stat_unconverted, result$stat) + expect_equal(result$statname, rep('SE', 5)) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.query.dplyr.R b/base/db/tests/testthat/test.query.dplyr.R new file mode 100644 index 00000000000..cc3e6436eea --- /dev/null +++ b/base/db/tests/testthat/test.query.dplyr.R @@ -0,0 +1,154 @@ +test_that("`fancy_scientific()` converts numbers to scientific expressions with proper formatting", { + result <- fancy_scientific(1234567890) + expect_equal(result, expression("1.234568" %*% 10^+9)) + + result <- fancy_scientific(0.00000123) + expect_equal(result, expression("1.23" %*% 10^-6)) + + result <- fancy_scientific(1e-20) + expect_equal(result, expression("1" %*% 10^-20)) +}) + +test_that("`dplyr.count()` returns the correct count of rows in a dataframe", { + + df <- data.frame( + x = c(1, 2, 3, 2, 1, 3), + y = c("a", "b", "a", "b", "a", "b") + ) + result <- dplyr.count(df) + expect_equal(result, 6) + + df <- data.frame() + result <- dplyr.count(df) + expect_equal(result, 0) +}) + +test_that("`dbHostInfo()` able to return correct host information", { + mockery::stub(dbHostInfo, 'db.query', data.frame(floor = 10)) + mockery::stub( + dbHostInfo, + 'dplyr::tbl', + data.frame( + data.frame( + sync_host_id = c(10, 11), + hostname = c("test_host_1", "test_host_2"), + sync_start = c("20190201", "20190201"), + sync_end = c("20200101", "20200101"), + sync_url = c("http://test_url_1", "http://test_url_2"), + sync_contact = c("test_contact_1", "test_contact_2") + ) + ) + ) + result <- dbHostInfo(bety = 1) + expect_equal(result$hostid, 10) + expect_equal(result$hostname, "test_host_1") + expect_equal(result$start, "20190201") + expect_equal(result$end, "20200101") + expect_equal(result$sync_url, "http://test_url_1") + expect_equal(result$sync_contact, "test_contact_1") +}) + +test_that("`workflows()` able to correctly return a list of workflows", { + mockery::stub( + workflows, + 'dbHostInfo', + list( + hostid = 10, + hostname = "test_host_1", + start = 3, + end = 10, + sync_url = "http://test_url_1", + sync_contact = "test_contact_1" + ) + ) + mockery::stub(workflows, 'dplyr::tbl', data.frame(workflow_id = c(1, 2, 3, 4, 5, 6))) + result <- workflows(bety = 1, ensemble = TRUE) + expect_equal(result, data.frame(workflow_id = c(3, 4, 5, 6))) +}) + +test_that("`workflow()` able to get a workflow data by id", { + mockery::stub( + workflow, + 'workflows', + data.frame(workflow_id = c(1, 2, 3, 4, 5, 6), workflow_name = c("A", "B", "C", "D", "E", "F")) + ) + result <- workflow(bety = 1, workflow_id = 3) + expect_equal(result, data.frame(workflow_id = 3, workflow_name = "C")) +}) + +test_that("`runs()` is able to get table of runs for a corresponding workflow", { + mockery::stub( + runs, + 'workflow', + data.frame( + workflow_id = c(1, 1), + folder = c("test_folder_1", "test_folder_2") + ) + ) + mocked_res <- mockery::mock( + data.frame( + id = c(1, 2, 3, 4, 5, 6), + workflow_id = c(1, 1, 3, 4, 5, 6) + ), + data.frame( + id = c(1, 2, 3), + ensemble_id = c(1, 1, 2) + ) + ) + mockery::stub(runs, 'dplyr::tbl', mocked_res) + result <- runs(bety = 1, workflow_id = 1) + expect_equal(result$run_id, c(1, 1, 2, 2, 3, 3)) + expect_equal(result$folder, c("test_folder_1", "test_folder_2", "test_folder_1", "test_folder_2", "test_folder_1", "test_folder_2")) +}) + +test_that("`get_workflow_ids()` able to get a vector of unique workflow IDs", { + mockery::stub( + get_workflow_ids, + 'workflows', + data.frame( + workflow_id = c(1, 2, 2, 3, 4, 4), + workflow_name = c("A", "B", "C", "D", "E", "F") + ) + ) + result <- get_workflow_ids(bety = 1, query = 1, all.ids = TRUE) + expect_equal(result, c(4, 3, 2, 1)) +}) + +test_that("`get_users()` ", { + mockery::stub(get_users, 'dplyr::tbl', data.frame(id = c(20200101, 20200102, 20240103))) + mockery::stub( + get_users, + 'dbHostInfo', + data.frame( + start = 20190201, + end = 20230101 + ) + ) + result <- get_users(bety = 1) + expect_equal(result, data.frame(id = c(20200101, 20200102))) +}) + +test_that("`get_run_ids()` able to get vector of run ids (in sorted order) for a given workflow ID", { + mockery::stub( + get_run_ids, + 'runs', + data.frame( + run_id = c(3, 1, 2), + folder = c("test_folder_1", "test_folder_2", "test_folder_3") + ) + ) + + result <- get_run_ids(bety = 1, workflow_id = 1) + expect_equal(result, c(1, 2, 3)) + + # if no run ids are found + mockery::stub(get_run_ids, 'runs', data.frame()) + result <- get_run_ids(bety = 1, workflow_id = 1) + expect_equal(result, c("No runs found")) +}) + +test_that("`var_names_all()` able get vector of variable names for a particular workflow and run ID removing variables not to be shown to user", { + mockery::stub(var_names_all, 'get_var_names', c('A', 'B', 'C', 'Year','FracJulianDay')) + result <- var_names_all(bety = 1, workflow_id = 1, run_id = 1) + expect_equal(result, c('A', 'B', 'C')) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.query.file.path.R b/base/db/tests/testthat/test.query.file.path.R new file mode 100644 index 00000000000..1da98a019e6 --- /dev/null +++ b/base/db/tests/testthat/test.query.file.path.R @@ -0,0 +1,21 @@ +test_that("`query.file.path()`", { + # mock responses for subsequent calls to db.query + mocked_res <- mockery::mock(data.frame(id = '20210101'), data.frame(file_name = 'test_file', file_path = 'test_path')) + mockery::stub(query.file.path, 'db.query', mocked_res) + mockery::stub(query.file.path, 'PEcAn.remote::remote.execute.R', TRUE) + res <- query.file.path(input.id = 1, host_name = "pecan", con = 1) + args <- mockery::mock_args(mocked_res) + expect_true( + grepl( + "where hostname = 'pecan'", + args[[1]]$query + ) + ) + expect_true( + grepl( + "container_id = 1.* machine_id = 20210101", + args[[2]]$query + ) + ) + expect_equal(res, 'test_path/test_file') +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.query.priors.R b/base/db/tests/testthat/test.query.priors.R new file mode 100644 index 00000000000..4f0311a9e8f --- /dev/null +++ b/base/db/tests/testthat/test.query.priors.R @@ -0,0 +1,13 @@ +test_that("`query.priors()` correctly forms the query based on the parameters passed and returns priors",{ + mocked_function <- mockery::mock(data.frame(name = c("A", "B"), value = c(0.1, 0.2))) + mockery::stub(query.priors, 'db.query', mocked_function) + priors <- query.priors("ebifarm.pavi", c("SLA"), con = 1) + expect_equal(priors, c(0.1, 0.2)) + args <- mockery::mock_args(mocked_function) + expect_true( + grepl( + "WHERE pfts.id = ebifarm.pavi AND variables.name IN .* SLA", + args[[1]]$query + ) + ) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.query.site.R b/base/db/tests/testthat/test.query.site.R new file mode 100644 index 00000000000..ec61c210581 --- /dev/null +++ b/base/db/tests/testthat/test.query.site.R @@ -0,0 +1,14 @@ +test_that("`query.site()` correctly forms the query and returns the site", { + mock_site_data <- data.frame(id = c(1), lon = c(1), lat = c(1)) + mocked_function <- mockery::mock(mock_site_data) + mockery::stub(query.site, 'db.query', mocked_function) + site <- query.site(1, con = 1) + expect_equal(site, mock_site_data) + args <- mockery::mock_args(mocked_function) + expect_true( + grepl( + "WHERE id = 1", + args[[1]]$query + ) + ) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.query.yields.R b/base/db/tests/testthat/test.query.yields.R new file mode 100644 index 00000000000..c8a7905d51f --- /dev/null +++ b/base/db/tests/testthat/test.query.yields.R @@ -0,0 +1,43 @@ +test_that("`query.yields()` able to form the query correctly for trait set to 'yield' and with no extra columns", { + mocked_function <- mockery::mock(data.frame(Y=rep(1,5), stat=rep(1,5), n=rep(4,5), mean = rep(3,5), statname=c('SD', 'MSE', 'LSD', 'HSD', 'MSD'))) + mockery::stub(query.yields, 'db.query', mocked_function, 2) + result <- query.yields(spstr = "test_spstr", con = 1) + + args <- mockery::mock_args(mocked_function) + expect_true( + grepl( + paste0( + "month\\(yields.date\\) as month,treatments.control.*", + "where specie_id in \\(test_spstr\\);" + ), + args[[1]]$query + ) + ) +}) + +test_that("`query.yields()` throws an error if extra columns is not a string", { + expect_error( + query.yields(spstr = "test_spstr", con = 1, extra.columns = 1), + "`extra.columns` must be a string" + ) + expect_error( + query.yields(spstr = "test_spstr", con = 1, extra.columns = c("a","b")), + "`extra.columns` must be a string" + ) +}) + +test_that("`query.yields()` able to form the query correctly for trait not equal to 'yield' and with extra columns",{ + mocked_function <- mockery::mock(data.frame(Y=rep(1,5), stat=rep(1,5), n=rep(4,5), mean = rep(3,5), statname=c('SD', 'MSE', 'LSD', 'HSD', 'MSD'))) + mockery::stub(query.yields, 'db.query', mocked_function, 2) + result <- query.yields(trait = 'test_trait', spstr = "test_spstr", extra.columns = 'test_col', con = 1) + args <- mockery::mock_args(mocked_function) + expect_true( + grepl( + paste0( + "month\\(yields.date\\) as month,test_col,treatments.control.*", + "where specie_id in \\(test_spstr\\) and variables.name in \\('test_trait'\\)" + ), + args[[1]]$query + ) + ) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.stamp.R b/base/db/tests/testthat/test.stamp.R new file mode 100644 index 00000000000..c566e073ee4 --- /dev/null +++ b/base/db/tests/testthat/test.stamp.R @@ -0,0 +1,15 @@ +test_that("`stamp_started()` able to correctly update the query for run_id passed", { + mock_function <- mockery::mock() + mockery::stub(stamp_started, 'PEcAn.DB::db.query', mock_function) + stamp_started(1, 1) + args <- mockery::mock_args(mock_function) + expect_true(grepl("started_at .* WHERE id = 1", args[[1]]$query)) +}) + +test_that("`stamp_finished()` able to correctly update the query for run_id passed", { + mock_function <- mockery::mock() + mockery::stub(stamp_finished, 'PEcAn.DB::db.query', mock_function) + stamp_finished(1, 1) + args <- mockery::mock_args(mock_function) + expect_true(grepl("finished_at .* WHERE id = 1", args[[1]]$query)) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.take.samples.R b/base/db/tests/testthat/test.take.samples.R new file mode 100644 index 00000000000..dee2e479b44 --- /dev/null +++ b/base/db/tests/testthat/test.take.samples.R @@ -0,0 +1,15 @@ +test_that("`take.samples` returns mean when stat is NA", { + summary = list(mean = 10, stat = NA) + expect_equal(take.samples(summary = summary), summary$mean) +}) + +test_that("`take.samples` returns a vector of length sample.size for given summary stats", { + summary = list(mean = 10, stat = 10) + sample.size = 10 + expect_equal(length(take.samples(summary = summary, sample.size = sample.size)), sample.size) + + # Testing for exact return values for a simple example + test.sample <- take.samples(summary = data.frame(mean = 1, stat = 1), + sample.size = 2) + expect_equal(test.sample, c(2.26295428488079, 0.673766639294351)) +}) \ No newline at end of file diff --git a/base/db/tests/testthat/test.utils_db.R b/base/db/tests/testthat/test.utils_db.R new file mode 100644 index 00000000000..b859baea575 --- /dev/null +++ b/base/db/tests/testthat/test.utils_db.R @@ -0,0 +1,26 @@ +# test_that("`db.print.connections()` able to log out details about connections", { +# PEcAn.logger::logger.setUseConsole(TRUE, FALSE) +# on.exit(PEcAn.logger::logger.setUseConsole(TRUE, TRUE), add = TRUE) +# expect_output( +# db.print.connections(), +# paste0( +# ".* Created 0 connections and executed 0 queries .* ", +# "Created 0 connections and executed 0 queries.*", +# "No open database connections." +# ) +# ) +# }) + +test_that("`db.showQueries()` and `db.getShowQueries()` able to set and get the value of the .db.utils$showquery variable respectively", { + showquery_old <- db.getShowQueries() + on.exit(db.showQueries(showquery_old)) + db.showQueries(TRUE) + expect_equal(db.getShowQueries(), TRUE) +}) + +test_that("`default_hostname()` fixes hostname if the host is localhost", { + expect_equal(default_hostname("localhost"), PEcAn.remote::fqdn()) + + # if not localhost + expect_equal(default_hostname("pecan"), "pecan") +}) \ No newline at end of file diff --git a/docker/depends/pecan.depends.R b/docker/depends/pecan.depends.R index a4f2e489a4e..c208e5e5525 100644 --- a/docker/depends/pecan.depends.R +++ b/docker/depends/pecan.depends.R @@ -13,6 +13,7 @@ remotes::install_github(c( 'chuhousen/amerifluxr', 'ebimodeling/biocro@0.951', 'MikkoPeltoniemi/Rpreles', +'r-lib/mockery@v0.4.3', 'r-lib/testthat@v3.1.6', 'r-lib/vdiffr@v1.0.4', 'ropensci/geonames',