Count entities

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

R/site-methods.R

@@ -530,4 +530,84 @@ setMethod(f = "cite_data",
               warning("No sites to cite.")
               return(NULL)
             }
-          })
+          })
+
+#' @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))
+      }
+    )
+  }
+)

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()

tests/testthat/test_sites.R

@@ -5,81 +5,96 @@ 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],
            [61.87499999999999, 39.36827914916014],
            [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:
+  })
 })