throw_error <- function(src, x) {
if (as.logical(Sys.getenv("SPOCC_THROW_ERRORS", FALSE))) {
warning(src, ": ", x, call. = FALSE)
}
}
# Plugins for the occ function for each data source
## the plugins
#' @noRd
foo_gbif <- function(sources, query, limit, start, geometry, has_coords,
date, callopts, opts) {
if (any(grepl("gbif", sources))) {
opts$hasCoordinate <- has_coords
# skip WKT validation for now, GBIF follows "left hand rule"
opts$skip_validate <- TRUE
if (!is.null(query)) {
if (class(query) %in% c("ids", "gbifid")) {
if (class(query) %in% "ids") {
query_use <- opts$taxonKey <- query$gbif
} else {
query_use <- opts$taxonKey <- query
}
} else {
query_use <- query
if (is.null(query_use)) {
warning(sprintf("No GBIF result found for %s", query))
} else {
opts$scientificName <- query_use
}
}
} else {
query_use <- NULL
}
if (!is.null(date)) {
if (length(date) != 2) stop("'date' for GBIF must be length 2")
opts$eventDate <- paste0(date, collapse = ",")
}
if (is.null(query_use) && is.null(geometry) && length(opts) == 0) {
warning(sprintf("No records returned in GBIF for %s", query), call. = FALSE)
emptylist(opts)
} else {
time <- now()
if (!'limit' %in% names(opts)) opts$limit <- limit
if (!'start' %in% names(opts)) opts$start <- start
if (!is.null(geometry)) {
opts$geometry <- if (grepl('POLYGON', paste(as.character(geometry),
collapse = " "))) {
geometry
} else {
bbox2wkt(bbox = geometry)
}
}
if (length(callopts) > 0) opts$curlopts <- callopts
out <- tryCatch(do.call("occ_data", opts), error = function(e) e)
if (inherits(out, "error")) {
throw_error("gbif", sprintf("No records returned in GBIF for %s", query))
throw_error("gbif", out$message)
emptylist(opts, out$message)
} else {
if (inherits(out, "character")) {
emptylist(opts)
} else {
if (
all(names(out) %in% c('meta', 'data')) &&
(is.null(out$data) ||
inherits(out$data, "character"))
) {
emptylist(opts)
} else {
if (length(out) > 1 && !all(c('meta', 'data') %in% names(out))) {
dat <- setDF(rbindlist(lapply(out, "[[", "data"),
fill = TRUE, use.names = TRUE))
} else {
dat <- out$data
}
if (NROW(dat) == 0) {
return(emptylist(opts))
}
dat$prov <- rep("gbif", nrow(dat))
dat$name <- as.character(dat$name)
cols <- c('name', 'decimalLongitude', 'decimalLatitude',
'issues', 'prov')
cols <- cols[ cols %in% sort(names(dat)) ]
dat <- move_cols(x = dat, y = cols)
dat <- stand_latlon(dat)
dat <- add_latlong_if_missing(dat)
dat <- stand_dates(dat, "gbif")
list(time = time, found = out$meta$count,
data = as_tibble(dat), opts = opts)
}
}
}
}
} else {
emptylist(opts)
}
}
#' @noRd
foo_inat <- function(sources, query, limit, page, geometry, has_coords,
date, callopts, opts) {
if (any(grepl("inat", sources))) {
opts <- limit_alias(opts, "inat")
opts$geo <- has_coords
time <- now()
opts$taxon_name <- query
if (!"maxresults" %in% names(opts)) opts$maxresults <- limit
if (!"page" %in% names(opts)) opts$page <- page
if (!is.null(geometry)) {
opts$bounds <- if (grepl("POLYGON", paste(as.character(geometry),
collapse = " "))) {
# flip lat and long spots in the bounds vector for inat
temp <- wkt2bbox(geometry)
c(temp[2], temp[1], temp[4], temp[3])
} else {
c(geometry[2], geometry[1], geometry[4], geometry[3])
}
}
if (!is.null(date)) {
if (length(date) != 2) stop("'date' for Inaturalist must be length 2")
opts$date_start <- date[1]
opts$date_end <- date[2]
}
opts$callopts <- callopts
out <- tryCatch(do.call("spocc_inat_obs", opts), error = function(e) e)
if (!is.data.frame(out$data) || inherits(out, "simpleError")) {
throw_error("inat",
sprintf("No records returned in INAT for %s", query))
throw_error("inat", out$message)
emptylist(opts, out$message)
} else{
res <- out$data
res$prov <- rep("inat", nrow(res))
res <- rename(res, c("taxon.name" = "name"))
# pull out lon/lat from geojson field
cds <- res$geojson.coordinates
lons <- sapply(cds, "[[", 1)
lons[vapply(lons, is.null, logical(1))] <- NA_character_
res$longitude <- unlist(lons)
lats <- sapply(cds, "[[", 2)
lats[vapply(lats, is.null, logical(1))] <- NA_character_
res$latitude <- unlist(lats)
res <- stand_latlon(res)
res <- add_latlong_if_missing(res)
res <- stand_dates(res, "inat")
list(time = time, found = out$meta$found, data = as_tibble(res),
opts = opts)
}
} else {
emptylist(opts)
}
}
#' @noRd
foo_ebird <- function(sources, query, limit, callopts, opts) {
if (any(grepl("ebird", sources))) {
opts <- limit_alias(opts, "ebird")
time <- now()
if (is.null(opts$method))
opts$method <- "ebirdregion"
if (!opts$method %in% c("ebirdregion", "ebirdgeo"))
stop("ebird method must be one of ebirdregion or ebirdgeo")
spnm <- tryCatch(suppressMessages(rebird::species_code(query)),
error = function(e) e)
if (inherits(spnm, "error")) {
warning(spnm$message, ": ", query, call. = FALSE)
return(emptylist(opts, spnm$message))
}
opts$species <- spnm
if (!'max' %in% names(opts)) opts$max <- limit
opts$opts <- callopts
if (opts$method == "ebirdregion") {
if (is.null(opts$loc)) opts$loc <- "US"
out <- tryCatch(do.call(spocc_ebird_region, opts[!names(opts) %in% "method"]),
error = function(e) e, warning = function(w) w)
} else {
out <- tryCatch(do.call(spocc_ebirdgeo, opts[!names(opts) %in% "method"]),
error = function(e) e, warning = function(w) w)
}
if (!is.data.frame(out) || inherits(out, "simpleError") || NROW(out) == 0) {
throw_error("ebird",
sprintf("No records returned in eBird for %s", query))
throw_error("ebird", out$message)
emptylist(opts, out$message)
} else {
out$prov <- rep("ebird", nrow(out))
names(out)[names(out) == 'sciName'] <- "name"
out <- stand_latlon(out)
out <- add_latlong_if_missing(out)
out <- stand_dates(out, "ebird")
list(time = time, found = NULL, data = as_tibble(out), opts = opts)
}
} else {
emptylist(opts)
}
}
#' @noRd
foo_vertnet <- function(sources, query, limit, has_coords, date, callopts, opts) {
if (any(grepl("vertnet", sources))) {
time <- now()
if (!is.null(has_coords)) {
opts$mappable <- has_coords
}
opts$scientificname <- query
opts$messages <- FALSE
if (!is.null(date)) {
if (length(date) != 2) stop("'date' for Vertnet must be length 2")
date <- tryCatch(as.Date(date), error = function(e) e)
if (inherits(date, "error")) stop("'date' values do not appear to be dates")
opts$year <- c(paste0('>=', format(date[1], "%Y")),
paste0('<=', format(date[2], "%Y")))
opts$month <- c(paste0('>=', as.numeric(format(date[1], "%m"))),
paste0('<=', as.numeric(format(date[2], "%m"))))
opts$day <- c(paste0('>=', as.numeric(format(date[1], "%d"))),
paste0('<=', as.numeric(format(date[2], "%d"))))
}
if (!'limit' %in% names(opts)) opts$limit <- limit
opts$callopts <- callopts
out <- tryCatch(do.call(rvertnet::searchbyterm, opts),
error = function(e) e)
if (!is.data.frame(out$data) || inherits(out, "simpleError")) {
throw_error("vertnet",
sprintf("No records returned in VertNet for %s", query))
throw_error("vertnet", out$message)
emptylist(opts, out$message)
} else{
df <- out$data
df$prov <- rep("vertnet", NROW(df))
df <- rename(df, c('scientificname' = 'name'))
cols <- c('name', 'decimallongitude', 'decimallatitude', 'prov')
cols <- cols[ cols %in% sort(names(df)) ]
df <- move_cols(x = df, y = cols)
df <- stand_latlon(df)
df <- add_latlong_if_missing(df)
df <- stand_dates(df, "vertnet")
names(df) <- tolower(names(df))
list(time = time,
found = as.numeric(gsub(">|<", "", out$meta$matching_records)),
data = as_tibble(df), opts = opts)
}
} else {
emptylist(opts)
}
}
#' @noRd
foo_idigbio <- function(sources, query, limit, start, geometry, has_coords,
date, callopts, opts) {
if (any(grepl("idigbio", sources))) {
time <- now()
addopts <- list()
if (!is.null(query)) addopts$rq <- list(scientificname = query)
if (!is.null(has_coords)) opts$rq$geopoint <- if (has_coords) {
list(type = "exists")
} else {
list(type = "missing")
}
if (!is.null(date)) {
if (length(date) != 2) stop("'date' for IdigBio must be length 2")
opts$rq$datecollected <- list(type = "range", gte = date[1], lte = date[2])
}
if (!is.null(geometry)) {
if (grepl('POLYGON', paste(as.character(geometry), collapse = " "))) {
geometry <- unlist(unname(c(wkt2bbox(geometry))))
}
# force all geometry requests into this format if possible
addopts$rq <- c(addopts$rq,
list(geopoint = list(
type = "geo_bounding_box",
top_left = list(
lat = geometry[4], lon = geometry[1]
),
bottom_right = list(
lat = geometry[2], lon = geometry[3]
)
))
)
}
if ("rq" %in% names(opts)) {
opts$rq <- c(addopts$rq, opts$rq)
} else {
opts$rq <- addopts$rq
}
if (!"limit" %in% names(opts)) opts$limit <- limit
if (!'offset' %in% names(opts)) opts$offset <- start
if (is.null(opts$fields)) opts$fields <- "all"
opts$config <- callopts
out <- tryCatch(suppressWarnings(
do.call(ridigbio::idig_search_records, opts)), error = function(e) e)
if (inherits(out, "simpleError")) {
throw_error("idigbio",
sprintf("No records returned in iDigBio for %s", query))
throw_error("idigbio", out$message)
emptylist(opts, out$message)
} else{
out$prov <- rep("idigbio", nrow(out))
out <- rename(out, c('scientificname' = 'name'))
out <- add_latlong(out, nms = c('geopoint.lon', 'geopoint.lat'))
out <- stand_latlon(out)
out <- add_latlong_if_missing(out)
out <- stand_dates(out, "idigbio")
list(time = time, found = attr(out, "itemCount"),
data = as_tibble(out), opts = opts)
}
} else {
emptylist(opts)
}
}
#' @noRd
foo_obis <- function(sources, query, limit, start, geometry, has_coords,
date, callopts, opts) {
if (any(grepl("obis", sources))) {
time <- now()
opts$scientificName <- query
if (!is.null(geometry)) {
opts$geometry <- if (grepl('POLYGON', paste(as.character(geometry),
collapse = " "))) {
geometry
} else {
bbox2wkt(bbox = geometry)
}
}
if (!is.null(date)) {
if (length(date) != 2) stop("'date' for OBIS must be length 2")
opts$startdate <- date[1]
opts$enddate <- date[2]
}
if (!"limit" %in% names(opts)) opts$size <- limit
if (!'offset' %in% names(opts)) opts$offset <- start
opts <- c(opts, callopts)
tmp <- tryCatch(do.call(obis_search, opts), error = function(e) e)
if (inherits(tmp, "simpleError") || "error" %in% names(tmp)) {
throw_error("obis",
sprintf("No records returned in OBIS for %s", query))
throw_error("obis", tmp$error)
emptylist(opts, tmp$error)
} else {
if (!"results" %in% names(tmp)) {
warning(sprintf("No records returned in OBIS for %s", query))
emptylist(opts)
} else {
out <- tmp$results
out$prov <- rep("obis", NROW(out))
out <- rename(out, c('scientificName' = 'name'))
out <- add_latlong(out, nms = c('decimalLongitude', 'decimalLatitude'))
out <- stand_latlon(out)
out <- add_latlong_if_missing(out)
out <- stand_dates(out, "obis")
list(time = time, found = tmp$count, data = out, opts = opts)
}
}
} else {
emptylist(opts)
}
}
#' @noRd
foo_ala <- function(sources, query, limit, start, geometry, has_coords,
date, callopts, opts) {
if (any(grepl("ala", sources))) {
time <- now()
opts$taxon <- sprintf('taxon_name:"%s"', query)
if (!is.null(date)) {
if (length(date) != 2) stop("'date' for ALA must be length 2")
opts$taxon <- paste0(opts$taxon, sprintf(" occurrence_date:[%s TO %s]", date[1], date[2]))
}
if (!is.null(geometry)) {
opts$wkt <- if (grepl('POLYGON', paste(as.character(geometry),
collapse = " "))) {
geometry
} else {
bbox2wkt(bbox = geometry)
}
}
if (!"limit" %in% names(opts)) opts$limit <- limit
if (!'offset' %in% names(opts)) opts$offset <- start
opts <- c(opts, callopts)
tmp <- tryCatch(do.call(ala_search, opts), error = function(e) e)
if (inherits(tmp, "error")) {
throw_error("ala",
sprintf("No records returned in ALA for %s", query))
throw_error("ala", tmp$message)
emptylist(opts, tmp$message)
} else {
if (!"occurrences" %in% names(tmp)) {
warning(sprintf("No records returned in ALA for %s", query))
emptylist(opts)
} else {
if (!length(tmp$occurrences)) {
warning(sprintf("No records returned in ALA for %s", query))
emptylist(opts)
} else {
out <- tmp$occurrences
out$prov <- rep("ala", NROW(out))
out <- rename(out, c('scientificName' = 'name'))
out <- add_latlong(out, nms = c('decimalLongitude', 'decimalLatitude'))
out <- stand_latlon(out)
out <- add_latlong_if_missing(out)
out <- stand_dates(out, "ala")
list(time = time, found = tmp$totalRecords, data = out, opts = opts)
}
}
}
} else {
emptylist(opts)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.