diff --git a/.RData b/.RData new file mode 100644 index 00000000..06153a80 Binary files /dev/null and b/.RData differ diff --git a/R/02_genericDefinitions.R b/R/02_genericDefinitions.R index af406817..978e6aaa 100644 --- a/R/02_genericDefinitions.R +++ b/R/02_genericDefinitions.R @@ -42,9 +42,8 @@ setGeneric("showMatch", function(x) { #' @param x sites object #' @returns data.frame with record information at sample level #' @export -setGeneric("samples", function(x) { - standardGeneric(f = "samples") - }) +setGeneric("samples", + function(object, chronname=NULL) standardGeneric("samples")) #' @title Obtain speleothems from a record or multiple records. #' @param x sites object diff --git a/R/get_sites.R b/R/get_sites.R index 3575445b..42fba196 100644 --- a/R/get_sites.R +++ b/R/get_sites.R @@ -116,6 +116,9 @@ get_sites.default <- function(...) { cl <- as.list(match.call()) cl[[1]] <- NULL cl <- lapply(cl, eval, envir = parent.frame()) + if ("gpid" %in% names(cl)) { + cl$gpid = paste(cl$gpid,collapse=",") + } if ("siteid" %in% names(cl)) { # redirect to numeric method if ("all_data" %in% names(cl)) { @@ -136,7 +139,7 @@ get_sites.default <- function(...) { on.exit(options(oo)) baseURL <- paste0("data/sites") result <- tryCatch( - parseURL(baseURL, ...), + do.call(parseURL, c(list(baseURL), cl)), error = function(e) { stop("API call failed: ", e$message) NULL diff --git a/R/samples.R b/R/samples.R index 4a66fa60..f6c27254 100644 --- a/R/samples.R +++ b/R/samples.R @@ -14,154 +14,194 @@ #' @md #' @export setMethod(f = "samples", - signature = "sites", - definition = function(x) { - output <- map(x@sites, function(y) samples(y)) %>% - bind_rows() # %>% - # Handle NAs to allow distinct to work properly - #distinct(.data$sampleid, .keep_all = TRUE) - if (nrow(output) == 0) { - warnsite <- sprintf("No assigned samples. Did you run get_downloads()?") - warning(warnsite) - } - return(output) - } + signature = "sites", + definition = function(object,chronname = NULL) { + output <- map(object@sites, function(y) samples(y, chronname = chronname)) %>% + bind_rows() # %>% + # Handle NAs to allow distinct to work properly + #distinct(.data$sampleid, .keep_all = TRUE) + if (nrow(output) == 0) { + warnsite <- sprintf("No assigned samples. Did you run get_downloads()?") + warning(warnsite) + } + return(output) + } ) #' @rdname samples #' @export setMethod(f = "samples", - signature = "site", - definition = function(x) { - allids <- getids(x) - siteinfo <- as.data.frame(x) %>% - left_join(allids, by = "siteid") - sampset <- map(x@collunits@collunits, - function(y) samples(y)) %>% - bind_rows() %>% - bind_rows() %>% - left_join(siteinfo, by = "datasetid") %>% - rename(sitenotes = .data$notes) - return(sampset) - } + signature = "site", + definition = function(object,chronname = NULL) { + allids <- getids(object) + siteinfo <- as.data.frame(object) %>% + left_join(allids, by = "siteid") + sampset <- map(object@collunits@collunits, + function(y) samples(y, chronname = chronname)) %>% + bind_rows() %>% + bind_rows() %>% + left_join(siteinfo, by = "datasetid") %>% + rename(sitenotes = .data$notes) + return(sampset) + } ) #' @rdname samples #' @export setMethod(f = "samples", - signature = "collunits", - definition = function(x) { - map(x@collunits, function(x) samples(x)) %>% - bind_rows() - } + signature = "collunits", + definition = function(object, chronname = NULL) { + map(object@collunits, function(object) samples(object, chronname=chronname)) %>% + bind_rows() + } ) #' @rdname samples #' @export +#' setMethod(f = "samples", - signature = "collunit", - definition = function(x) { - # A collection unit with no datasets (e.g. its datasets were deleted - # upstream) contributes no samples. Return an empty data.frame so the - # bind_rows() in the site/sites/collunits methods simply skips it instead - # of erroring on an empty/NULL datasets slot. - if (length(datasets(x)) == 0) { - return(data.frame()) - } - precedence <- c("Calendar years BP", - "Calibrated radiocarbon years BP", - "Radiocarbon years BP", "Varve years BP") - ids <- getids(x) - # Check the chronologies to make sure everything is okay: - if (length(chronologies(x)) > 0) { - # This pulls the chronology IDs, then applies the Neotoma - # age model precedence (see get_table('agetypes')). - # It returns a value that is larger when your age reporting is - # better. - defaultchron <- map(chronologies(x)@chronologies, - function(y) { - data.frame(chronologyid = y@chronologyid, - isdefault = y@isdefault, - modelagetype = y@modelagetype, - chronologyname = y@chronologyname, - dateprepared = y@dateprepared) - }) %>% - bind_rows() %>% - mutate(modelrank = match(.data$modelagetype, rev(precedence)), - order = .data$isdefault * match(.data$modelagetype, - rev(precedence))) - # Validation of default chrons, we want to check whether there - # exists either multiple default chronologies for the same - # time-frame or, alternately, no default chronology. - all_na <- all(is.na(defaultchron$order)) - max_order <- max(defaultchron$order, na.rm = TRUE) - if (sum(defaultchron$order == max_order, na.rm = TRUE) > 1) { - if (any(is.na(defaultchron$dateprepared))) { - high_chron <- defaultchron$order == max_order - newmax_order <- which.max(defaultchron$chronologyid[high_chron]) - defaultchron$order[high_chron][newmax_order] <- max_order + 1 - } else { - newmax_order <- which.max(defaultchron$dateprepared[ - defaultchron$order == max_order]) - defaultchron$order[defaultchron$order == max_order][ - newmax_order] <- max_order + 1 - } - } - if (all_na == TRUE) { - warnsite <- sprintf("The dataset %s has no default chronologies.", - ids$datasetid[1]) - warning(warnsite) - } else if (sum(defaultchron$order == max_order, na.rm = TRUE) > 1) { - warnsite <- sprintf("The dataset %s has multiple default chronologies. - Chronology %s has been used.", ids$datasetid[1], - defaultchron$chronologyid[ - which.max(defaultchron$order)]) - warning(warnsite) - defaultchron <- defaultchron[which.max(defaultchron$order), ] - } else { - defaultchron <- defaultchron[which.max(defaultchron$order), ] - } - } else { - defaultchron <- data.frame(chronologyid = NULL) - } - sampset <- map(datasets(x)@datasets, - function(y) { - dsid <- y$datasetid - allsamp <- - map(y@samples@samples, - function(z) { - whichage <- - which(z@ages$chronologyid == - defaultchron$chronologyid) - if (length(whichage) == 0) { - whichage <- 1 - } - if (dim(z@datum)[1] > 0) { - df <- - data.frame(z@ages[whichage,], - z@datum, - analysisunitid = z@analysisunitid, - sampleanalyst = - toString(unique(unlist( - z@sampleanalyst, - use.names = FALSE))), - sampleid = z@sampleid, - depth = z@depth, - thickness = z@thickness, - samplename = z@samplename, - row.names = NULL) - } else { - df <- data.frame() - } - return(df) + signature = "collunit", + definition = function(object, chronname) { + chron_exists <- FALSE + precedence <- c("Calendar years BP", + "Calibrated radiocarbon years BP", + "Radiocarbon years BP", "Varve years BP") + ids <- getids(object) + # Check the chronologies to make sure everything is okay: + if (length(chronologies(object)) > 0) { + # This pulls the chronology IDs, then applies the Neotoma + # age model precedence (see get_table('agetypes')). + # It returns a value that is larger when your age reporting is + # better. + defaultchron <- map(chronologies(object)@chronologies, + function(y) { + data.frame(chronologyid = y@chronologyid, + isdefault = y@isdefault, + modelagetype = y@modelagetype, + chronologyname = y@chronologyname, + dateprepared = y@dateprepared) + }) %>% + bind_rows() %>% + mutate(modelrank = match(.data$modelagetype, rev(precedence)), + order = .data$isdefault * match(.data$modelagetype, + rev(precedence))) + #print(defaultchron) + #print(unique(defaultchron$modelagetype)) + #print(unique(defaultchron$isdefault)) + # Validation of default chrons, we want to check whether there + # exists either multiple default chronologies for the same + # time-frame or, alternately, no default chronology. + all_na <- all(is.na(defaultchron$order)) + #print(all_na) + #print(defaultchron$order) + max_order <- max(defaultchron$order, na.rm = TRUE) + if (sum(defaultchron$order == max_order, na.rm = TRUE) > 1) { + if (any(is.na(defaultchron$dateprepared))) { + high_chron <- defaultchron$order == max_order + newmax_order <- which.max(defaultchron$chronologyid[high_chron]) + defaultchron$order[high_chron][newmax_order] <- max_order + 1 + } else { + newmax_order <- which.max(defaultchron$dateprepared[ + defaultchron$order == max_order]) + defaultchron$order[defaultchron$order == max_order][ + newmax_order] <- max_order + 1 + } + } + if (all_na == TRUE) { + warnsite <- sprintf("The dataset %s has no default chronologies.", + ids$datasetid[1]) + warning(warnsite) + + } + + chron_exists <- !is.null(chronname) && + chronname %in% defaultchron$chronologyname + + if (all_na == TRUE) { + + warnsite <- sprintf("The dataset %s has no default chronologies.", + ids$datasetid[1]) + warning(warnsite) + + } else if (chron_exists) { + + # chronology explicitly requested and exists + matches <- defaultchron$chronologyname == chronname + + if (sum(matches, na.rm = TRUE) == 1) { + defaultchron <- defaultchron[matches, ] + } + + if (sum(matches, na.rm = TRUE) > 1) { + defaultchron <- defaultchron[matches, ][1,] + warnsite <- sprintf( + "The dataset %s has multiple chronologies matching chronname %s. Chronology %s has been used.", + ids$datasetid[1], chronname, defaultchron$chronologyid) + warning(warnsite) + } + + } else { + + # either no chronname OR chronname invalid + defaultchron <- defaultchron[which.max(defaultchron$order), ] + + if (!is.null(chronname)) { + warnsite <- sprintf( + "The dataset %s has no chronology matching chronname %s. Default chronology %s has been used.", + ids$datasetid[1], chronname, defaultchron$chronologyid) + warning(warnsite) + } + + } + } else { + defaultchron <- data.frame(chronologyid = NULL) + } + #print(paste0("default chron: ", defaultchron)) + sampset <- map(datasets(object)@datasets, + function(y) { + dsid <- y$datasetid + allsamp <- + map(y@samples@samples, + function(z) { + whichage <- + which(z@ages$chronologyid == + defaultchron$chronologyid) + if (length(whichage) == 0) { + if (chron_exists) { + whichage <- NA + } else { + whichage <- 1 + } + } + if (dim(z@datum)[1] > 0) { + df <- + data.frame(z@ages[whichage,], + z@datum, + analysisunitid = z@analysisunitid, + sampleanalyst = + toString(unique(unlist( + z@sampleanalyst, + use.names = FALSE))), + sampleid = z@sampleid, + depth = z@depth, + thickness = z@thickness, + samplename = z@samplename, + row.names = NULL) + #print(z$ages) + } else { + df <- data.frame() + } + return(df) + }) %>% + bind_rows() %>% + mutate(datasetid = dsid) + return(allsamp) }) %>% - bind_rows() %>% - mutate(datasetid = dsid) - return(allsamp) - }) %>% - bind_rows() %>% - left_join(as.data.frame(datasets(x)), by = "datasetid") %>% - rename(datasetnotes = .data$notes) - return(sampset) - } + bind_rows() %>% + left_join(as.data.frame(datasets(object)), by = "datasetid") %>% + rename(datasetnotes = .data$notes) + if (!is.null(chronname) && sum(defaultchron$chronologyname == chronname, na.rm = TRUE) != 0) { + sampset = sampset %>% dplyr::filter(!is.na(chronologyid))} + return(sampset) + } ) \ No newline at end of file diff --git a/tests/testthat.R b/tests/testthat.R deleted file mode 100644 index aa2e6760..00000000 --- a/tests/testthat.R +++ /dev/null @@ -1,4 +0,0 @@ -library(testthat) -library(neotoma2) - -test_check("neotoma2") diff --git a/tests/testthat/test_sites.R b/tests/testthat/test_sites.R index b66044cf..7c34acc7 100644 --- a/tests/testthat/test_sites.R +++ b/tests/testthat/test_sites.R @@ -5,68 +5,83 @@ library("httptest") context("Run Neotoma `test_sites` only when not on CRAN") httptest::with_mock_api({ -test_that("get_sites runs as expected.", { - skip_on_cran() - alexander_lake <- get_sites(sitename = "Alexander Lake") - testthat::expect_identical(alexander_lake[[1]]@sitename, "Alexander Lake") -}) - -test_that("get_sites runs as expected.", { - skip_on_cran() - alex <- get_sites(sitename = "Alex%") - for (i in seq_len(length(alex))) { - alex_char <- substring(alex[[i]]@sitename, 1,4) - alex_char <- tolower(alex_char) - testthat::expect_identical(alex_char, "alex") - } -}) - -test_that("get_sites runs as expected.", { - skip_on_cran() - site.1001 <- get_sites(1001) - testthat::expect_equal(site.1001[[1]]@siteid, 1001) -}) - -test_that("get_sites runs as expected.", { - skip_on_cran() - sites.ob <- get_sites(c(1001, 2001, 15, 24)) - sites.vec <- getids(sites.ob) - sites.vec <- unique(sites.vec$siteid) - testthat::expect_setequal(sites.vec, c(1001, 2001, 15, 24)) -}) - -# test_that("All Czech sites work with different spatial bounds:", { -# skip_on_cran() -# cz_json <- '{"type": "Polygon", -# "coordinates": [[ -# [12.40, 50.14], -# [14.10, 48.64], -# [16.95, 48.66], -# [18.91, 49.61], -# [15.24, 50.99], -# [12.40, 50.14]]]}' -# cz_WKT <- 'POLYGON ((12.4 50.14, -# 14.1 48.64, -# 16.95 48.66, -# 18.91 49.61, -# 15.24 50.99, -# 12.4 50.14))' -# cz_bbox <- c(12.4, 48.64, 18.91, 50.99) -# -# testthat::expect_true(all.equal(get_sites(loc=cz_json), -# get_sites(loc=cz_WKT))) -# -# # Now, we know that all sites in cz_sites[[1]] should be in cz_sites[[3]], -# # but the bounding box strategy means that the reverse is not true: -# cz_ids <- getids(get_sites(loc=cz_json[1])) -# testthat::expect_true(all(cz_ids$siteid %in% -# getids(get_sites(loc = cz_bbox, limit = 50))$siteid)) -# }) - -test_that("All Data + loc work", { - skip_on_cran() - on.exit(Sys.sleep(10), add = TRUE) - europe_json <- '{"type": "Polygon", + test_that("get_sites runs as expected.", { + skip_on_cran() + alexander_lake <- get_sites(sitename = "Alexander Lake") + testthat::expect_identical(alexander_lake[[1]]@sitename, "Alexander Lake") + }) + + test_that("get_sites runs as expected.", { + skip_on_cran() + alex <- get_sites(sitename = "Alex%") + for (i in seq_len(length(alex))) { + alex_char <- substring(alex[[i]]@sitename, 1,4) + alex_char <- tolower(alex_char) + testthat::expect_identical(alex_char, "alex") + } + }) + + test_that("get_sites runs as expected.", { + skip_on_cran() + site.1001 <- get_sites(1001) + testthat::expect_equal(site.1001[[1]]@siteid, 1001) + }) + + test_that("get_sites runs as expected.", { + skip_on_cran() + sites.ob <- get_sites(c(1001, 2001, 15, 24)) + sites.vec <- getids(sites.ob) + sites.vec <- unique(sites.vec$siteid) + testthat::expect_setequal(sites.vec, c(1001, 2001, 15, 24)) + }) + + + #test_that("count() counts sites correctly.", { + # skip_on_cran() + # sites.ob <- get_sites(c(1001, 2001, 15, 24)) + # length_sites = length(sites.ob) + # count_sites = count(sites.ob) + # number_collunit_names = summary(sites.ob) %>% distinct(collunit_name) %>% dplyr::count() + # count_collunits = count(sites.ob,level="collunits") + # count_datasets = count(sites.ob,level="datasets") + # sum_datasets = sum(summary(sites.ob)$n_datasets) + # testthat::expect_equal(number_collunit_names$n[[1]],count_collunits) + # testthat::expect_equal(sum_datasets,count_datasets) + # testthat::expect_equal(length_sites,count_sites) + #}) + + # test_that("All Czech sites work with different spatial bounds:", { + # skip_on_cran() + # cz_json <- '{"type": "Polygon", + # "coordinates": [[ + # [12.40, 50.14], + # [14.10, 48.64], + # [16.95, 48.66], + # [18.91, 49.61], + # [15.24, 50.99], + # [12.40, 50.14]]]}' + # cz_WKT <- 'POLYGON ((12.4 50.14, + # 14.1 48.64, + # 16.95 48.66, + # 18.91 49.61, + # 15.24 50.99, + # 12.4 50.14))' + # cz_bbox <- c(12.4, 48.64, 18.91, 50.99) + # + # testthat::expect_true(all.equal(get_sites(loc=cz_json), + # get_sites(loc=cz_WKT))) + # + # # Now, we know that all sites in cz_sites[[1]] should be in cz_sites[[3]], + # # but the bounding box strategy means that the reverse is not true: + # cz_ids <- getids(get_sites(loc=cz_json[1])) + # testthat::expect_true(all(cz_ids$siteid %in% + # getids(get_sites(loc = cz_bbox, limit = 50))$siteid)) + # }) + + test_that("All Data + loc work", { + skip_on_cran() + on.exit(Sys.sleep(10), add = TRUE) + europe_json <- '{"type": "Polygon", "coordinates": [ [[-23.5546875, 70.8446726342528], [-25.3125, 39.36827914916014], @@ -74,12 +89,13 @@ test_that("All Data + loc work", { [62.57812500000001, 74.01954331150228], [-23.5546875, 70.8446726342528]] ]}' - # This only needs to prove that a large region returns many sites; a single - # page (`limit = 100`) satisfies `> 50` without paginating the whole continent. - data <- get_sites(loc = europe_json[1], limit = 100) - testthat::expect_gt(length(data), 50) - - # Now, we know that all sites in cz_sites[[1]] should be in cz_sites[[3]], - # but the bounding box strategy means that the reverse is not true: + # This only needs to prove that a large region returns many sites; a single + # page (`limit = 100`) satisfies `> 50` without paginating the whole continent. + data <- get_sites(loc = europe_json[1], limit = 100) + testthat::expect_gt(length(data), 50) + + # Now, we know that all sites in cz_sites[[1]] should be in cz_sites[[3]], + # but the bounding box strategy means that the reverse is not true: + }) }) })