Next release

CODE_DESIGN.md

@@ -4,7 +4,7 @@
 - API urls
   - are stored in `meta_info`, a tibble created in `data-raw/data_creation.R`
   - This is where you can change from main to sandbox versions
-  - https://birdscanada.org/api vs. https://sandbox.birdscanada.org/api
+  - https://naturecounts.ca/api vs. https://sandbox.naturecounts.ca/api
   - To apply this you must **re-run** `data-raw/data_creation.R` and then
     **re-load** the functions/package
 

DESCRIPTION

@@ -45,12 +45,14 @@ Suggests:
     sf (>= 1.0-9),
     spelling,
     testthat,
-    vdiffr
+    vdiffr,
+    rnaturalearthhires
 Language: en-US
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 URL: https://github.com/BirdsCanada/naturecounts,
     https://naturecounts.ca,
     https://birdscanada.github.io/naturecounts/
 VignetteBuilder: knitr
 Config/testthat/edition: 3
+Remotes: ropensci/rnaturalearthhires

NEWS.md

@@ -1,3 +1,8 @@
+# naturecounts dev
+* Add option to clip EOO in `cosewic_ranges()` to a particular shapefile before calculating area
+* Add option to scale records in `cosewic_plot()`
+* Change API to naturecounts.ca
+
 # naturecounts 0.4.1
 * Fix use of species_id and record_id in `cosewic_ranges()`.
   * Truly allow different columns

R/cosewic_tools.R

@@ -44,6 +44,9 @@
 #'   Defaults to 0.95 for a 95% convex hull to ensure outlier points do not
 #'   artificially inflate the EOO. Note that for a final COSEWIC report, this
 #'   may not be appropriate. Set to 1 to include all points.
+#' @param eoo_clip sf (Multi)Polygon. A spatial object to clip the EOO to. May
+#'   be relevant when calculating EOOs for complex regions (i.e. long curved
+#'   areas) to avoid including area which cannot have observations.
 #' @param filter_unique Logical. Whether to filter observations to unique 
 #'   locations. Use this only if there are too many data points to work with. 
 #'   This changes the nature of what an observation is, and also may bias 
@@ -86,6 +89,18 @@
 #' r <- cosewic_ranges(mult)
 #' r <- cosewic_ranges(mult, spatial = FALSE)
 #' 
+#' # Clip to a specific region
+#' @examplesIf requireNamespace("rnaturalearth", quietly = TRUE) & requireNamespace("rnaturalearthhires", quietly = TRUE)
+#' 
+#' library(rnaturalearth)
+#' ON <- ne_states("Canada") |> 
+#'   dplyr::filter(postal == "ON")
+#' 
+#' r <- cosewic_ranges(mult)
+#' cosewic_plot(r, map = ON) # No clip
+#' 
+#' r <- cosewic_ranges(mult, eoo_clip = ON)
+#' cosewic_plot(r, map = ON) # With clip
 #'
 #' @export 
 
