#' NCBI BioSamples
#'
#' These functions help manage BioSamples spreadsheets and individual attribute
#' fields.
#'
#' Notable functions:
#'
#' * \code{\link{build_biosamples_from_template}}: make a new spreadsheet from a
#' template name and existing metadata
#' * \code{\link{write_biosamples}}: save a prepared biosamples spreadsheet to a
# ' file
#'
#' @md
#'
#' @name biosamples
NULL
#' Create BioSamples Table
#'
#' Create a new BioSamples table using a named template and existing sample
#' attributes.
#'
#' @param package_name name of BioSample Package for the template to use, as
#' either the display name (e.g., "MIGS: cultured bacteria/archaea,
#' human-associated; version 4.0") or the short name (e.g.,
#' "MIGS.ba.human-associated.4.0"). Call \code{\link{list_templates}} to see
#' all the pre-installed templates by their short name.
#' @param sample_attrs data frame of existing sample metadata to draw from. Any
#' names given in the \code{col_pairs} argument will be used to explicitly map
#' column names from the existing data frame to the new data frame. Remaining
#' columns with matching names will also be used. Other columns not in
#' \code{col_pairs} or the template's fields are ignored.
#' @param submission the accession assigned by the submission portal for the
#' submission, like "SUB####". Will be attached to the output data frame as
#' an attribute.
#' @param col_pairs named vector of column names in the existing data frame with
#' names set to column names in the new data frame. Vector names that don't
#' match known column names signify custom columns to add.
#' @param constants vector of field names to match to constant values for all
#' samples.
#'
#' @return data frame with BioSample attributes defined.
#' @export
build_biosamples_from_template <- function(package_name,
sample_attrs,
submission=NULL,
col_pairs=NULL,
constants=NULL) {
# Figure out what template to use. By default try to use the package name
# given, and if that isn't found, try using that as a display name (the
# long-format one shown on the web pages). If neither works, warn.
template_name <- package_name
if (! package_name %in% list_templates()) {
pkgs <- read_biosample_packages()
template_name <- pkgs[pkgs[["DisplayName"]] == package_name, "Name"]
if (is.null(template_name)) {
warning(paste("Template name not recognzied:", package_name))
}
}
# Read in the relevant template from disk.
template <- read_template(template_name, "biosample_attributes")
# Build biosamples data frame, using rows from sample attributes, columns and
# column classes from template.
len <- nrow(sample_attrs) * ncol(template)
biosamples <- as.data.frame(matrix( (1:len) * NA, nrow = nrow(sample_attrs)))
colnames(biosamples) <- colnames(template)
for (j in 1:ncol(template)) {
biosamples[[j]] <- methods::as(biosamples[[j]],
class(template[[j]]))
}
# Add object attributes from template
for (a in names(attributes(template))) {
if (! a %in% names(attributes(biosamples)))
attr(biosamples, a) <- attr(template, a)
}
if (! is.null(submission)) {
attr(biosamples, "submission") <- submission
}
attr(biosamples, "template") <- template_name
# Match up columns for sample attributes table
biosamples <- fill_from_columns(biosamples, sample_attrs, col_pairs)
if (! is.null(constants)) {
for (column in names(constants))
biosamples[[column]] <- constants[[column]]
}
biosamples
}
#' Write BioSample attributes or metadata to disk
#'
#' These functions write spreadsheets to the working directory by type
#' (BioSample attributes or library metadata) with the naming scheme
#' \code{<submission>/<submission>_<type>.tsv} if submission is defined or just
#' \code{<type>.tsv} otherwise.
#'
#' @param data data frame of metadata
#' @param ... additional arguments for \code{\link{write_table}}
#'
#' @export
#' @describeIn write_biosamples Write BioSample attributes to disk
write_biosamples <- function(data, ...) {
write_table(data, fp_suffix = "biosamples", ...)
}
# BioSample Package / Template Info ---------------------------------------
# These functions are structured in pairs of download/read steps, so we can
# keep a raw copy of the metadata inside the package and update from NCBI when
# needed.
#' Download BioSample Metadata
#'
#' Download all available BioSample package and template information and save to
#' a given directory.
#'
#' @param dp directory path to save files to. If not specified, the extdata
#' subdirectory of the package location will be used.
#'
#' @return named vector of downloaded file paths.
#'
#' @export
dump_metadata <- function(dp=NULL) {
# TODO library metadata be added and this moved elsewhere?
if (is.null(dp)) {
dp <- system.file("extdata", package = methods::getPackageName())
}
if (! dir.exists(dp)) {
dir.create(dp, recursive = TRUE)
}
fps <- download_biosample_packages()
data <- read_biosample_packages(fps)
fps <- c(fps, sapply(data$Name, download_template))
fps
}
#' Download BioSample Package info XML
#'
#' Download an XML file of BioSample package information and write to disk.
#'
#' @param fp file path to write to, or NULL to use a default within the package
#' directory.
#'
#' @return file path written to
#'
#' @export
download_biosample_packages <- function(fp=NULL) {
# (Or one at a time by giving a path after the last "/" of a package name.)
url_xml <- paste0("https://",
HTTP_SRV["WWW"],
"/biosample/docs/packages/?format=xml")
if (is.null(fp)) {
dp <- system.file("extdata", package = methods::getPackageName())
fp <- file.path(dp, "biosample_packages.xml")
}
utils::download.file(url = url_xml, destfile = fp)
c(biosample_packages = fp)
}
#' Read BioSample package information from file
#'
#' Read in XML file of BioSample package information (including template
#' names) and return a data frame.
#'
#' @param fp file path to write to, or NULL to use a default within the package
#' directory.
#'
#' @return data frame of information for all available BioSample types.
#'
#' @export
read_biosample_packages <- function(fp=NULL) {
if (is.null(fp)) {
dp <- system.file("extdata", package = methods::getPackageName())
fp <- file.path(dp, "biosample_packages.xml")
}
data <- xml2::xml_children(xml2::read_xml(fp))
columns <- c("Name", "DisplayName", "ShortName", "EnvPackage",
"EnvPackageDisplay", "Description", "Example")
names(columns) <- columns
data <- lapply(columns, function(column) {
xml2::xml_text(xml2::xml_child(data, column))
})
data <- do.call(cbind.data.frame, c(data, list(stringsAsFactors = FALSE)))
data
}
#' Download BioSample Attributes XML
#'
#' Download an XML file of BioSample field attribute information and write to
#' disk.
#'
#' @param fp file path to write to, or NULL to use a default within the package
#' directory.
#'
#' @return file path written to
#'
#' @export
download_biosample_attributes <- function(fp=NULL) {
url_xml <- paste0("https://",
HTTP_SRV["WWW"],
"/biosample/docs/attributes/?format=xml")
if (is.null(fp)) {
dp <- system.file("extdata", package = methods::getPackageName())
fp <- file.path(dp, "biosample_package_attributes.xml")
}
utils::download.file(url = url_xml, destfile = fp)
c(biosample_package_attributes = fp)
}
#' Read BioSample attributes list from file
#'
#' Read in an XML file of BioSample field attributes and return as nested list
#' structure. (This doesn't fit cleanly into a table like the packages
#' information does.)
#'
#' @param fp file path to read from, or NULL to use a default within the package
#' directory.
#'
#' @return nested list of BioSample field attributes. Each named entry refers
#' to a single field (column) used by one or more package templates. Each
#' entry contains "metadata" and "extra"; metadata stores basic information
#' like a description of the field and what packages it's used in. extra
#' refers to additional per-metadata-item characteristics (currently only used
#' for Packages).
#'
#' @export
read_biosample_attributes <- function(fp=NULL) {
if (is.null(fp)) {
dp <- system.file("extdata", package = methods::getPackageName())
fp <- file.path(dp, "biosample_package_attributes.xml")
}
data <- xml2::xml_children(xml2::read_xml(fp))
output <- lapply(data, function(entry) {
children <- xml2::xml_children(entry)
entry_names <- xml2::xml_name(children)
entry_contents <- split(xml2::xml_text(children), entry_names)
entry_attrs <- split(xml2::xml_attrs(children), entry_names)
list(metadata = entry_contents, extra = entry_attrs)
})
names(output) <- sapply(output,
function(x) x[["metadata"]][["HarmonizedName"]])
output
}
#' Download BioSample Template
#'
#' Download a BioSample template as a TSV file.
#'
#' @param package_name name of BioSample Package for the template to download,
#' (e.g., "MIMS.me.human-associated.4.0")
#' @param fp file path to write to, or NULL to use a default within the package
#' directory.
#'
#' @return file path written to
#'
#' @export
download_template <- function(package_name, fp=NULL) {
# read_template is currently in templates.R. Should tidy that in one
# direction or the other.
args <- c(package = package_name, action = "download_tsv") # or download_excel
url_args <- paste(names(args), args,
sep = "=",
collapse = "&")
url <- paste0("https://",
HTTP_SRV["SUBMIT"],
"/biosample/template/?",
url_args)
if (is.null(fp)) {
dp <- system.file("extdata", package = methods::getPackageName())
dp_templates <- file.path(dp, "templates", "biosample_attributes")
if (! dir.exists(dp_templates)) {
dir.create(dp_templates, recursive = TRUE)
}
fp <- file.path(dp_templates, paste0(package_name, ".tsv"))
}
utils::download.file(url = url, destfile = fp)
names(fp) <- package_name
return(fp)
}
# Other -------------------------------------------------------------------
# Also useful: https://www.ncbi.nlm.nih.gov/biosample/docs/submission/validation/
#' Remove blank optional fields
#'
#' Given a data frame (with optional_fields attribute), remove any columns that
#' are listed as optional and are entirely blank. Call this after filling in
#' any optional fields that you do have information for to clear out the
#' remaining empty ones.
#'
#' @param data data frame of metadata
#'
#' @return data frame with blank optional fields removed
#'
#' @export
tidy_optional_fields <- function(data) {
fields <- attributes(data)$optional_fields
if (! is.null(fields)) {
for (f in fields) {
if (all(blank(data[[f]]))) {
data[[f]] <- NULL
}
}
}
data
}
#' Get BioSample field descriptions
#'
#' Given a vector of BioSample field (column) names, return a data frame of
#' descriptions for each.
#'
#' @param fields vector of field names, like \code{c("env_biome", "env_feature")}.
#'
#' @return data frame of field names and descriptions.
#'
#' @export
#'
#' @examples
#' fields <- c("env_biome", "env_feature")
#' descs <- field_descriptions(fields)
#' # descs is a data frame of field/descrption pairs
#' # Try View(descs)
field_descriptions <- function(fields) {
bs_attrs <- read_biosample_attributes()
has_name <- function(field, attrib) {
(field == attrib[["metadata"]][["HarmonizedName"]]) ||
(field %in% unlist(attrib[["metadata"]][["Synonym"]]))
}
desc <- sapply(fields, function(field) {
for (attrib in bs_attrs) {
if (has_name(field, attrib)) {
d <- attrib[["metadata"]][["Description"]]
if (is.null(d))
d <- ""
return(d)
}
}
return("")
})
# Trim off whitespace including trailing line endings
# https://stackoverflow.com/a/2261149
trim <- function (x) gsub("^\\s+|\\s+$", "", x)
desc <- trim(desc)
data.frame(
Field = fields,
Description = desc,
stringsAsFactors = FALSE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.