Tissue Samples Locator Demo

# Load core libraries; install these packages if you have not already
library(ridigbio)
library(tidyverse)

# Load library for making nice HTML output
library(kableExtra)

# Edit the fields (e.g. `genus`) and values (e.g. "manis") in `list()` 
# to adjust your query and the fields (e.g. `uuid`) in `fields` to adjust the
# columns returned in your results
records <- idig_search_records(rq = list(genus = c("manis",
                                                   "rhinolophus",
                                                   "paguma")),
                       fields = c("uuid",
                                  "recordset",
                                  "institutioncode",
                                  "genus",
                                  "scientificname",
                                  "country",
                                  "data.dwc:year",
                                  "data.dwc:collectionCode",
                                  "catalognumber",
                                  "data.dwc:preparations"))

# List distinct values for the `preparation` field
prepsummary <- records %>% 
  group_by(`data.dwc:preparations`) %>% 
  tally()

# Display `prepsummary` in HTML output
knitr::kable(prepsummary) %>% 
    kable_styling(bootstrap_options = 
                         c("striped", "hover", "condensed", "responsive"),
                  full_width = FALSE) %>% 
  scroll_box(height = "400px")

# Count how many records in the data were contributed by each recordset
recordtally <- recordsfiltered %>% 
  group_by(recordset) %>% 
  tally() %>% rename()

# Get metadata from the attributes of the `records` data frame
collections <- tibble(collection = attr(recordsfiltered, "attribution")) %>% 
  # Expand information captured in nested lists
  hoist(collection, 
        recordset_uuid = "uuid",
        recordset_name = "name",
        recordset_url= "url",
        contacts = "contacts") %>% 
  # Get rid of extraneous attribution metadata
  select(-collection) %>% 
  # Expand information captured in nested lists
  unnest_longer(contacts) %>% 
  # Expand information captured in nested lists
  unnest_wider(contacts) %>% 
  # Remove any contacts without an email address listed
  filter(!is.na(email)) %>% 
  # Get rid of duplicate contacts within the same recordset
  distinct() %>% 
  # Rename some columns
  rename(contact_role = role, contact_email = email) %>% 
  # Group first and last names together in the same column
  unite(col = "contact_name", 
        first_name, last_name, 
        sep = " ", 
        na.rm = TRUE) %>% 
  # Restructure data frame so that there is one row per recordset
  group_by(recordset_uuid) %>% 
  mutate(contact_index = row_number()) %>%
  mutate(recordset_url = if_else(grepl("^http://", recordset_url),
    gsub("^http://", "https://", recordset_url),
    recordset_url
  )) %>%
  mutate(recordset_url = if_else(grepl("www.amnh.org/our-research/vertebrate-zoology/mammalogy", recordset_url),
    gsub("www.amnh.org/our-research/vertebrate-zoology/mammalogy", "www.amnh.org/research/vertebrate-zoology/mammalogy", recordset_url),
    recordset_url
  )) %>%
  mutate(recordset_url = if_else(grepl("www.burkemuseum.org/mammalogy", recordset_url),
    gsub("www.burkemuseum.org/mammalogy", "www.burkemuseum.org/collections-and-research/biology/mammalogy", recordset_url),
    recordset_url
  )) %>%
  mutate(recordset_url = if_else(grepl("www.nhm.org", recordset_url),
    gsub("www.nhm.org", "nhm.org", recordset_url),
    recordset_url
  )) %>%
  mutate(recordset_url = if_else(
    grepl("appl003.lsu.edu/natsci/lmns.nsf/\\$Content/Mammals\\?OpenDocument", recordset_url),
    gsub("appl003.lsu.edu/natsci/lmns.nsf/\\$Content/Mammals\\?OpenDocument", "appl103.lsu.edu/natsci/Collections/natscicolsearch.nsf/OpenMainPage?OpenAgent&ID=1042", recordset_url),
    recordset_url
  )) %>%
  mutate(recordset_url = if_else(grepl("www.nsrl.ttu.edu/collections/Mammals/index.htm", recordset_url),
    gsub("www.nsrl.ttu.edu/collections/Mammals/index.htm", "www.depts.ttu.edu/nsrl/collections/mammal.php", recordset_url),
    recordset_url
  )) %>%
  mutate(recordset_url = if_else(grepl("sites01.lsu.edu/wp/mns/research-collections/genetic-resources/", recordset_url),
    gsub("sites01.lsu.edu/wp/mns/research-collections/genetic-resources/", "appl103.lsu.edu/natsci/Collections/natscicolsearch.nsf/OpenMainPage?OpenAgent&ID=1050", recordset_url),
    recordset_url
  )) %>%
  mutate(recordset_url = if_else(grepl("https://www.msb.unm.edu", recordset_url),
    gsub("www.msb.unm.edu", "www.msb.unm.edu", recordset_url),
    recordset_url
  )) %>%
  pivot_wider(names_from = contact_index,
                values_from = c(contact_name, contact_role, contact_email)) %>%
  # Include how many records in the data were contributed by each recordset
  left_join(recordtally, by = c("recordset_uuid"="recordset")) %>% 
   # Filter and remove n = 0
  filter(!is.na(n)) %>% 
  # Get rid of any rows which don't actually contribute data to `records`;
  # necessary because the attribute metadata by default includes all recordsets
  # in iDigBio that match the `idig_search_records` query, even if you filter
  # or limit those results in your own code
  filter(recordset_uuid %in% records$recordset)