#' @importFrom DBI dbDisconnect dbExistsTable dbExecute dbGetQuery
#' @noRd
#' @family admin
am_create_fts <- function(con, overwrite = TRUE) {
if (missing(con)) {
con <- con_am("sqlite")
on.exit(DBI::dbDisconnect(con))
}
if (overwrite)
if (DBI::dbExistsTable(con, "fts"))
am_drop_fts()
if (!"fts" %in% dbListTables(con)) {
DBI::dbExecute(con, statement =
"create virtual table fts using fts5(
key, terms
);")
DBI::dbExecute(con, statement = paste0(
"insert into fts select SpeciesID as key, printf('",
paste(collapse = " ", rep("%s", 8)), "',
`Genus`, `Species`, `FBname`,
`Kingdom`, `Phylum`, `Class`,
`Order`, `Family`
) as terms FROM speciesoccursum_r;"))
}
n_keys <- DBI::dbGetQuery(con, "select count(*) from fts;")
message("Added FTS index for ", n_keys, " keys.")
}
#' Fuzzy search for terms related to taxonomic names
#' @param search_term token query, phrase query or NEAR query
#' (see http://www.sqlite.org/fts5.html)
#' @return tibble with matching keys (database identifiers)
#' @examples \dontrun{
#' am_search_fuzzy("trevally")
#' am_search_fuzzy("trevally OR animalia")
#' }
#' @export
#' @family general
am_search_fuzzy <- function(search_term) {
query <- paste("select key, terms from fts",
sprintf("where terms match '%s'", search_term))
am_custom_query(query)
}
#' Run a custom SQL query
#' @param sql_query the query
#' @param con the connection to use, if missing an sqlite con is used
#' @param ... other arguments to be passed to the sql() fcn
#' @examples \dontrun{
#' am_custom_query("select * from speciesoccursum_r", con = con_am("extdata"))
#' }
#' @importFrom dplyr sql tbl collect
#' @importFrom DBI dbDisconnect
#' @export
#' @family admin
am_custom_query <- function(sql_query, con, ...) {
if (missing(con)) {
con <- db_cache$local_db
}
con %>%
tbl(sql(sql_query, ...)) %>%
collect()
}
#' @importFrom DBI dbRemoveTable
#' @importFrom purrr map
#' @noRd
#' @family admin
am_drop_fts <- function(con) {
if (missing(con)) {
con <- con_am("sqlite")
on.exit(DBI::dbDisconnect(con))
}
fts_shadow_tables <- function(tablename)
sprintf("%s_%s", tablename,
c("data", "idx", "config", "content", "docsize"))
drop_table <- function(x)
DBI::dbRemoveTable(con, x, fail_if_missing = FALSE)
fts_tabs <- c("fts", fts_shadow_tables("fts"))
fts_tabs %>% purrr::map(drop_table)
}
#' Exact search for taxonomic names
#'
#' Search taxonomic names with or without parameters specified.
#' - If parameters are given, the intersection of matching records
#' are returned.
#' - If no parameters are given, all records are returned.
#' - If parameters are specified with NULL specified, examples of
#' valid combinations of values are returned.
#' @param SpeciesID AquaMaps unique identifier for a valid species used by the
#' Catalogue of Life Annual Checklist (www.catalogueoflife.org). Example for
#' the whale shark: Fis-30583
#' @param SpecCode Species identifier used in FishBase or SeaLifeBase
#' @param Genus Genus name of the species
#' @param Species Specific epithet of the species
#' @param FBname Common name suggested by FishBase or SeaLifeBase
#' @param OccurRecs Number of point records used to generate good cells
#' @param OccurCells Number of good cells used to generate species envelope
#' @param StockDefs Distribution of the species as recorded in
#' FishBase or SeaLifeBase
#' @param Kingdom Kingdom to which the species belongs
#' @param Phylum Phylum to which the species belongs
#' @param Class Class to which the species belongs
#' @param Order Order to which the species belongs
#' @param Family Family to which the species belongs
#' @param deepwater Does the species occur in the deep-sea (i.e. tagged
#' bathypelagic or bathydemersal in FishBase or SeaLifeBase)? 0=No, 1=Yes
#' @param angling Is the species a sport fish (i.e. tagged as a GameFish in
#' FishBase)? 0=No, 1=Yes
#' @param diving Is the species found on a dive (i.e. where DepthPrefMin in
#' HSPEN < 20 meters)? 0=No, 1=Yes
#' @param dangerous Is the species dangerous (i.e. tagged as traumatogenic or
#' venonous in FishBase or SeaLifeBase)? 0=No, 1=Yes
#' @param m_invertebrates Is the species a marine invertebrate? 0=No, 1=Yes
#' @param highseas Is the species an open ocean fish species (i.e. tagged as
#' pelagic-oceanic in FishBase)? 0=No, 1=Yes
#' @param invasive Is the species recorded to be invasive (i.e. in FishBase
#' or SeaLifeBase)? 0=No, 1=Yes
#' @param resilience Resilience of the species (i.e. as recorded in
#' FishBase/SeaLifeBase)
#' @param iucn_id IUCN species identifier
#' @param iucn_code IUCN Red list classification assigned to the species
#' @param iucn_version IUCN version
#' @param provider FishBase (FB) or SeaLifeBase (SLB)?
#' @return tibble with results...
#' @examples \dontrun{
#' am_search_exact()
#' am_search_exact(Species = "bucculentus")
#' am_search_exact(FBname = NULL, provider = NULL)
#' }
#' @export
#' @family general
am_search_exact <- function(
SpeciesID=NULL, SpecCode=NULL, Genus=NULL, Species=NULL, FBname=NULL,
OccurRecs=NULL, OccurCells=NULL, StockDefs=NULL, Kingdom=NULL, Phylum=NULL,
Class=NULL, Order=NULL, Family=NULL, deepwater=NULL, angling=NULL,
diving=NULL, dangerous=NULL, m_invertebrates=NULL, highseas=NULL,
invasive=NULL, resilience=NULL, iucn_id=NULL, iucn_code=NULL,
iucn_version=NULL, provider=NULL) {
args <- as.list(match.call(expand.dots = TRUE)[-1])
tc <- function(l) Filter(Negate(is.null), l)
tcn <- function(l) Filter(is.null, l)
if (length(tcn(args)) > 0) {
nullfields <- paste0(collapse = ", ", names(tcn(args)))
message("Got NULL params for ", nullfields)
message("Showing some example combinations")
sql <-
sprintf(paste0("select distinct * from (select %s ",
"from speciesoccursum_r limit 100) limit 10"), nullfields)
return(am_custom_query(sql))
}
if (!(length(tc(args)) > 0))
return(am_custom_query("select * from speciesoccursum_r"))
dbq <- function(x)
DBI::dbQuoteString(DBI::ANSI(),
DBI::dbQuoteString(DBI::ANSI(), DBI::SQL(x)))
sql_where <- function(x)
sprintf('%s = "%s"', names(x), dbq(x))
kv <- purrr::map(tc(args), eval)
sql_where <- paste(collapse = " and ", sql_where(kv))
sql <- sprintf("select * from speciesoccursum_r where %s", sql_where)
message("query: ", sql)
am_custom_query(sql)
}
#' @importFrom DBI dbDisconnect dbExecute
#' @noRd
#' @family admin
am_create_indexes <- function(con) {
if (missing(con)) {
con <- con_am("sqlite")
on.exit(DBI::dbDisconnect(con))
}
i <-
aquamapsdata::am_meta %>%
filter(.data$field %in% c("SpeciesID", "LOICZID", "CsquareCode")) %>%
select(.data$table, .data$field)
idx <- paste0(i$field, seq_len(length(i$field)))
sql <-
sprintf("create index if not exists [%s] on %s([%s])",
idx, i$table, i$field)
execute <- function(x) {
res <- DBI::dbExecute(con, x)
message("Index created: ", res, ", sql: ", x)
res
}
res <- sql %>% map(execute)
if (!all(res == 0)) message("Done")
}
#' @family general
am_keys <- function() {
con <- db_cache$local_db
con %>%
dplyr::tbl("speciesoccursum_r") %>%
dplyr::distinct(.data$SpeciesID) %>%
dplyr::collect() %>%
dplyr::pull(.data$SpeciesID)
}
#' @importFrom rlang .data
#' @noRd
#' @family general
am_nativemaps <- function(key) {
if (!all(key %in% am_keys()))
stop("Please specify valid key(s)")
con <- db_cache$local_db
con %>%
dplyr::tbl("hcaf_species_native") %>%
dplyr::filter(.data$SpeciesID %in% key) %>%
dplyr::collect() %>%
dplyr::select(
.data$SpeciesID, .data$CsquareCode,
.data$CenterLat, .data$CenterLong,
.data$Probability) %>%
dplyr::rename(lat = "CenterLat", lon = "CenterLong")
}
#' Half degree cell location reference data
#' This table represents an authority file with reference data for half degree
#' cell locations.
#' @examples \dontrun{
#' am_hcaf()
#' }
#' @export
#' @importFrom dplyr tbl
#' @family general
am_hcaf <- function() {
con <- db_cache$local_db
con %>%
dplyr::tbl("hcaf_r")
}
#' Environmental envelope preference data for suitable habitats for species
#' This table provides data on species environmental parameters / preferences
#' @examples \dontrun{
#' keys <- am_search_fuzzy("trevally")$key[1:2]
#' am_hspen() %>% filter(SpeciesID %in% keys)
#' }
#' @export
#' @importFrom dplyr tbl
#' @family general
am_hspen <- function() {
con <- db_cache$local_db
con %>%
dplyr::tbl("hspen_r")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.