@@ -96,6 +111,7 @@ cosewic_ranges <- function(df_db,
                            species = "species_id",
                            iao_grid_size_km = 2,
                            eoo_p = 0.95,
+                           eoo_clip = NULL,
                            filter_unique = FALSE,
                            spatial = TRUE) {
 
@@ -109,6 +125,12 @@ cosewic_ranges <- function(df_db,
   } else if (!all(is.numeric(df[[coord_lat]]), is.numeric(df[[coord_lat]]))) {
     stop("`coord_lat` and `coord_lon` must be numeric", call. = FALSE)
   }
+
+  # Clip
+  if(!is.null(eoo_clip) && !inherits(eoo_clip, "sf") && 
+     !all(sf::st_is(eoo_clip, c("POLYGON", "MULTIPOLYGON")))) {
+    stop("If provided, `eoo_clip` must be an sf polygon object", call. = FALSE)
+  }
 
   # Columns
   if(!is.null(species) && !species %in% names(df)) {
@@ -175,7 +197,7 @@ cosewic_ranges <- function(df_db,
     dplyr::left_join(n, by = species) %>%
     dplyr::relocate(dplyr::all_of(species), "n_records_total") %>%
     dplyr::mutate(
-      eoo = purrr::map(.data[["data"]], \(x) cosewic_eoo(x, p = eoo_p, spatial)),
+      eoo = purrr::map(.data[["data"]], \(x) cosewic_eoo(x, p = eoo_p, clip = eoo_clip, spatial)),
       iao = purrr::map(.data[["data"]], \(x) cosewic_iao(x, cell_size, record, spatial))) %>%
     dplyr::select(-"data")
 
@@ -269,20 +291,33 @@ cosewic_iao <- function(df_sf, cell_size, record, spatial) {
   iao  
 }
 
-cosewic_eoo <- function(df_sf, p, spatial) {
+cosewic_eoo <- function(df_sf, p, clip, spatial) {
   center <- df_sf %>%
     sf::st_union() %>%
     sf::st_convex_hull() %>%
     sf::st_centroid()
-  
+
   eoo <- df_sf %>%
     dplyr::mutate(dist = sf::st_distance(.data$geometry, .env$center)[, 1]) %>%
     dplyr::filter(.data$dist <= stats::quantile(.data$dist, .env$p)) %>%
     sf::st_cast(to = "POINT") %>%  
     sf::st_union() %>%
     sf::st_convex_hull() %>%
-    sf::st_as_sf() %>%
-    dplyr::mutate(eoo = sf::st_area(.),
+    sf::st_as_sf()
+
+  if(!is.null(clip)) {
+    clip <- sf::st_transform(clip, sf::st_crs(eoo))
+    eoo_clipped <- sf::st_intersection(sf::st_set_agr(eoo, "constant"), 
+                                       sf::st_set_agr(clip, "constant"))
+    if(nrow(eoo_clipped) == 0) {
+      warning("Clipping EOO results in no EOO, using non-clipped EOO instead", call. = FALSE)
+    } else {
+      eoo <- eoo_clipped
+    }
+  }
+
+  eoo <- eoo |>
+    dplyr::mutate(eoo = sf::st_area(eoo),
                   eoo = units::set_units(.data$eoo, "km^2"))
 
   if(!spatial) eoo <- sf::st_drop_geometry(eoo)
@@ -414,6 +449,9 @@ map_canada <- function() {
 #' @param grid sf data frame. Optional grid over which to summarize IAO values
 #'   (useful for species with many points over a broad distribution).
 #' @param map sf data frame. Optional base map over which to plot the values.
+#' @param scale Logical. Whether to scale the IAO legends to a proportion for
+#'   easier plotting of mutliple species (allows collecting legends by
+#'   patchwork).
 #' @param species Character. Name of the column containing species
 #'   identification.
 #' @param title Character. Optional title to add to the map. Can be a named by
@@ -425,13 +463,15 @@ map_canada <- function() {
 #' @examples
 #' r <- cosewic_ranges(bcch)
 #' cosewic_plot(r)
+#' cosewic_plot(r, scale = TRUE)
 #' cosewic_plot(r, points = bcch)
 #' cosewic_plot(r, grid = grid_canada(50), map = map_canada(), 
 #'              title = "Black-capped chickadees")
 #'              
 #' m <- rbind(bcch, hofi)
 #' r <- cosewic_ranges(m)
 #' cosewic_plot(r)
+#' cosewic_plot(r, scale = TRUE)
 #' cosewic_plot(r, points = m)
 #' p <- cosewic_plot(r, grid = grid_canada(50), map = map_canada(), 
 #'                  title = c("14280" = "Black-capped chickadees", 
@@ -440,6 +480,7 @@ map_canada <- function() {
 #' p[[2]]
 #' 
 cosewic_plot <- function(ranges, points = NULL, grid = NULL, map = NULL, 
+                         scale = FALSE, 
                          species = "species_id",  title = "") {
 
   have_pkg_check("sf")
@@ -490,14 +531,14 @@ cosewic_plot <- function(ranges, points = NULL, grid = NULL, map = NULL,
 
   g <- purrr::pmap(
     list(e, i, points, title), 
-    \(e, i, points, title) cosewic_plot_indiv(e, i, points, grid, map, title))
+    \(e, i, points, title) cosewic_plot_indiv(e, i, points, grid, map, scale, title))
 
   if(length(g) == 1) g <- g[[1]]
   g
 }
 
 
-cosewic_plot_indiv <- function(e, a, points, grid, map, title) {
+cosewic_plot_indiv <- function(e, a, points, grid, map, scale, title) {
 
   size_a <- unique(a$grid_size_km)
 
@@ -506,6 +547,10 @@ cosewic_plot_indiv <- function(e, a, points, grid, map, title) {
     stringr::str_replace("p(\\d{1,3})", "\\1%") %>%
     toupper()
 
+  records <- paste0(a$n_records_total[1], 
+                    " records\n(", a$min_record[1], "-", a$max_record[1], 
+                    " per ", size_a, "x", size_a, " km grid)")
+
   if(!is.null(grid)) {
     a <- a %>%
       sf::st_join(grid, ., left = FALSE) %>% # Inner join
@@ -515,6 +560,11 @@ cosewic_plot_indiv <- function(e, a, points, grid, map, title) {
   } else {
     size_p <- size_a
   }
+
+  if(scale) {
+    a <- dplyr::mutate(a, n_records = .data$n_records / max(.data$n_records, na.rm = TRUE))
+    leg_title <- "IAO\nProp. records"
+  } else leg_title <- "IAO\nNo. records"
 
   g <- ggplot2::ggplot() +
     ggplot2::theme_minimal() +
@@ -523,8 +573,9 @@ cosewic_plot_indiv <- function(e, a, points, grid, map, title) {
     ggplot2::scale_fill_viridis_c() +
     ggplot2::scale_colour_manual(name = "", values = "grey20") +
     ggplot2::labs(
-      fill = "IAO\nNo. records", 
+      fill = leg_title, 
       title = title,
+      subtitle = records,
       caption = 
         paste0("Showing ", size_p, "x", size_p, 
                "km grids\nAnalysis used ",

R/metadata_utils.R

@@ -30,12 +30,12 @@ metadata_v_remote <- function() {
 
 metadata_save <- function(data, path, name = deparse(substitute(data)),
                           compress = TRUE) {
-  save(data, file = file.path(path, paste0(name, ".rds")), compress = compress)
+  save(data, file = file.path(path, paste0("meta_", name, ".rds")), compress = compress)
 }
 
 metadata_read <- function(name) {
   data <- NULL # load(f) reads data into envir as 'data', use this to avoid NOTE
-  f <- system.file("extdata", paste0(name, ".rds"), package = "naturecounts")
+  f <- system.file("extdata", paste0("meta_", name, ".rds"), package = "naturecounts")
   if(!file.exists(f)) stop("Could not find metadata file '", name, "'",
                            call. = FALSE)
   load(f)
@@ -156,8 +156,8 @@ nc_metadata_internal <- function(path = "./inst/extdata", force = TRUE,
 
     # Update metadata version
     message("Metadata version updated to ", metadata_v_remote())
-    metadata_save(metadata_v_remote(), name = "metadata_v_local", path = path)
+    metadata_save(metadata_v_remote(), name = "v_local", path = path)
   }
 }
 
-metadata_v_local <- function() {metadata_read("metadata_v_local")}
+metadata_v_local <- function() {metadata_read("v_local")}

RELEASE.R

@@ -7,7 +7,9 @@
 devtools::test()
 
 # - Update internal data files
-source("data-raw/data_creation.R")
+source("data-raw/data_internal.R")
+source("data-raw/data_example.R")
+source("data-raw/data_test.R")
 
 # - Update metadata stored in inst/extdata (Check URLS in data-raw/data_creation.R)
 # - Utm codes take time to update

data-raw/data_example.R

@@ -0,0 +1,16 @@
+# Get Example Data ------------------------------------------------------------
+
+# Create example databases
+bcch <- nc_data_dl(request_id = 152543, username = "sample")
+usethis::use_data(bcch, internal = FALSE, overwrite = TRUE)
+
+hofi <- nc_data_dl(species = 20350, username = "sample", info = "pkg_data")
+usethis::use_data(hofi, internal = FALSE, overwrite = TRUE)
+
+unlink(file.path("inst", "extdata", "bcch.nc"))
+nc_data_dl(request_id = 152543, username = "sample", 
+           sql_db = file.path("inst", "extdata", "bcch"))
+
+unlink(file.path("inst", "extdata", "hofi.nc"))
+nc_data_dl(species = 20350, username = "sample", info = "pkg_data",
+           sql_db = file.path("inst", "extdata", "hofi"))

data-raw/data_creation.R → data-raw/data_internal.R

@@ -4,7 +4,7 @@ ua <- httr::user_agent(agent = "https://github.com/birdscanada/naturecounts")
 # API URLs
 meta_info <- dplyr::tribble(
   ~package_name,         ~api_url,                              ~primary_keys,
-  "api",                 "https://birdscanada.org/api", NA,
+  "api",                 "https://naturecounts.ca/api",        NA,
 
   "auth",                "/data/authenticate",                  NA,
 
@@ -75,15 +75,6 @@ queries <- dplyr::tribble(
   "subnational2",  "subNat2",       FALSE,
   "site_type",     "siteType",      TRUE)
 
-# Testing Data ------------------------------------------------------------
-test_rc <- nc_data_dl(request_id = 152518, fields_set = "core",
-                      username = "sample", info = "sample_data") |>
-  dplyr::filter(CommonName %in% c("Monarch",
-                                  "Black Swallowtail",
-                                  "Red Admiral"),
-                AllSpeciesReported == "Yes") |>
-  dplyr::mutate(presence = as.numeric(ObservationCount > 0)) |>
-  format_dates()
 
 # Field order - Non BMDE fields
 field_order <- c("record_id", "collection", "project_id", "protocol_id",
@@ -96,22 +87,6 @@ field_order <- c("record_id", "collection", "project_id", "protocol_id",
                  "source_table", "breeding_rank", "is_unconfirmed")
 
 # Save all internal datasets
-usethis::use_data(ua, api, keys, queries, test_rc, field_order,
+usethis::use_data(ua, api, keys, queries, field_order,
                   internal = TRUE, overwrite = TRUE)
 
-# Get Example Data ------------------------------------------------------------
-
-# Create example databases
-bcch <- nc_data_dl(request_id = 152543, username = "sample")
-usethis::use_data(bcch, internal = FALSE, overwrite = TRUE)
-
-hofi <- nc_data_dl(species = 20350, username = "sample", info = "pkg_data")
-usethis::use_data(hofi, internal = FALSE, overwrite = TRUE)
-
-unlink(file.path("inst", "extdata", "bcch.nc"))
-nc_data_dl(request_id = 152543, username = "sample", 
-           sql_db = file.path("inst", "extdata", "bcch"))
-
-unlink(file.path("inst", "extdata", "hofi.nc"))
-nc_data_dl(species = 20350, username = "sample", info = "pkg_data",
-           sql_db = file.path("inst", "extdata", "hofi"))

data-raw/data_test.R

@@ -0,0 +1,11 @@
+# Testing Data ------------------------------------------------------------
+test_rc <- nc_data_dl(request_id = 152518, fields_set = "core",
+                      username = "sample", info = "sample_data") |>
+  dplyr::filter(CommonName %in% c("Monarch",
+                                  "Black Swallowtail",
+                                  "Red Admiral"),
+                AllSpeciesReported == "Yes") |>
+  dplyr::mutate(presence = as.numeric(ObservationCount > 0)) |>
+  format_dates()
+
+saveRDS(test_rc, file.path(system.file("extdata", package = "naturecounts"), "test_data.rds"))