diff --git a/R/02_genericDefinitions.R b/R/02_genericDefinitions.R index af40681..a972bab 100644 --- a/R/02_genericDefinitions.R +++ b/R/02_genericDefinitions.R @@ -162,6 +162,14 @@ setGeneric("set_default", function(x, n) { standardGeneric(f = "set_default") }) + +#' @title Count the number of sites, datasets, or collectionunits associated with a site object. +#' @param level The level at which you want to count. Can be sites, collunits, or datasets. Default is sites. +#' @returns A count of the specified level in the object +#' @export +setGeneric("count", function(x, level="sites") + standardGeneric("count")) + #TODO # #' @title Obtain specimens from a record or multiple records. # #' @param x sites object diff --git a/R/site-methods.R b/R/site-methods.R index 5a05f9b..971ad29 100644 --- a/R/site-methods.R +++ b/R/site-methods.R @@ -530,4 +530,84 @@ setMethod(f = "cite_data", warning("No sites to cite.") return(NULL) } - }) \ No newline at end of file + }) + +#' @alias count-data, sites-method +setMethod( + "count", + "sites", + function(x, level = c("sites", "collunits", "datasets")) { + + level <- match.arg(level) + + switch( + level, + sites = length(x@sites), + collunits = { + ids <- unlist( + lapply( + x@sites, + function(site) { + vapply( + site@collunits@collunits, + function(cu) cu@collectionunitid, + integer(1) + )})) + length(unique(ids))}, + datasets = { + ids <- unlist( + lapply(x@sites,function(site) { + unlist(lapply( + site@collunits@collunits, + function(cu) { + vapply(cu@datasets@datasets, + function(ds) ds@datasetid, + integer(1) + )}))})) + length(unique(ids)) + } + )} +) + +#' @alias count-data, site-method +setMethod( + "count", + "site", + function(x, level = c("sites", "collunits", "datasets")) { + + level <- match.arg(level) + + switch( + level, + + sites = 1L, + + collunits = { + ids <- vapply( + x@collunits@collunits, + function(cu) cu@collectionunitid, + integer(1) + ) + + length(unique(ids)) + }, + + datasets = { + ids <- unlist( + lapply( + x@collunits@collunits, + function(cu) { + vapply( + cu@datasets@datasets, + function(ds) ds@datasetid, + integer(1) + ) + } + ) + ) + + length(unique(ids)) + } + ) + } +) \ No newline at end of file diff --git a/tester_serialized.R b/tester_serialized.R new file mode 100644 index 0000000..57b071b --- /dev/null +++ b/tester_serialized.R @@ -0,0 +1,62 @@ + + +logfile <- "tests_071726" + +sink(logfile, append = TRUE, split = TRUE) + +tests = c( + "tests/testthat/test_add_chronology.R", + "tests/testthat/test_c.R", + "tests/testthat/test_chroncontrols.R", + "tests/testthat/test_chronologies.R", + "tests/testthat/test_cite_data.R", + "tests/testthat/test_clean.R", + "tests/testthat/test_collunits.R", + "tests/testthat/test_coordinates.R", + "tests/testthat/test_datasets.R", + "tests/testthat/test_doi.R", + #"tests/testthat/test_examples.R", + "tests/testthat/test_filter.R", + "tests/testthat/test_get_contacts.R", + "tests/testthat/test_get_datasets.R", + "tests/testthat/test_get_documentation.R", + "tests/testthat/test_get_downloads.R", + "tests/testthat/test_get_manual.R", + "tests/testthat/test_get_publications.R", + "tests/testthat/test_get_sites.R", + #"tests/testthat/test_get_speleothems.R", + "tests/testthat/test_get_stats.R", + "tests/testthat/test_get_table.R", + "tests/testthat/test_get_taxa.R", + "tests/testthat/test_get_taxon.R", + "tests/testthat/test_getids.R", + "tests/testthat/test_length.R", + "tests/testthat/test_parse_location.R", + "tests/testthat/test_pingNeotoma.R", + "tests/testthat/test_plot.R", + "tests/testthat/test_plotLeaflet.r", + "tests/testthat/test_samples.R", + "tests/testthat/test_set_chronology.R", + "tests/testthat/test_set_collunit.R", + "tests/testthat/test_set_contact.R", + "tests/testthat/test_set_dataset.R", + "tests/testthat/test_set_default.R", + "tests/testthat/test_set_publication.R", + "tests/testthat/test_set_sample.R", + "tests/testthat/test_set_server.R", + "tests/testthat/test_set_site.R", + #"tests/testthat/test_set_speleothem.R", + "tests/testthat/test_sites.R", + #"tests/testthat/test_specimens.R", + #"tests/testthat/test_speleothems.R", + "tests/testthat/test_summary.R", + "tests/testthat/test_taxa.R", + "tests/testthat/test_toWide.R" +) + +for (i in tests) { + print(i) + source(i) + Sys.sleep(0.5) +} +sink() \ No newline at end of file diff --git a/tests/testthat/test_sites.R b/tests/testthat/test_sites.R index b66044c..80e457c 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,12 @@ 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: + }) })