Nothing
R/EAL_make_eml.R
In ecocomDP: Tools to Create, Use, and Convert ecocomDP Data
Defines functions
EAL_make_eml
# Make EML metadata
#
# @description
# Render the contents of metadata templates into EML, validate, and write
# to file.
#
# @param path
# (character) Path to the metadata template directory.
# @param data.path
# (character) Path to the data directory.
# @param eml.path
# (character) Path to the EML directory, where EML files are written.
# @param dataset.title
# (character) Title of the dataset.
# @param temporal.coverage
# (character) Beginning and ending dates of the dataset in the format
# "YYYY-MM-DD" (e.g.
# \code{temporal.coverage = c('2012-05-01', '2014-11-30')}).
# @param geographic.description
# (character) Description of datasets geographic extent. Don't use this
# argument if geographic coverage is supplied by geographic_coverage.txt.
# @param geographic.coordinates
# (character) Coordinates of datasets geographic extent. Coordinates are
# listed in this order: North, East, South, West (e.g.
# \code{geographic.coordinates = c('28.38', '-119.95', '28.38', '-119.95')}).
# Longitudes west of the prime meridian and latitudes south of the equator
# are negative. Don't use this argument if geographic coverage is supplied
# by geographic_coverage.txt.
# @param maintenance.description
# (character) A description of data collection status (e.g. "ongoing",
# "complete"), communicating the frequency of updates.
# @param data.table
# (character; optional) Table file name. If more than one, then supply
# as a vector of character strings (e.g.
# \code{data.table = c("nitrogen.csv", "decomp.csv")}).
# @param data.table.name
# (character; optional) A short descriptive name for the table. Defaults
# to \code{data.table}. If more than one, then supply as a vector of
# character strings in the same order as listed in \code{data.table}.
# @param data.table.description
# (character; optional) Table description. If more than one, then supply
# as a vector of character strings in the same order as listed in
# \code{data.table}.
# @param data.table.quote.character
# (character; optional) Quote character used in \code{data.table}. If
# more than one, then supply as a vector of character strings in the same
# order as listed in \code{data.table}. If the quote character is a quotation,
# then enter \code{'"'}. If the quote character is an apostrophe, then
# enter \code{"'"}. If wanting to include quote characters for some but
# not all \code{data.table}, then use a "" for those that don't have a
# quote character (e.g. \code{data.table.quote.character =
# c("'", "")}).
# @param data.table.url
# (character; optional) The publicly accessible URL from which
# \code{data.table} can be downloaded. If more than one, then supply as
# a vector of character strings in the same order as listed in
# \code{data.table}. If wanting to include URLs for some but not all
# \code{data.table}, then use a "" for those that don't have a URL
# (e.g. \code{data.table.url = c("", "/url/to/decomp.csv")}).
# @param other.entity
# (character; optional) Name of \code{other.entity}(s) in this
# dataset. Use \code{other.entity} for all non-\code{data.table} files.
# \code{other.entity}(s) should be stored at \code{data.path}. If more
# than one, then supply as a vector of character strings (e.g.
# \code{other.entity = c('ancillary_data.zip', 'quality_control.R')}).
# @param other.entity.name
# (character; optional) A short descriptive name for the other.entity.
# Defaults to \code{other.entity}. If more than one, then supply as a
# vector of character strings in the same order as listed in
# \code{other.entity}.
# @param other.entity.description
# (character; optional) Description(s) of \code{other.entity}(s). If more
# than one, then supply as a vector of descriptions in the same order as
# listed in \code{other.entity}.
# @param other.entity.url
# (character; optional) The publicly accessible URL from which
# \code{other.entity} can be downloaded. If more than one, then supply as
# a vector of character strings in the same order as listed in
# \code{other.entity}. If wanting to include URLs for some but not all
# \code{other.entity}, then use a "" for those that don't have a URL
# (e.g. \code{other.entity.url = c("", "/url/to/quality_control.R")}).
# @param provenance
# (character; optional) EDI Data Repository Data package ID(s)
# corresponding to parent datasets from which this dataset was created
# (e.g. \code{knb-lter-cap.46.3}).
# @param user.id
# (character; optional) Repository user identifier. If more than one,
# then enter as a vector of character strings (e.g.
# \code{c("user_id_1", "user_id_2")}). \code{user.id} sets the
# /eml/access/principal element for all \code{user.domain} except
# "KNB", "ADC", and if \code{user.domain = NULL}.
# @param user.domain
# (character; optional) Repository domain associated with
# \code{user.id}. Currently supported values are "EDI"
# (Environmental Data Initiative), "LTER" (Long-Term Ecological Research
# Network), "KNB" (The Knowledge Network for Biocomplexity), "ADC" (The
# Arctic Data Center). If you'd like your system supported please contact
# maintainers of the ecocomDP R package. If using more than one
# \code{user.domain}, then enter as a vector of character strings (e.g.
# \code{c("user_domain_1", "user_domain_2")}) in the same order as
# corresponding \code{user.id}. If \code{user.domain} is missing then a
# default value "unknown" is assigned. \code{user.domain} sets the EML
# header "system" attribute and for all \code{user.domain}, except "KNB"
# and "ADC", sets the /eml/access/principal element attributes and values.
# @param package.id
# (character; optional) Data package ID for the dataset described by this
# EML. Ask your data repository for a package ID. Missing \code{package.id}
# is assigned a UUID.
# @param write.file
# (logical; optional) Whether to write the EML file.
# @param return.obj
# (logical; optional) Whether to return the EML as an R object of class \code{EML object}. This EML object can be modified ad written to file according to the \href{https://github.com/ropensci/EML}{EML R library}.
# @param x
# (named list; optional) Alternative input to
# \code{create_eml()}. Use \code{EAL_template_arguments()}
# to create \code{x}.
#
# @return
# \itemize{
# \item \strong{EML file} written to \code{eml.path}.
# \item \strong{EML object} when \code{return.obj = TRUE}.
# }
#
# @details
# \code{create_eml()} reads the contents of metadata templates,
# auto-extracts additional metadata from the data entities, appends value
# added content (e.g. resolving keywords to controlled vocabularies), and
# adds all the metadata content to locations in the EML schema according
# with best practice recommendations of scientists, data managers, and
# data repositories. The EML is then validated against the schema and
# written to file.
#
# Character encodings in tabular metadata templates are converted to UTF-8
# via \code{enc2utf8()}. Characters in TextType metadata templates are not
# yet converted. Note: This may lead to an inaccuracy and disconnect
# between values in the data objects and what is reported in the EML (e.g.
# a categorical variable listed in the EML may not be the same as it's
# corresponding value in the data object). For this reason it's important
# to work with UTF-8 encoded data and metadata.
#
EAL_make_eml <- function(
path,
data.path = path,
eml.path = path,
dataset.title = NULL,
temporal.coverage = NULL,
geographic.description = NULL,
geographic.coordinates = NULL,
maintenance.description = NULL,
data.table = NULL,
data.table.name = data.table,
data.table.description = NULL,
data.table.quote.character = NULL,
data.table.url = NULL,
other.entity = NULL,
other.entity.name = other.entity,
other.entity.description = NULL,
other.entity.url = NULL,
provenance = NULL,
user.id = NULL,
user.domain = NULL,
package.id = NULL,
write.file = TRUE,
return.obj = FALSE,
x = NULL
) {
# Parameterize --------------------------------------------------------------
# Get attributes of template files
attr_tmp <- read_template_attributes()
# Validate arguments --------------------------------------------------------
# Validate path usage before passing arguments to validate_arguments().
# When not using x, inputs are expected from path, data.path, and
# eml.path. When using x, only data.path is required unless write.file = TRUE
# in which case eml.path is required.
if (is.null(x) & missing(path)) {
stop("Input argument 'path' is missing.")
} else if (!is.null(x) & missing(path)) {
path <- NULL
if (missing(data.path)) {
stop("Input argument 'data.path' is missing.")
}
if (isTRUE(write.file) & missing(eml.path)) {
stop("Input argument 'write.file = TRUE' but 'eml.path' is missing.")
} else if (!isTRUE(write.file) & missing(eml.path)) {
eml.path <- NULL
}
}
# Pass remaining arguments to validate_arguments()
validate_arguments(
fun.name = "make_eml",
fun.args = as.list(environment()))
# Handle deprecated arguments
if (!is.null(provenance)) {
warning(
paste0(
"Argument 'provenance' is deprecated; please use ",
"'template_provanence()' instead."),
call. = F)
}
# Read templates and data ---------------------------------------------------
# The reading function (EAL_template_arguments()) ignores empty templates located
# at path, thereby simplifying logic required to populate EML nodes below.
if (is.null(x)) {
if (is.null(data.table) & is.null(other.entity)) {
x <- EAL_template_arguments(
path = path,
data.path = data.path)$x
} else if (!is.null(data.table) & is.null(other.entity)) {
table_names <- suppressWarnings(
validate_file_names(
path = data.path,
data.files = data.table))
x <- EAL_template_arguments(
path = path,
data.path = data.path,
data.table = table_names)$x
} else if (!is.null(data.table) & !is.null(other.entity)) {
table_names <- suppressWarnings(
validate_file_names(
path = data.path,
data.files = data.table))
x <- EAL_template_arguments(
path = path,
data.path = data.path,
data.table = table_names,
other.entity = other.entity)$x
} else if (is.null(data.table) & !is.null(other.entity)) {
x <- EAL_template_arguments(
path = path,
data.path = data.path,
other.entity = other.entity)$x
}
data_read_2_x <- TRUE
}
# Clean templates of extraneous NA values -----------------------------------
# Users often add NAs to templates where "" is expected. This
# removes NAs from where they shouldn't be and replaces them with "". NOTE:
# Any value listed in the missingValueCode field is interpreted "as is" when
# attributes.txt templates are input as files. In contrast, when inputs are
# supplied by the argument "x" and when is.na() returns TRUE for values in
# the missingValueCode field, these NAs are converted to "".
for (k in names(x$template)) {
if (is.data.frame(x$template[[k]]$content)) {
for (m in names(x$template[[k]]$content)) {
if (m == "missingValueCode") {
if (!exists("data_read_2_x")) {
x$template[[k]]$content[[m]][
is.na(x$template[[k]]$content[[m]])] <- ""
}
} else {
x$template[[k]]$content[[m]][
is.na(x$template[[k]]$content[[m]])] <- ""
}
}
}
}
# Validate templates --------------------------------------------------------
x <- remove_empty_templates(x)
x <- validate_templates("make_eml", x)
# Modify templates ----------------------------------------------------------
# Modification of some template content helps with downstream processes.
# catvars.txt:
# - Remove incomplete cases
# - Remove white space
use_i <- stringr::str_detect(
names(x$template),
attr_tmp$regexpr[attr_tmp$template_name == "catvars"])
if (any(use_i)) {
for (i in which(use_i)) {
use_i <- (x$template[[i]]$content$attributeName == "") |
(x$template[[i]]$content$code == "") |
(x$template[[i]]$content$definition == "")
x$template[[i]]$content <- x$template[[i]]$content[!use_i, ]
x$template[[i]]$content <- as.data.frame(
lapply(
x$template[[i]]$content,
trimws),
stringsAsFactors = F)
}
}
# custom_units.txt:
# - Remove white space
if (!is.null(x$template$custom_units.txt)) {
x$template$custom_units.txt$content <- as.data.frame(
lapply(
x$template$custom_units.txt$content,
trimws),
stringsAsFactors = F)
}
# keywords.txt:
# - Remove blank keywords to reduce errors when matching to controlled
# vocabularies
x$template$keywords.txt$content <- x$template$keywords.txt$content[
x$template$keywords.txt$content$keyword != "", ]
# personnel.txt:
# - Make all roles lowercase for string matching and remove mistankenly
# entered white spaces
x$template$personnel.txt$content$role <- tolower(
x$template$personnel.txt$content$role)
x$template$personnel.txt$content <- as.data.frame(
lapply(
x$template$personnel.txt$content,
trimws),
stringsAsFactors = F)
# personnel.txt:
# - Set default project title and funding elements when none are provided
# - Combine projectTitle and fundingNumber into new "funding" field
x$template$personnel.txt$content$projectTitle[
x$template$personnel.txt$content$projectTitle == ""] <-
"No project title to report"
x$template$personnel.txt$content$funding <- trimws(
paste(
x$template$personnel.txt$content$fundingAgency,
x$template$personnel.txt$content$fundingNumber))
x$template$personnel.txt$content$funding[
x$template$personnel.txt$content$funding == ""] <- "No funding to report"
# table_attributes.txt:
# - Convert contents in the class field to a consistent case
# - Set units in non-numeric classes to ""
# - Ignore dateTimeFormatString when not classified as date
# - Remove white space
use_i <- stringr::str_detect(
names(x$template),
attr_tmp$regexpr[attr_tmp$template_name == "attributes"])
if (any(use_i)) {
for (i in which(use_i)) {
x$template[[i]]$content$class <- tolower(x$template[[i]]$content$class)
x$template[[i]]$content$unit[
x$template[[i]]$content$class != "numeric"] <- ""
x$template[[i]]$content$dateTimeFormatString[
x$template[[i]]$content$class != "date"] <- ""
x$template[[i]]$content <- as.data.frame(
lapply(
x$template[[i]]$content,
trimws),
stringsAsFactors = F)
}
}
# taxonomic_coverage.txt
# - Convert "" to NA as expected by txcl_make_taxonomicCoverage()
# - Add unresolved names to the name_resolved field so they will be listed in
# the output EML (with a rank value of "unknown").
if (!is.null(x$template$taxonomic_coverage.txt$content)) {
x$template$taxonomic_coverage.txt$content[
x$template$taxonomic_coverage.txt$content == "" ] <- NA_character_
use_i <- is.na(x$template$taxonomic_coverage.txt$content$name_resolved)
x$template$taxonomic_coverage.txt$content$name_resolved[use_i] <-
x$template$taxonomic_coverage.txt$content$name[use_i]
}
# Load helper funcitions ----------------------------------------------------
# A function to set personnel roles: contact, creator, Principal
# investigator, associated party (other)
set_person <- function(info_row, person_role) {
if (person_role == "contact") {
# If the contact only has givenName then the contact is an organization,
# otherwise it is a person.
if ((x$template$personnel.txt$content[info_row, "givenName"] != "") &
(x$template$personnel.txt$content[info_row, "middleInitial"] == "") &
(x$template$personnel.txt$content[info_row, "surName"] == "")) {
contact <- list(
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
positionName = stringr::str_to_title(x$template$personnel.txt$content[info_row,"givenName"]),
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"])
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19) {
contact$userId <- list(
directory = "https://orcid.org",
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
} else {
contact <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]),
surName = x$template$personnel.txt$content[info_row,"surName"]),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"])
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
contact$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
contact <- rapply(
contact,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
}
contact
} else if (person_role == "creator") {
creator <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]),
surName = x$template$personnel.txt$content[info_row,"surName"]),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"])
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
creator$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
creator <- rapply(
creator,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
creator
} else if (person_role == "pi") {
rp_personnel <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]),
surName = x$template$personnel.txt$content[info_row,"surName"]),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"],
role = 'Principal Investigator')
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
rp_personnel$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
rp_personnel <- rapply(
rp_personnel,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
rp_personnel
} else if (person_role == "publisher") {
rp_personnel <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]),
surName = x$template$personnel.txt$content[info_row,"surName"]),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"])
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
rp_personnel$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
rp_personnel <- rapply(
rp_personnel,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
rp_personnel
}else {
# If givenName, middleName, and surName are blank then the
# associatedParty is an organization, otherwise the associatedParty
# is a person
if ((x$template$personnel.txt$content[info_row, "givenName"] == "") &
(x$template$personnel.txt$content[info_row, "middleInitial"] == "") &
(x$template$personnel.txt$content[info_row, "surName"] == "")) {
associated_party = list(
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"],
role = stringr::str_to_title(x$template$personnel.txt$content[info_row,"role"]))
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
associated_party$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
associated_party
} else {
associated_party <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]
),
surName = x$template$personnel.txt$content[info_row,"surName"]
),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"],
role = stringr::str_to_title(x$template$personnel.txt$content[info_row,"role"])
)
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
associated_party$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
associated_party <- rapply(
associated_party,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
associated_party
}
}
}
# Create <eml> --------------------------------------------------------------
message("Making EML ...")
message("<eml>")
# Set default package.id
if (is.null(package.id)) {
warning("Missing 'package.id', assigning a UUID", call. = FALSE)
package.id <- uuid::UUIDgenerate()
}
# Define the EML system attribute from user.domain
if (("edi" %in% tolower(user.domain)) | ("lter" %in% tolower(user.domain))) {
sys <- "edi"
} else if ("knb" %in% tolower(user.domain)) {
sys <- "knb"
} else if ("adc" %in% tolower(user.domain)) {
sys <- "https://arcticdata.io"
} else {
sys <- "unknown"
}
# Construct EML header
eml <- list(
schemaLocation = "https://eml.ecoinformatics.org/eml-2.2.0 https://nis.lternet.edu/schemas/EML/eml-2.2.0/xsd/eml.xsd",
packageId = package.id,
system = sys)
# Create <access> -----------------------------------------------------------
# Create the access node for systems/repositories (i.e. user.domain) that
# use it, and if a user.id is specified.
if ((eml$system != "knb") &
(eml$system != "https://arcticdata.io") &
(!is.null(user.id))) {
message(" <access>")
# Set access attributes
if (eml$system == "edi") {
auth_sys <- "https://pasta.edirepository.org/authentication"
} else {
auth_sys <- "unknown"
}
eml$access <- list(
scope = "document",
order = "allowFirst",
authSystem = auth_sys,
allow = list())
# Extrapolate user.id and user.domain if unequal lengths.
if (!is.null(user.id) & !is.null(user.domain)) {
if (length(user.id) != length(user.domain)) {
user.id <- data.frame(
user.id, user.domain, stringsAsFactors = FALSE)$user.id
user.domain <- data.frame(
user.id, user.domain, stringsAsFactors = FALSE)$user.domain
warning(
"The number of 'user.id' and 'user.domain' inputs differ. ",
"Extrapolating to make equal:\nuser.id = ",
paste(user.id, collapse = ", "), "\nuser.domain = ",
paste(user.domain, collapse = ", "), call. = FALSE)
}
}
# Set permissions to "all" for the principal and "read" for public
r <- lapply(
seq_along(user.id),
function(k) {
if (auth_sys == "https://pasta.edirepository.org/authentication") {
if (tolower(user.domain[k]) == "lter") {
principal <- paste0(
"uid=", user.id[k], ",o=", user.domain[k], ",dc=ecoinformatics,dc=org")
} else if (tolower(user.domain[k]) == "edi") {
principal <- paste0(
"uid=", user.id[k], ",o=", user.domain[k], ",dc=edirepository,dc=org")
}
} else {
principal <- user.id[k]
}
permission <- "all"
list(principal = principal, permission = permission)
})
r[[length(r)+1]] <- list(principal = "public", permission = "read")
eml$access$allow <- r
}
# Create <dataset> ----------------------------------------------------------
# Initialize the dataset list to which sub-nodes will be added
message(" <dataset>")
dataset <- list()
# Create <title> ------------------------------------------------------------
if (!is.null(dataset.title)) {
message(" <title>")
eml$dataset$title <- dataset.title
}
# Create <creator> ----------------------------------------------------------
if (!is.null(x$template$personnel.txt)) {
eml$dataset$creator <- lapply(
which(x$template$personnel.txt$content$role == "creator"),
function(k) {
message(" <creator>")
set_person(info_row = k, person_role = "creator")
})
}
# Create <associatedParty> --------------------------------------------------
if (!is.null(x$template$personnel.txt)) {
eml$dataset$associatedParty <- lapply(
which(
stringr::str_detect(
x$template$personnel.txt$content$role,
"[^pi|^creator|^contact]")),
function(k) {
message(" <associatedParty>")
set_person(info_row = k, person_role = "")
})
}
# Create <pubDate> ----------------------------------------------------------
message(" <pubDate>")
eml$dataset$pubDate <- format(Sys.time(), "%Y-%m-%d")
# Create <abstract> ---------------------------------------------------------
if (any(stringr::str_detect(names(x$template), 'abstract'))) {
message(" <abstract>")
eml$dataset$abstract <- x$template[[
names(x$template)[stringr::str_detect(names(x$template), 'abstract')]
]]$content
}
# Create <keywordSet> -------------------------------------------------------
# Try resolving keywords without a listed thesaurus to the LTER Controlled
# Vocabulary, then create a separate keywordSet for each thesaurus + keyword
# group.
if (!is.null(x$template$keywords.txt)) {
use_i <- x$template$keywords.txt$content$keywordThesaurus == ""
if (any(use_i)) {
r <- try(
vocab_resolve_terms(
x = x$template$keywords.txt$content$keyword[use_i],
cv = "lter"),
silent = T)
if (is.data.frame(r)) {
x$template$keywords.txt$content[
match(
r[r$controlled_vocabulary != "", ]$term,
x$template$keywords.txt$content$keyword), ] <-
r[r$controlled_vocabulary != "", ]
}
}
eml$dataset$keywordSet <- lapply(
unique(x$template$keywords.txt$content$keywordThesaurus),
function(k) {
message(" <keywordSet>")
if (k == "") {
list(
keyword = as.list(
x$template$keywords.txt$content$keyword[
x$template$keywords.txt$content$keywordThesaurus == k]))
} else {
list(
keyword = as.list(
x$template$keywords.txt$content$keyword[
x$template$keywords.txt$content$keywordThesaurus == k]),
keywordThesaurus = unique(
x$template$keywords.txt$content$keywordThesaurus[
x$template$keywords.txt$content$keywordThesaurus == k]))
}
})
}
# Create <additionalInfo> ---------------------------------------------------
if (any(stringr::str_detect(names(x$template), "additional_info"))) {
message(' <additionalInfo>')
eml$dataset$additionalInfo <- x$template[[
names(x$template)[
stringr::str_detect(names(x$template), "additional_info")]]]$content
}
# Create <intellectualRights> -----------------------------------------------
if (!is.null(stringr::str_detect(names(x$template), "intellectual_rights"))) {
message(" <intellectualRights>")
eml$dataset$intellectualRights <- x$template$intellectual_rights.txt$content
}
# Create <coverage> ---------------------------------------------------------
message(' <coverage>')
eml$dataset$coverage <- list()
# Create <geographicCoverage> -----------------------------------------------
# Check for multiple geographic coverage inputs.
if (is.null(geographic.coordinates) & !any(stringr::str_detect(
names(x$template),
"geographic_coverage.txt|bounding_boxes.txt"))) {
warning("Geographic coverage is recommended.", call. = FALSE)
} else {
if (!is.null(x$template$geographic_coverage.txt)) {
# Create the geographicCoverage node
o <- x$template$geographic_coverage.txt$content
eml$dataset$coverage$geographicCoverage <- lapply(
seq_len(nrow(o)),
function(k) {
message(' <geographicCoverage>')
list(
geographicDescription = o$geographicDescription[k],
boundingCoordinates = list(
westBoundingCoordinate = o$westBoundingCoordinate[k],
eastBoundingCoordinate = o$eastBoundingCoordinate[k],
northBoundingCoordinate = o$northBoundingCoordinate[k],
southBoundingCoordinate = o$southBoundingCoordinate[k]))
})
}
}
# Create <temporalCoverage> -------------------------------------------------
if (!is.null(temporal.coverage)) {
message(" <temporalCoverage>")
eml$dataset$coverage$temporalCoverage <- list(
rangeOfDates = list(
beginDate = list(calendarDate = temporal.coverage[1]),
endDate = list(calendarDate = temporal.coverage[2])))
}
# Create <taxonomicCoverage> ------------------------------------------------
# Two sources of taxonomic coverage are supported:
#
# 1.) The taxonomicCoverage EML node as an .xml file, which is read and
# inserted into the emld list object that make_eml() creates.
#
# 2.) The taxonomic_coverage.txt template listing taxa and authorities.
# Attempts are made to get the full hierarchy of taxonomic rank values for
# each taxa and render to EML.
# Create methods for adding taxonomic authorities. Only ITIS is
# currently supported.
# Allow taxonomic hierarchies to be supplied as a table (i.e. align
# taxonomic_coverage.txt with the taxonomicCoverage option of
# EML::set_coverage()).
if (!is.null(x$template$taxonomicCoverage.xml)) {
message(" <taxonomicCoverage>")
eml$dataset$coverage$taxonomicCoverage <-
x$template$taxonomicCoverage.xml$content
} else if (!is.null(x$template$taxonomic_coverage.txt)) {
message(" <taxonomicCoverage>")
# Check for suggested packages
if (!requireNamespace("ritis", quietly = TRUE)) {
warning("Package 'ritis' is required for taxonomic rank expansion but is not installed", call. = FALSE)
}
if (!requireNamespace("taxize", quietly = TRUE)) {
warning("Package 'taxize' is required for taxonomic rank expansion but is not installed", call. = FALSE)
}
if (!requireNamespace("worrms", quietly = TRUE)) {
warning("Package 'worrms' is required for taxonomic rank expansion but is not installed", call. = FALSE)
}
# Expand taxonomic ranks and create taxonomic coverage
tc <- try(
suppressMessages(
txcl_make_taxonomicCoverage(
taxa.clean = x$template$taxonomic_coverage.txt$content$name_resolved,
authority = x$template$taxonomic_coverage.txt$content$authority_system,
authority.id = x$template$taxonomic_coverage.txt$content$authority_id,
write.file = F)),
silent = T)
if (!("try-error" %in% class(tc))) {
eml$dataset$coverage$taxonomicCoverage$taxonomicClassification <- tc$taxonomicClassification
}
}
# Create <maintenance> ------------------------------------------------------
if (!is.null(maintenance.description)) {
message(" <maintenance>")
eml$dataset$maintenance$description <- maintenance.description
}
# Create <contact> ----------------------------------------------------------
if (!is.null(x$template$personnel.txt)) {
eml$dataset$contact <- lapply(
which(x$template$personnel.txt$content$role == "contact"),
function(k) {
message(" <contact>")
set_person(info_row = k, person_role = "contact")
})
}
# Create <publisher> --------------------------------------------------------
eml$dataset$publisher <- lapply(
which(x$template$personnel.txt$content$role == "publisher"),
function(k) {
message(" <publisher>")
set_person(info_row = k, person_role = "publisher")
})
# Create <methods> ----------------------------------------------------------
if (any(stringr::str_detect(names(x$template), "methods"))) {
message(" <methods>")
# eml$dataset$methods$methodStep <- list(
# x$template[[
# names(x$template)[stringr::str_detect(names(x$template), "methods")]
# ]]$content$methodStep)
eml$dataset$methods$methodStep$description$para <-
x$template[[
names(x$template)[stringr::str_detect(names(x$template), "methods")]
]]$content$para[[1]]
}
# Create <methodStep> (provenance) ------------------------------------------
# Get provenance metadata from supported systems (repositories) and external
# sources (everything else), then combine as a list of methodStep.
if (!is.null(x$template$provenance.txt$content)) {
# Identify internal sources
internal_sources <- x$template$provenance.txt$content[
x$template$provenance.txt$content$dataPackageID != "", ]
# Parse internal sources
if (nrow(internal_sources) != 0) {
data_package_identifiers <- unique(internal_sources$dataPackageID)
for (k in data_package_identifiers) {
message(" <methodStep> (provenance metadata)")
r <- httr::GET(
paste0(
url_env("production"),
".lternet.edu/package/provenance/eml/",
stringr::str_replace_all(k, '\\.', '/')))
if (r$status_code == 200) {
prov <- httr::content(r, encoding = 'UTF-8')
# Remove IDs from creator and contact to preempt ID + reference
# errors
xml2::xml_set_attr(
xml2::xml_find_all(prov, './/dataSource/creator'),
'id', NULL)
xml2::xml_set_attr(
xml2::xml_find_all(prov, './/dataSource/contact'),
'id', NULL)
# Write .xml to tempdir() and read back in as an emld list object
# to be added to the dataset emld list under construction here
xml2::write_xml(prov, paste0(tempdir(), "/provenance_metadata.xml"))
prov <- EML::read_eml(paste0(tempdir(), "/provenance_metadata.xml"))
prov$`@context` <- NULL
prov$`@type` <- NULL
eml$dataset$methods$methodStep[[
length(eml$dataset$methods$methodStep)+1]] <- prov
suppressMessages(file.remove(paste0(tempdir(), "/provenance_metadata.xml")))
} else {
message("Unable to get provenance metadata.")
}
}
}
# Identify external sources
external_sources <- x$template$provenance.txt$content[
x$template$provenance.txt$content$dataPackageID == "", ]
# Parse external sources.
# Some elements require an explicit NULL value to prevent them from
# being displayed in the returned EML as closing tags (i.e. </tag>). This
# is an issue in the EML R package. Is there a more concise way of handling
# this issue than implemented here?
if (nrow(external_sources) != 0) {
source_titles <- unique(external_sources$title)
provenance <- lapply(
source_titles,
function(title) {
message(" <methodStep> (provenance metadata)")
d <- x$template$provenance.txt$content[
x$template$provenance.txt$content$title == title, ]
# Initialize onlineDescription
online_description <- d$onlineDescription[1]
if (online_description == "") {
online_description <- NULL
}
# Initialize provenance node
out <- list(
dataSource = list(
title = title,
creator = NULL,
distribution = list(
online = list(
onlineDescription = online_description,
url = d[1, "url"])),
contact = NULL),
description = "This provenance metadata does not contain entity specific information.")
for (i in 1:nrow(d)) {
# Initialize individualName
if (trimws(d$middleInitial[i]) != "") {
individual_name <- list(
givenName = list(trimws(d$givenName[i]), trimws(d$middleInitial[i])),
surName = d$surName[i])
} else {
individual_name <- list(
givenName = list(trimws(d$givenName[i])),
surName = d$surName[i])
}
if (individual_name$givenName[[1]] == "" &
individual_name$surName == "") {
individual_name <- NULL
}
# Initialize organizationName
organization_name <- d$organizationName[i]
if (organization_name == "") {
organization_name <- NULL
}
# Initialize electronicMailAddress
email <- d$email[i]
if (email == "") {
email <- NULL
}
# Add creator
if (d$role[i] == "creator") {
out$dataSource$creator[[length(out$dataSource$creator) + 1]] <-
list(
individualName = individual_name,
organizationName = organization_name,
electronicMailAddress = email)
}
# Add contact
if (d$role[i] == "contact") {
out$dataSource$contact[[length(out$dataSource$contact) + 1]] <-
list(
individualName = individual_name,
organizationName = organization_name,
electronicMailAddress = email)
}
}
out
})
# Add to eml
eml$dataset$methods$methodStep <- c(eml$dataset$methods$methodStep, provenance)
}
}
# Create <project> ----------------------------------------------------------
# The project metadata corresponding to the first "pi" listed in
# personnel.txt will become the primary project. Project metadata listed
# under supbsequent "pi" will become related projects in the order they are
# listed.
if (!is.null(x$template$personnel.txt)) {
use_i <- x$template$personnel.txt$content$role == "pi"
if (any(use_i)){
for (k in which(use_i)) {
if (k == min(which(use_i))) {
message(" <project>")
eml$dataset$project <- list(
title = x$template$personnel.txt$content$projectTitle[k],
personnel = set_person(info_row = k, person_role = "pi"),
funding = x$template$personnel.txt$content$funding[k])
} else {
message(" <relatedProject>")
eml$dataset$project$relatedProject[[
length(eml$dataset$project$relatedProject)+1]] <- list(
title = x$template$personnel.txt$content$projectTitle[k],
personnel = set_person(info_row = k, person_role = "pi"),
funding = x$template$personnel.txt$content$funding[k])
}
}
}
}
# Create <dataTable> --------------------------------------------------------
if (!is.null(x$data.table)) {
eml$dataset$dataTable <- lapply(
names(x$data.table),
function(k) {
message(k)
# Get corresponding table_attributes.txt
tbl_attr <- x$template[[
paste0("attributes_", tools::file_path_sans_ext(k), ".txt")]]$content
# Break if no table_attributes.txt
if (is.null(tbl_attr)) {
return()
}
message(paste0(" <dataTable> (", k, ")"))
# Add attributes.txt contents to the data frame input expected by
# EML::set_attributes().
# Order of attributes listed in the template may not be match
# the order listed in the table so ... reorder attributes according
# to the data table listing.
attributes <- data.frame(
attributeName = tbl_attr$attributeName,
formatString = tbl_attr$dateTimeFormatString,
unit = tbl_attr$unit,
numberType = "",
definition = "",
attributeDefinition = tbl_attr$attributeDefinition,
columnClasses = tbl_attr$class,
minimum = NA,
maximum = NA,
missingValueCode = tbl_attr$missingValueCode,
missingValueCodeExplanation = tbl_attr$missingValueCodeExplanation,
stringsAsFactors = F)
# Update missingValueCode - NA must be "NA" otherwise it will not be
# listed in the EML
attributes$missingValueCode[is.na(attributes$missingValueCode)] <- "NA"
# Update non-numeric attributes - categorical and character classes must
# have a numberType of "character" and their attributeDefinition must be
# listed under "defintion. date and categorical classes must be listed as
# "Date" and "factor" respectively
use_i <- (attributes$columnClasses == "categorical") |
(attributes$columnClasses == "character")
attributes$numberType[use_i] <- "character"
attributes$definition[use_i] <- attributes$attributeDefinition[use_i]
attributes$columnClasses[
attributes$columnClasses == "date"] <- "Date"
attributes$columnClasses[
attributes$columnClasses == "categorical"] <- "factor"
# Update numeric attributes - Remove NA and missingValueCode for
# calculations. Get minimum and maximum values. Infer numberType
for (i in which(tbl_attr$class == "numeric")) {
a <- x$data.table[[k]]$content[[tbl_attr$attributeName[i]]][
!is.na(x$data.table[[k]]$content[[tbl_attr$attributeName[i]]])]
if (methods::is(a, "integer64")) { # An exception for integer64 - Does not behave like a "numeric". Can remove this if we remove the data.table lib dependency
a <- as.numeric(a)
}
a <- a[a != tbl_attr$missingValueCode[i]]
if (all(is.na(a))) {
attributes$minimum[i] <- NA
attributes$maximum[i] <- NA
} else {
attributes$minimum[i] <- as.numeric(min(a, na.rm = T))
attributes$maximum[i] <- as.numeric(max(a, na.rm = T))
}
is_integer <-function(x, tol = .Machine$double.eps^0.5) {
abs(x - round(x)) < tol
}
if (any(!is_integer(a))) {
attributes$numberType[i] <- "real"
} else if (!any(a < 1)) {
attributes$numberType[i] <- "natural"
} else if (any(a < 0)) {
attributes$numberType[i] <- "integer"
} else {
attributes$numberType[i] <- "whole"
}
# Calculate precision for numeric attributes. Alternatively
# this should be added to the attributes template so precision can
# be manually defined by the metadata creator.
}
# Create attributeList
if (paste0("catvars_", tools::file_path_sans_ext(k), ".txt") %in%
names(x$template)) {
attributeList <- suppressWarnings(
EML::set_attributes(
attributes[ , c(
"attributeName",
"formatString",
"unit",
"numberType",
"definition",
"attributeDefinition",
"minimum",
"maximum",
"missingValueCode",
"missingValueCodeExplanation")],
factors = x$template[[
paste0(
"catvars_",
tools::file_path_sans_ext(k),
".txt")]]$content,
col_classes = attributes$columnClasses))
} else {
attributeList <- suppressWarnings(
EML::set_attributes(
attributes[ , c(
'attributeName',
'formatString',
'unit',
'numberType',
'definition',
'attributeDefinition',
'minimum',
'maximum',
'missingValueCode',
'missingValueCodeExplanation')],
col_classes = attributes$columnClasses))
}
# Set physical
physical <- suppressMessages(
EML::set_physical(
paste0(data.path, "/", k),
numHeaderLines = "1",
recordDelimiter = get_eol(
path = data.path,
file.name = k),
attributeOrientation = "column",
url = "placeholder"))
if (!is.null(data.table.quote.character)) {
# data.table.quote.character isn't required for each data table, but
# must have a non-NULL entry if other data tables have a quote
# character. A "" or NA indicates to skip assignment.
quote_character <- data.table.quote.character[
which(k == names(x$data.table))]
if ((quote_character == "") | is.na(quote_character)) {
physical$dataFormat$textFormat$simpleDelimited$quoteCharacter <-
NULL
} else {
physical$dataFormat$textFormat$simpleDelimited$quoteCharacter <-
quote_character
}
}
if (!is.null(data.table.url)) {
# data.table.url isn't required for each data table, but must have a
# non-NULL entry in the data.table.url if other data tables have a
# URL. A "" or NA indicates to skip URL assignment.
url <- data.table.url[which(k == names(x$data.table))]
if ((url == "") | is.na(url)) {
physical$distribution <- list()
} else {
physical$distribution$online$url <- url
}
} else {
physical$distribution <- list()
}
fdlim <- detect_delimiter(
path = data.path,
data.files = k,
os = detect_os())
if (fdlim == "\t") {
fdlim <- "\\t" # requires escape char to be written, otherwise is blank
}
physical$dataFormat$textFormat$simpleDelimited$fieldDelimiter <- fdlim
# Create dataTable
data_table <- list(
entityName = data.table.name[which(k == names(x$data.table))],
entityDescription = data.table.description[which(k == names(x$data.table))],
physical = physical,
attributeList = attributeList,
numberOfRecords = as.character(nrow(x$data.table[[k]]$content)))
# EML v2.0.0 handles absense of missingValue codes differently
# than EML v 1.0.3. This fixes the issue here, though it may be better
# to implement the fix in EML v2.0.0.
for (j in seq_along(data_table$attributeList$attribute)){
if (data_table$attributeList$attribute[[j]]$missingValueCode$code == ''){
data_table$attributeList$attribute[[j]]$missingValueCode$code <- NA_character_
data_table$attributeList$attribute[[j]]$missingValueCode$codeExplanation <- NA_character_
}
}
data_table
}
)
}
# Create <otherEntity> ------------------------------------------------------
if (!is.null(x$other.entity)) {
eml$dataset$otherEntity <- lapply(
names(x$other.entity),
function(k) {
message(paste0(" <otherEntity> (", k, ")"))
# Set physical
# Some sub-routine in EML::set_physical() doesn't like the .zip
# file extension, so we suppress the warning here so users aren't
# uneccessarily burdened by it. Not a great solution since helpful
# warnings will be lost.
physical <- suppressWarnings(
suppressMessages(
EML::set_physical(
paste0(data.path, "/", k))))
physical$dataFormat$textFormat <- NULL
if (!requireNamespace("mime", quietly = TRUE)) {
warning("Package 'mime' is required for detecting the script mime type but is not installed", call. = FALSE)
physical$dataFormat$externallyDefinedFormat$formatName <- "Unknown"
} else {
physical$dataFormat$externallyDefinedFormat$formatName <- mime::guess_type(
file = k, unknown = "Unknown", empty = "Unknown")
}
if (!is.null(other.entity.url)) {
# other.entity.url isn't required for each data table, but must have a
# non-NULL entry in the other.entity.url if other data tables have a
# URL. A "" or NA indicates to skip URL assignment.
url <- other.entity.url[which(k == names(x$other.entity))]
if ((url == "") | is.na(url)) {
physical$distribution <- list()
} else {
physical$distribution$online$url <- url
}
} else {
physical$distribution <- list()
}
# Create otherEntity
list(
entityName = other.entity.name[
which(k == names(x$other.entity))],
entityDescription = other.entity.description[
which(k == names(x$other.entity))],
physical = physical,
entityType = "unknown")
})
}
# Create <additionalMetadata> -----------------------------------------------
if (!is.null(x$template$custom_units.txt)) {
message(" <additionalMetadata>")
eml$additionalMetadata[[
length(eml$dataset$additionalMetadata)+1]]$metadata$unitList <- EML::set_unitList(
x$template$custom_units.txt$content)
}
# Create <annotations> ------------------------------------------------------
if (any(stringr::str_detect(names(x$template), "annotations.txt"))) {
message(" <annotations>")
eml <- suppressMessages(
annotate_eml(
annotations = x$template$annotations.txt$content,
eml.in = eml))
}
# Write EML -----------------------------------------------------------------
message("</eml>")
if (isTRUE(write.file)) {
message(paste0("Writing EML (", package.id, ".xml)"))
emld::eml_version("eml-2.2.0")
EML::write_eml(eml, paste0(eml.path, "/", package.id, ".xml"))
# Fix TextType nodes - EML::set_TextType() and EML::set_methods() replace
# special XML characters &, <, >, with their encoded representations. These
# characters are encoded a second time by EML::write_eml() resulting in
# replacement of "&" by "&" resulting in "&gt;" etc. The below code
# block patches this issue.
txt <- readLines(paste0(eml.path, "/", package.id, ".xml"), encoding = "UTF-8")
for (x in seq_along(txt)) {
txt[x] <- stringr::str_replace_all(txt[x], "&gt;", ">")
txt[x] <- stringr::str_replace_all(txt[x], "&lt;", "<")
txt[x] <- stringr::str_replace_all(txt[x], "&amp;", "&")
}
writeLines(txt, paste0(eml.path, "/", package.id, ".xml"), useBytes = T)
}
# Validate EML --------------------------------------------------------------
message("Validating EML")
r <- EML::eml_validate(eml)
if (isTRUE(r)) {
message(" Validation passed :)")
} else {
message(" Validation failed :(")
}
message("Done.")
if (isTRUE(return.obj)) {
eml
}
}
Try the ecocomDP package in your browser
Any scripts or data that you put into this service are public.
ecocomDP documentation built on July 9, 2023, 6:42 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions EAL_make_eml
# Make EML metadata
#
# @description
# Render the contents of metadata templates into EML, validate, and write
# to file.
#
# @param path
# (character) Path to the metadata template directory.
# @param data.path
# (character) Path to the data directory.
# @param eml.path
# (character) Path to the EML directory, where EML files are written.
# @param dataset.title
# (character) Title of the dataset.
# @param temporal.coverage
# (character) Beginning and ending dates of the dataset in the format
# "YYYY-MM-DD" (e.g.
# \code{temporal.coverage = c('2012-05-01', '2014-11-30')}).
# @param geographic.description
# (character) Description of datasets geographic extent. Don't use this
# argument if geographic coverage is supplied by geographic_coverage.txt.
# @param geographic.coordinates
# (character) Coordinates of datasets geographic extent. Coordinates are
# listed in this order: North, East, South, West (e.g.
# \code{geographic.coordinates = c('28.38', '-119.95', '28.38', '-119.95')}).
# Longitudes west of the prime meridian and latitudes south of the equator
# are negative. Don't use this argument if geographic coverage is supplied
# by geographic_coverage.txt.
# @param maintenance.description
# (character) A description of data collection status (e.g. "ongoing",
# "complete"), communicating the frequency of updates.
# @param data.table
# (character; optional) Table file name. If more than one, then supply
# as a vector of character strings (e.g.
# \code{data.table = c("nitrogen.csv", "decomp.csv")}).
# @param data.table.name
# (character; optional) A short descriptive name for the table. Defaults
# to \code{data.table}. If more than one, then supply as a vector of
# character strings in the same order as listed in \code{data.table}.
# @param data.table.description
# (character; optional) Table description. If more than one, then supply
# as a vector of character strings in the same order as listed in
# \code{data.table}.
# @param data.table.quote.character
# (character; optional) Quote character used in \code{data.table}. If
# more than one, then supply as a vector of character strings in the same
# order as listed in \code{data.table}. If the quote character is a quotation,
# then enter \code{'"'}. If the quote character is an apostrophe, then
# enter \code{"'"}. If wanting to include quote characters for some but
# not all \code{data.table}, then use a "" for those that don't have a
# quote character (e.g. \code{data.table.quote.character =
# c("'", "")}).
# @param data.table.url
# (character; optional) The publicly accessible URL from which
# \code{data.table} can be downloaded. If more than one, then supply as
# a vector of character strings in the same order as listed in
# \code{data.table}. If wanting to include URLs for some but not all
# \code{data.table}, then use a "" for those that don't have a URL
# (e.g. \code{data.table.url = c("", "/url/to/decomp.csv")}).
# @param other.entity
# (character; optional) Name of \code{other.entity}(s) in this
# dataset. Use \code{other.entity} for all non-\code{data.table} files.
# \code{other.entity}(s) should be stored at \code{data.path}. If more
# than one, then supply as a vector of character strings (e.g.
# \code{other.entity = c('ancillary_data.zip', 'quality_control.R')}).
# @param other.entity.name
# (character; optional) A short descriptive name for the other.entity.
# Defaults to \code{other.entity}. If more than one, then supply as a
# vector of character strings in the same order as listed in
# \code{other.entity}.
# @param other.entity.description
# (character; optional) Description(s) of \code{other.entity}(s). If more
# than one, then supply as a vector of descriptions in the same order as
# listed in \code{other.entity}.
# @param other.entity.url
# (character; optional) The publicly accessible URL from which
# \code{other.entity} can be downloaded. If more than one, then supply as
# a vector of character strings in the same order as listed in
# \code{other.entity}. If wanting to include URLs for some but not all
# \code{other.entity}, then use a "" for those that don't have a URL
# (e.g. \code{other.entity.url = c("", "/url/to/quality_control.R")}).
# @param provenance
# (character; optional) EDI Data Repository Data package ID(s)
# corresponding to parent datasets from which this dataset was created
# (e.g. \code{knb-lter-cap.46.3}).
# @param user.id
# (character; optional) Repository user identifier. If more than one,
# then enter as a vector of character strings (e.g.
# \code{c("user_id_1", "user_id_2")}). \code{user.id} sets the
# /eml/access/principal element for all \code{user.domain} except
# "KNB", "ADC", and if \code{user.domain = NULL}.
# @param user.domain
# (character; optional) Repository domain associated with
# \code{user.id}. Currently supported values are "EDI"
# (Environmental Data Initiative), "LTER" (Long-Term Ecological Research
# Network), "KNB" (The Knowledge Network for Biocomplexity), "ADC" (The
# Arctic Data Center). If you'd like your system supported please contact
# maintainers of the ecocomDP R package. If using more than one
# \code{user.domain}, then enter as a vector of character strings (e.g.
# \code{c("user_domain_1", "user_domain_2")}) in the same order as
# corresponding \code{user.id}. If \code{user.domain} is missing then a
# default value "unknown" is assigned. \code{user.domain} sets the EML
# header "system" attribute and for all \code{user.domain}, except "KNB"
# and "ADC", sets the /eml/access/principal element attributes and values.
# @param package.id
# (character; optional) Data package ID for the dataset described by this
# EML. Ask your data repository for a package ID. Missing \code{package.id}
# is assigned a UUID.
# @param write.file
# (logical; optional) Whether to write the EML file.
# @param return.obj
# (logical; optional) Whether to return the EML as an R object of class \code{EML object}. This EML object can be modified ad written to file according to the \href{https://github.com/ropensci/EML}{EML R library}.
# @param x
# (named list; optional) Alternative input to
# \code{create_eml()}. Use \code{EAL_template_arguments()}
# to create \code{x}.
#
# @return
# \itemize{
# \item \strong{EML file} written to \code{eml.path}.
# \item \strong{EML object} when \code{return.obj = TRUE}.
# }
#
# @details
# \code{create_eml()} reads the contents of metadata templates,
# auto-extracts additional metadata from the data entities, appends value
# added content (e.g. resolving keywords to controlled vocabularies), and
# adds all the metadata content to locations in the EML schema according
# with best practice recommendations of scientists, data managers, and
# data repositories. The EML is then validated against the schema and
# written to file.
#
# Character encodings in tabular metadata templates are converted to UTF-8
# via \code{enc2utf8()}. Characters in TextType metadata templates are not
# yet converted. Note: This may lead to an inaccuracy and disconnect
# between values in the data objects and what is reported in the EML (e.g.
# a categorical variable listed in the EML may not be the same as it's
# corresponding value in the data object). For this reason it's important
# to work with UTF-8 encoded data and metadata.
#
EAL_make_eml <- function(
path,
data.path = path,
eml.path = path,
dataset.title = NULL,
temporal.coverage = NULL,
geographic.description = NULL,
geographic.coordinates = NULL,
maintenance.description = NULL,
data.table = NULL,
data.table.name = data.table,
data.table.description = NULL,
data.table.quote.character = NULL,
data.table.url = NULL,
other.entity = NULL,
other.entity.name = other.entity,
other.entity.description = NULL,
other.entity.url = NULL,
provenance = NULL,
user.id = NULL,
user.domain = NULL,
package.id = NULL,
write.file = TRUE,
return.obj = FALSE,
x = NULL
) {
# Parameterize --------------------------------------------------------------
# Get attributes of template files
attr_tmp <- read_template_attributes()
# Validate arguments --------------------------------------------------------
# Validate path usage before passing arguments to validate_arguments().
# When not using x, inputs are expected from path, data.path, and
# eml.path. When using x, only data.path is required unless write.file = TRUE
# in which case eml.path is required.
if (is.null(x) & missing(path)) {
stop("Input argument 'path' is missing.")
} else if (!is.null(x) & missing(path)) {
path <- NULL
if (missing(data.path)) {
stop("Input argument 'data.path' is missing.")
}
if (isTRUE(write.file) & missing(eml.path)) {
stop("Input argument 'write.file = TRUE' but 'eml.path' is missing.")
} else if (!isTRUE(write.file) & missing(eml.path)) {
eml.path <- NULL
}
}
# Pass remaining arguments to validate_arguments()
validate_arguments(
fun.name = "make_eml",
fun.args = as.list(environment()))
# Handle deprecated arguments
if (!is.null(provenance)) {
warning(
paste0(
"Argument 'provenance' is deprecated; please use ",
"'template_provanence()' instead."),
call. = F)
}
# Read templates and data ---------------------------------------------------
# The reading function (EAL_template_arguments()) ignores empty templates located
# at path, thereby simplifying logic required to populate EML nodes below.
if (is.null(x)) {
if (is.null(data.table) & is.null(other.entity)) {
x <- EAL_template_arguments(
path = path,
data.path = data.path)$x
} else if (!is.null(data.table) & is.null(other.entity)) {
table_names <- suppressWarnings(
validate_file_names(
path = data.path,
data.files = data.table))
x <- EAL_template_arguments(
path = path,
data.path = data.path,
data.table = table_names)$x
} else if (!is.null(data.table) & !is.null(other.entity)) {
table_names <- suppressWarnings(
validate_file_names(
path = data.path,
data.files = data.table))
x <- EAL_template_arguments(
path = path,
data.path = data.path,
data.table = table_names,
other.entity = other.entity)$x
} else if (is.null(data.table) & !is.null(other.entity)) {
x <- EAL_template_arguments(
path = path,
data.path = data.path,
other.entity = other.entity)$x
}
data_read_2_x <- TRUE
}
# Clean templates of extraneous NA values -----------------------------------
# Users often add NAs to templates where "" is expected. This
# removes NAs from where they shouldn't be and replaces them with "". NOTE:
# Any value listed in the missingValueCode field is interpreted "as is" when
# attributes.txt templates are input as files. In contrast, when inputs are
# supplied by the argument "x" and when is.na() returns TRUE for values in
# the missingValueCode field, these NAs are converted to "".
for (k in names(x$template)) {
if (is.data.frame(x$template[[k]]$content)) {
for (m in names(x$template[[k]]$content)) {
if (m == "missingValueCode") {
if (!exists("data_read_2_x")) {
x$template[[k]]$content[[m]][
is.na(x$template[[k]]$content[[m]])] <- ""
}
} else {
x$template[[k]]$content[[m]][
is.na(x$template[[k]]$content[[m]])] <- ""
}
}
}
}
# Validate templates --------------------------------------------------------
x <- remove_empty_templates(x)
x <- validate_templates("make_eml", x)
# Modify templates ----------------------------------------------------------
# Modification of some template content helps with downstream processes.
# catvars.txt:
# - Remove incomplete cases
# - Remove white space
use_i <- stringr::str_detect(
names(x$template),
attr_tmp$regexpr[attr_tmp$template_name == "catvars"])
if (any(use_i)) {
for (i in which(use_i)) {
use_i <- (x$template[[i]]$content$attributeName == "") |
(x$template[[i]]$content$code == "") |
(x$template[[i]]$content$definition == "")
x$template[[i]]$content <- x$template[[i]]$content[!use_i, ]
x$template[[i]]$content <- as.data.frame(
lapply(
x$template[[i]]$content,
trimws),
stringsAsFactors = F)
}
}
# custom_units.txt:
# - Remove white space
if (!is.null(x$template$custom_units.txt)) {
x$template$custom_units.txt$content <- as.data.frame(
lapply(
x$template$custom_units.txt$content,
trimws),
stringsAsFactors = F)
}
# keywords.txt:
# - Remove blank keywords to reduce errors when matching to controlled
# vocabularies
x$template$keywords.txt$content <- x$template$keywords.txt$content[
x$template$keywords.txt$content$keyword != "", ]
# personnel.txt:
# - Make all roles lowercase for string matching and remove mistankenly
# entered white spaces
x$template$personnel.txt$content$role <- tolower(
x$template$personnel.txt$content$role)
x$template$personnel.txt$content <- as.data.frame(
lapply(
x$template$personnel.txt$content,
trimws),
stringsAsFactors = F)
# personnel.txt:
# - Set default project title and funding elements when none are provided
# - Combine projectTitle and fundingNumber into new "funding" field
x$template$personnel.txt$content$projectTitle[
x$template$personnel.txt$content$projectTitle == ""] <-
"No project title to report"
x$template$personnel.txt$content$funding <- trimws(
paste(
x$template$personnel.txt$content$fundingAgency,
x$template$personnel.txt$content$fundingNumber))
x$template$personnel.txt$content$funding[
x$template$personnel.txt$content$funding == ""] <- "No funding to report"
# table_attributes.txt:
# - Convert contents in the class field to a consistent case
# - Set units in non-numeric classes to ""
# - Ignore dateTimeFormatString when not classified as date
# - Remove white space
use_i <- stringr::str_detect(
names(x$template),
attr_tmp$regexpr[attr_tmp$template_name == "attributes"])
if (any(use_i)) {
for (i in which(use_i)) {
x$template[[i]]$content$class <- tolower(x$template[[i]]$content$class)
x$template[[i]]$content$unit[
x$template[[i]]$content$class != "numeric"] <- ""
x$template[[i]]$content$dateTimeFormatString[
x$template[[i]]$content$class != "date"] <- ""
x$template[[i]]$content <- as.data.frame(
lapply(
x$template[[i]]$content,
trimws),
stringsAsFactors = F)
}
}
# taxonomic_coverage.txt
# - Convert "" to NA as expected by txcl_make_taxonomicCoverage()
# - Add unresolved names to the name_resolved field so they will be listed in
# the output EML (with a rank value of "unknown").
if (!is.null(x$template$taxonomic_coverage.txt$content)) {
x$template$taxonomic_coverage.txt$content[
x$template$taxonomic_coverage.txt$content == "" ] <- NA_character_
use_i <- is.na(x$template$taxonomic_coverage.txt$content$name_resolved)
x$template$taxonomic_coverage.txt$content$name_resolved[use_i] <-
x$template$taxonomic_coverage.txt$content$name[use_i]
}
# Load helper funcitions ----------------------------------------------------
# A function to set personnel roles: contact, creator, Principal
# investigator, associated party (other)
set_person <- function(info_row, person_role) {
if (person_role == "contact") {
# If the contact only has givenName then the contact is an organization,
# otherwise it is a person.
if ((x$template$personnel.txt$content[info_row, "givenName"] != "") &
(x$template$personnel.txt$content[info_row, "middleInitial"] == "") &
(x$template$personnel.txt$content[info_row, "surName"] == "")) {
contact <- list(
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
positionName = stringr::str_to_title(x$template$personnel.txt$content[info_row,"givenName"]),
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"])
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19) {
contact$userId <- list(
directory = "https://orcid.org",
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
} else {
contact <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]),
surName = x$template$personnel.txt$content[info_row,"surName"]),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"])
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
contact$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
contact <- rapply(
contact,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
}
contact
} else if (person_role == "creator") {
creator <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]),
surName = x$template$personnel.txt$content[info_row,"surName"]),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"])
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
creator$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
creator <- rapply(
creator,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
creator
} else if (person_role == "pi") {
rp_personnel <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]),
surName = x$template$personnel.txt$content[info_row,"surName"]),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"],
role = 'Principal Investigator')
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
rp_personnel$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
rp_personnel <- rapply(
rp_personnel,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
rp_personnel
} else if (person_role == "publisher") {
rp_personnel <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]),
surName = x$template$personnel.txt$content[info_row,"surName"]),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"])
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
rp_personnel$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
rp_personnel <- rapply(
rp_personnel,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
rp_personnel
}else {
# If givenName, middleName, and surName are blank then the
# associatedParty is an organization, otherwise the associatedParty
# is a person
if ((x$template$personnel.txt$content[info_row, "givenName"] == "") &
(x$template$personnel.txt$content[info_row, "middleInitial"] == "") &
(x$template$personnel.txt$content[info_row, "surName"] == "")) {
associated_party = list(
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"],
role = stringr::str_to_title(x$template$personnel.txt$content[info_row,"role"]))
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
associated_party$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
associated_party
} else {
associated_party <- list(
individualName = list(
givenName = list(
x$template$personnel.txt$content[info_row,"givenName"],
x$template$personnel.txt$content[info_row,"middleInitial"]
),
surName = x$template$personnel.txt$content[info_row,"surName"]
),
organizationName = x$template$personnel.txt$content[info_row,"organizationName"],
electronicMailAddress = x$template$personnel.txt$content[info_row,"electronicMailAddress"],
role = stringr::str_to_title(x$template$personnel.txt$content[info_row,"role"])
)
if (nchar(x$template$personnel.txt$content[info_row,"userId"]) == 19){
associated_party$userId <- list(
directory = 'https://orcid.org',
paste0(
"https://orcid.org/",
x$template$personnel.txt$content[info_row,"userId"]))
}
# Blank entries ('') result in closing tags when EML is written
# to file. Need function to set all elements of value = '' to NULL.
associated_party <- rapply(
associated_party,
function(x){
if (x == ""){
x <- NULL
} else {
x
}
},
how = c("replace"))
associated_party
}
}
}
# Create <eml> --------------------------------------------------------------
message("Making EML ...")
message("<eml>")
# Set default package.id
if (is.null(package.id)) {
warning("Missing 'package.id', assigning a UUID", call. = FALSE)
package.id <- uuid::UUIDgenerate()
}
# Define the EML system attribute from user.domain
if (("edi" %in% tolower(user.domain)) | ("lter" %in% tolower(user.domain))) {
sys <- "edi"
} else if ("knb" %in% tolower(user.domain)) {
sys <- "knb"
} else if ("adc" %in% tolower(user.domain)) {
sys <- "https://arcticdata.io"
} else {
sys <- "unknown"
}
# Construct EML header
eml <- list(
schemaLocation = "https://eml.ecoinformatics.org/eml-2.2.0 https://nis.lternet.edu/schemas/EML/eml-2.2.0/xsd/eml.xsd",
packageId = package.id,
system = sys)
# Create <access> -----------------------------------------------------------
# Create the access node for systems/repositories (i.e. user.domain) that
# use it, and if a user.id is specified.
if ((eml$system != "knb") &
(eml$system != "https://arcticdata.io") &
(!is.null(user.id))) {
message(" <access>")
# Set access attributes
if (eml$system == "edi") {
auth_sys <- "https://pasta.edirepository.org/authentication"
} else {
auth_sys <- "unknown"
}
eml$access <- list(
scope = "document",
order = "allowFirst",
authSystem = auth_sys,
allow = list())
# Extrapolate user.id and user.domain if unequal lengths.
if (!is.null(user.id) & !is.null(user.domain)) {
if (length(user.id) != length(user.domain)) {
user.id <- data.frame(
user.id, user.domain, stringsAsFactors = FALSE)$user.id
user.domain <- data.frame(
user.id, user.domain, stringsAsFactors = FALSE)$user.domain
warning(
"The number of 'user.id' and 'user.domain' inputs differ. ",
"Extrapolating to make equal:\nuser.id = ",
paste(user.id, collapse = ", "), "\nuser.domain = ",
paste(user.domain, collapse = ", "), call. = FALSE)
}
}
# Set permissions to "all" for the principal and "read" for public
r <- lapply(
seq_along(user.id),
function(k) {
if (auth_sys == "https://pasta.edirepository.org/authentication") {
if (tolower(user.domain[k]) == "lter") {
principal <- paste0(
"uid=", user.id[k], ",o=", user.domain[k], ",dc=ecoinformatics,dc=org")
} else if (tolower(user.domain[k]) == "edi") {
principal <- paste0(
"uid=", user.id[k], ",o=", user.domain[k], ",dc=edirepository,dc=org")
}
} else {
principal <- user.id[k]
}
permission <- "all"
list(principal = principal, permission = permission)
})
r[[length(r)+1]] <- list(principal = "public", permission = "read")
eml$access$allow <- r
}
# Create <dataset> ----------------------------------------------------------
# Initialize the dataset list to which sub-nodes will be added
message(" <dataset>")
dataset <- list()
# Create <title> ------------------------------------------------------------
if (!is.null(dataset.title)) {
message(" <title>")
eml$dataset$title <- dataset.title
}
# Create <creator> ----------------------------------------------------------
if (!is.null(x$template$personnel.txt)) {
eml$dataset$creator <- lapply(
which(x$template$personnel.txt$content$role == "creator"),
function(k) {
message(" <creator>")
set_person(info_row = k, person_role = "creator")
})
}
# Create <associatedParty> --------------------------------------------------
if (!is.null(x$template$personnel.txt)) {
eml$dataset$associatedParty <- lapply(
which(
stringr::str_detect(
x$template$personnel.txt$content$role,
"[^pi|^creator|^contact]")),
function(k) {
message(" <associatedParty>")
set_person(info_row = k, person_role = "")
})
}
# Create <pubDate> ----------------------------------------------------------
message(" <pubDate>")
eml$dataset$pubDate <- format(Sys.time(), "%Y-%m-%d")
# Create <abstract> ---------------------------------------------------------
if (any(stringr::str_detect(names(x$template), 'abstract'))) {
message(" <abstract>")
eml$dataset$abstract <- x$template[[
names(x$template)[stringr::str_detect(names(x$template), 'abstract')]
]]$content
}
# Create <keywordSet> -------------------------------------------------------
# Try resolving keywords without a listed thesaurus to the LTER Controlled
# Vocabulary, then create a separate keywordSet for each thesaurus + keyword
# group.
if (!is.null(x$template$keywords.txt)) {
use_i <- x$template$keywords.txt$content$keywordThesaurus == ""
if (any(use_i)) {
r <- try(
vocab_resolve_terms(
x = x$template$keywords.txt$content$keyword[use_i],
cv = "lter"),
silent = T)
if (is.data.frame(r)) {
x$template$keywords.txt$content[
match(
r[r$controlled_vocabulary != "", ]$term,
x$template$keywords.txt$content$keyword), ] <-
r[r$controlled_vocabulary != "", ]
}
}
eml$dataset$keywordSet <- lapply(
unique(x$template$keywords.txt$content$keywordThesaurus),
function(k) {
message(" <keywordSet>")
if (k == "") {
list(
keyword = as.list(
x$template$keywords.txt$content$keyword[
x$template$keywords.txt$content$keywordThesaurus == k]))
} else {
list(
keyword = as.list(
x$template$keywords.txt$content$keyword[
x$template$keywords.txt$content$keywordThesaurus == k]),
keywordThesaurus = unique(
x$template$keywords.txt$content$keywordThesaurus[
x$template$keywords.txt$content$keywordThesaurus == k]))
}
})
}
# Create <additionalInfo> ---------------------------------------------------
if (any(stringr::str_detect(names(x$template), "additional_info"))) {
message(' <additionalInfo>')
eml$dataset$additionalInfo <- x$template[[
names(x$template)[
stringr::str_detect(names(x$template), "additional_info")]]]$content
}
# Create <intellectualRights> -----------------------------------------------
if (!is.null(stringr::str_detect(names(x$template), "intellectual_rights"))) {
message(" <intellectualRights>")
eml$dataset$intellectualRights <- x$template$intellectual_rights.txt$content
}
# Create <coverage> ---------------------------------------------------------
message(' <coverage>')
eml$dataset$coverage <- list()
# Create <geographicCoverage> -----------------------------------------------
# Check for multiple geographic coverage inputs.
if (is.null(geographic.coordinates) & !any(stringr::str_detect(
names(x$template),
"geographic_coverage.txt|bounding_boxes.txt"))) {
warning("Geographic coverage is recommended.", call. = FALSE)
} else {
if (!is.null(x$template$geographic_coverage.txt)) {
# Create the geographicCoverage node
o <- x$template$geographic_coverage.txt$content
eml$dataset$coverage$geographicCoverage <- lapply(
seq_len(nrow(o)),
function(k) {
message(' <geographicCoverage>')
list(
geographicDescription = o$geographicDescription[k],
boundingCoordinates = list(
westBoundingCoordinate = o$westBoundingCoordinate[k],
eastBoundingCoordinate = o$eastBoundingCoordinate[k],
northBoundingCoordinate = o$northBoundingCoordinate[k],
southBoundingCoordinate = o$southBoundingCoordinate[k]))
})
}
}
# Create <temporalCoverage> -------------------------------------------------
if (!is.null(temporal.coverage)) {
message(" <temporalCoverage>")
eml$dataset$coverage$temporalCoverage <- list(
rangeOfDates = list(
beginDate = list(calendarDate = temporal.coverage[1]),
endDate = list(calendarDate = temporal.coverage[2])))
}
# Create <taxonomicCoverage> ------------------------------------------------
# Two sources of taxonomic coverage are supported:
#
# 1.) The taxonomicCoverage EML node as an .xml file, which is read and
# inserted into the emld list object that make_eml() creates.
#
# 2.) The taxonomic_coverage.txt template listing taxa and authorities.
# Attempts are made to get the full hierarchy of taxonomic rank values for
# each taxa and render to EML.
# Create methods for adding taxonomic authorities. Only ITIS is
# currently supported.
# Allow taxonomic hierarchies to be supplied as a table (i.e. align
# taxonomic_coverage.txt with the taxonomicCoverage option of
# EML::set_coverage()).
if (!is.null(x$template$taxonomicCoverage.xml)) {
message(" <taxonomicCoverage>")
eml$dataset$coverage$taxonomicCoverage <-
x$template$taxonomicCoverage.xml$content
} else if (!is.null(x$template$taxonomic_coverage.txt)) {
message(" <taxonomicCoverage>")
# Check for suggested packages
if (!requireNamespace("ritis", quietly = TRUE)) {
warning("Package 'ritis' is required for taxonomic rank expansion but is not installed", call. = FALSE)
}
if (!requireNamespace("taxize", quietly = TRUE)) {
warning("Package 'taxize' is required for taxonomic rank expansion but is not installed", call. = FALSE)
}
if (!requireNamespace("worrms", quietly = TRUE)) {
warning("Package 'worrms' is required for taxonomic rank expansion but is not installed", call. = FALSE)
}
# Expand taxonomic ranks and create taxonomic coverage
tc <- try(
suppressMessages(
txcl_make_taxonomicCoverage(
taxa.clean = x$template$taxonomic_coverage.txt$content$name_resolved,
authority = x$template$taxonomic_coverage.txt$content$authority_system,
authority.id = x$template$taxonomic_coverage.txt$content$authority_id,
write.file = F)),
silent = T)
if (!("try-error" %in% class(tc))) {
eml$dataset$coverage$taxonomicCoverage$taxonomicClassification <- tc$taxonomicClassification
}
}
# Create <maintenance> ------------------------------------------------------
if (!is.null(maintenance.description)) {
message(" <maintenance>")
eml$dataset$maintenance$description <- maintenance.description
}
# Create <contact> ----------------------------------------------------------
if (!is.null(x$template$personnel.txt)) {
eml$dataset$contact <- lapply(
which(x$template$personnel.txt$content$role == "contact"),
function(k) {
message(" <contact>")
set_person(info_row = k, person_role = "contact")
})
}
# Create <publisher> --------------------------------------------------------
eml$dataset$publisher <- lapply(
which(x$template$personnel.txt$content$role == "publisher"),
function(k) {
message(" <publisher>")
set_person(info_row = k, person_role = "publisher")
})
# Create <methods> ----------------------------------------------------------
if (any(stringr::str_detect(names(x$template), "methods"))) {
message(" <methods>")
# eml$dataset$methods$methodStep <- list(
# x$template[[
# names(x$template)[stringr::str_detect(names(x$template), "methods")]
# ]]$content$methodStep)
eml$dataset$methods$methodStep$description$para <-
x$template[[
names(x$template)[stringr::str_detect(names(x$template), "methods")]
]]$content$para[[1]]
}
# Create <methodStep> (provenance) ------------------------------------------
# Get provenance metadata from supported systems (repositories) and external
# sources (everything else), then combine as a list of methodStep.
if (!is.null(x$template$provenance.txt$content)) {
# Identify internal sources
internal_sources <- x$template$provenance.txt$content[
x$template$provenance.txt$content$dataPackageID != "", ]
# Parse internal sources
if (nrow(internal_sources) != 0) {
data_package_identifiers <- unique(internal_sources$dataPackageID)
for (k in data_package_identifiers) {
message(" <methodStep> (provenance metadata)")
r <- httr::GET(
paste0(
url_env("production"),
".lternet.edu/package/provenance/eml/",
stringr::str_replace_all(k, '\\.', '/')))
if (r$status_code == 200) {
prov <- httr::content(r, encoding = 'UTF-8')
# Remove IDs from creator and contact to preempt ID + reference
# errors
xml2::xml_set_attr(
xml2::xml_find_all(prov, './/dataSource/creator'),
'id', NULL)
xml2::xml_set_attr(
xml2::xml_find_all(prov, './/dataSource/contact'),
'id', NULL)
# Write .xml to tempdir() and read back in as an emld list object
# to be added to the dataset emld list under construction here
xml2::write_xml(prov, paste0(tempdir(), "/provenance_metadata.xml"))
prov <- EML::read_eml(paste0(tempdir(), "/provenance_metadata.xml"))
prov$`@context` <- NULL
prov$`@type` <- NULL
eml$dataset$methods$methodStep[[
length(eml$dataset$methods$methodStep)+1]] <- prov
suppressMessages(file.remove(paste0(tempdir(), "/provenance_metadata.xml")))
} else {
message("Unable to get provenance metadata.")
}
}
}
# Identify external sources
external_sources <- x$template$provenance.txt$content[
x$template$provenance.txt$content$dataPackageID == "", ]
# Parse external sources.
# Some elements require an explicit NULL value to prevent them from
# being displayed in the returned EML as closing tags (i.e. </tag>). This
# is an issue in the EML R package. Is there a more concise way of handling
# this issue than implemented here?
if (nrow(external_sources) != 0) {
source_titles <- unique(external_sources$title)
provenance <- lapply(
source_titles,
function(title) {
message(" <methodStep> (provenance metadata)")
d <- x$template$provenance.txt$content[
x$template$provenance.txt$content$title == title, ]
# Initialize onlineDescription
online_description <- d$onlineDescription[1]
if (online_description == "") {
online_description <- NULL
}
# Initialize provenance node
out <- list(
dataSource = list(
title = title,
creator = NULL,
distribution = list(
online = list(
onlineDescription = online_description,
url = d[1, "url"])),
contact = NULL),
description = "This provenance metadata does not contain entity specific information.")
for (i in 1:nrow(d)) {
# Initialize individualName
if (trimws(d$middleInitial[i]) != "") {
individual_name <- list(
givenName = list(trimws(d$givenName[i]), trimws(d$middleInitial[i])),
surName = d$surName[i])
} else {
individual_name <- list(
givenName = list(trimws(d$givenName[i])),
surName = d$surName[i])
}
if (individual_name$givenName[[1]] == "" &
individual_name$surName == "") {
individual_name <- NULL
}
# Initialize organizationName
organization_name <- d$organizationName[i]
if (organization_name == "") {
organization_name <- NULL
}
# Initialize electronicMailAddress
email <- d$email[i]
if (email == "") {
email <- NULL
}
# Add creator
if (d$role[i] == "creator") {
out$dataSource$creator[[length(out$dataSource$creator) + 1]] <-
list(
individualName = individual_name,
organizationName = organization_name,
electronicMailAddress = email)
}
# Add contact
if (d$role[i] == "contact") {
out$dataSource$contact[[length(out$dataSource$contact) + 1]] <-
list(
individualName = individual_name,
organizationName = organization_name,
electronicMailAddress = email)
}
}
out
})
# Add to eml
eml$dataset$methods$methodStep <- c(eml$dataset$methods$methodStep, provenance)
}
}
# Create <project> ----------------------------------------------------------
# The project metadata corresponding to the first "pi" listed in
# personnel.txt will become the primary project. Project metadata listed
# under supbsequent "pi" will become related projects in the order they are
# listed.
if (!is.null(x$template$personnel.txt)) {
use_i <- x$template$personnel.txt$content$role == "pi"
if (any(use_i)){
for (k in which(use_i)) {
if (k == min(which(use_i))) {
message(" <project>")
eml$dataset$project <- list(
title = x$template$personnel.txt$content$projectTitle[k],
personnel = set_person(info_row = k, person_role = "pi"),
funding = x$template$personnel.txt$content$funding[k])
} else {
message(" <relatedProject>")
eml$dataset$project$relatedProject[[
length(eml$dataset$project$relatedProject)+1]] <- list(
title = x$template$personnel.txt$content$projectTitle[k],
personnel = set_person(info_row = k, person_role = "pi"),
funding = x$template$personnel.txt$content$funding[k])
}
}
}
}
# Create <dataTable> --------------------------------------------------------
if (!is.null(x$data.table)) {
eml$dataset$dataTable <- lapply(
names(x$data.table),
function(k) {
message(k)
# Get corresponding table_attributes.txt
tbl_attr <- x$template[[
paste0("attributes_", tools::file_path_sans_ext(k), ".txt")]]$content
# Break if no table_attributes.txt
if (is.null(tbl_attr)) {
return()
}
message(paste0(" <dataTable> (", k, ")"))
# Add attributes.txt contents to the data frame input expected by
# EML::set_attributes().
# Order of attributes listed in the template may not be match
# the order listed in the table so ... reorder attributes according
# to the data table listing.
attributes <- data.frame(
attributeName = tbl_attr$attributeName,
formatString = tbl_attr$dateTimeFormatString,
unit = tbl_attr$unit,
numberType = "",
definition = "",
attributeDefinition = tbl_attr$attributeDefinition,
columnClasses = tbl_attr$class,
minimum = NA,
maximum = NA,
missingValueCode = tbl_attr$missingValueCode,
missingValueCodeExplanation = tbl_attr$missingValueCodeExplanation,
stringsAsFactors = F)
# Update missingValueCode - NA must be "NA" otherwise it will not be
# listed in the EML
attributes$missingValueCode[is.na(attributes$missingValueCode)] <- "NA"
# Update non-numeric attributes - categorical and character classes must
# have a numberType of "character" and their attributeDefinition must be
# listed under "defintion. date and categorical classes must be listed as
# "Date" and "factor" respectively
use_i <- (attributes$columnClasses == "categorical") |
(attributes$columnClasses == "character")
attributes$numberType[use_i] <- "character"
attributes$definition[use_i] <- attributes$attributeDefinition[use_i]
attributes$columnClasses[
attributes$columnClasses == "date"] <- "Date"
attributes$columnClasses[
attributes$columnClasses == "categorical"] <- "factor"
# Update numeric attributes - Remove NA and missingValueCode for
# calculations. Get minimum and maximum values. Infer numberType
for (i in which(tbl_attr$class == "numeric")) {
a <- x$data.table[[k]]$content[[tbl_attr$attributeName[i]]][
!is.na(x$data.table[[k]]$content[[tbl_attr$attributeName[i]]])]
if (methods::is(a, "integer64")) { # An exception for integer64 - Does not behave like a "numeric". Can remove this if we remove the data.table lib dependency
a <- as.numeric(a)
}
a <- a[a != tbl_attr$missingValueCode[i]]
if (all(is.na(a))) {
attributes$minimum[i] <- NA
attributes$maximum[i] <- NA
} else {
attributes$minimum[i] <- as.numeric(min(a, na.rm = T))
attributes$maximum[i] <- as.numeric(max(a, na.rm = T))
}
is_integer <-function(x, tol = .Machine$double.eps^0.5) {
abs(x - round(x)) < tol
}
if (any(!is_integer(a))) {
attributes$numberType[i] <- "real"
} else if (!any(a < 1)) {
attributes$numberType[i] <- "natural"
} else if (any(a < 0)) {
attributes$numberType[i] <- "integer"
} else {
attributes$numberType[i] <- "whole"
}
# Calculate precision for numeric attributes. Alternatively
# this should be added to the attributes template so precision can
# be manually defined by the metadata creator.
}
# Create attributeList
if (paste0("catvars_", tools::file_path_sans_ext(k), ".txt") %in%
names(x$template)) {
attributeList <- suppressWarnings(
EML::set_attributes(
attributes[ , c(
"attributeName",
"formatString",
"unit",
"numberType",
"definition",
"attributeDefinition",
"minimum",
"maximum",
"missingValueCode",
"missingValueCodeExplanation")],
factors = x$template[[
paste0(
"catvars_",
tools::file_path_sans_ext(k),
".txt")]]$content,
col_classes = attributes$columnClasses))
} else {
attributeList <- suppressWarnings(
EML::set_attributes(
attributes[ , c(
'attributeName',
'formatString',
'unit',
'numberType',
'definition',
'attributeDefinition',
'minimum',
'maximum',
'missingValueCode',
'missingValueCodeExplanation')],
col_classes = attributes$columnClasses))
}
# Set physical
physical <- suppressMessages(
EML::set_physical(
paste0(data.path, "/", k),
numHeaderLines = "1",
recordDelimiter = get_eol(
path = data.path,
file.name = k),
attributeOrientation = "column",
url = "placeholder"))
if (!is.null(data.table.quote.character)) {
# data.table.quote.character isn't required for each data table, but
# must have a non-NULL entry if other data tables have a quote
# character. A "" or NA indicates to skip assignment.
quote_character <- data.table.quote.character[
which(k == names(x$data.table))]
if ((quote_character == "") | is.na(quote_character)) {
physical$dataFormat$textFormat$simpleDelimited$quoteCharacter <-
NULL
} else {
physical$dataFormat$textFormat$simpleDelimited$quoteCharacter <-
quote_character
}
}
if (!is.null(data.table.url)) {
# data.table.url isn't required for each data table, but must have a
# non-NULL entry in the data.table.url if other data tables have a
# URL. A "" or NA indicates to skip URL assignment.
url <- data.table.url[which(k == names(x$data.table))]
if ((url == "") | is.na(url)) {
physical$distribution <- list()
} else {
physical$distribution$online$url <- url
}
} else {
physical$distribution <- list()
}
fdlim <- detect_delimiter(
path = data.path,
data.files = k,
os = detect_os())
if (fdlim == "\t") {
fdlim <- "\\t" # requires escape char to be written, otherwise is blank
}
physical$dataFormat$textFormat$simpleDelimited$fieldDelimiter <- fdlim
# Create dataTable
data_table <- list(
entityName = data.table.name[which(k == names(x$data.table))],
entityDescription = data.table.description[which(k == names(x$data.table))],
physical = physical,
attributeList = attributeList,
numberOfRecords = as.character(nrow(x$data.table[[k]]$content)))
# EML v2.0.0 handles absense of missingValue codes differently
# than EML v 1.0.3. This fixes the issue here, though it may be better
# to implement the fix in EML v2.0.0.
for (j in seq_along(data_table$attributeList$attribute)){
if (data_table$attributeList$attribute[[j]]$missingValueCode$code == ''){
data_table$attributeList$attribute[[j]]$missingValueCode$code <- NA_character_
data_table$attributeList$attribute[[j]]$missingValueCode$codeExplanation <- NA_character_
}
}
data_table
}
)
}
# Create <otherEntity> ------------------------------------------------------
if (!is.null(x$other.entity)) {
eml$dataset$otherEntity <- lapply(
names(x$other.entity),
function(k) {
message(paste0(" <otherEntity> (", k, ")"))
# Set physical
# Some sub-routine in EML::set_physical() doesn't like the .zip
# file extension, so we suppress the warning here so users aren't
# uneccessarily burdened by it. Not a great solution since helpful
# warnings will be lost.
physical <- suppressWarnings(
suppressMessages(
EML::set_physical(
paste0(data.path, "/", k))))
physical$dataFormat$textFormat <- NULL
if (!requireNamespace("mime", quietly = TRUE)) {
warning("Package 'mime' is required for detecting the script mime type but is not installed", call. = FALSE)
physical$dataFormat$externallyDefinedFormat$formatName <- "Unknown"
} else {
physical$dataFormat$externallyDefinedFormat$formatName <- mime::guess_type(
file = k, unknown = "Unknown", empty = "Unknown")
}
if (!is.null(other.entity.url)) {
# other.entity.url isn't required for each data table, but must have a
# non-NULL entry in the other.entity.url if other data tables have a
# URL. A "" or NA indicates to skip URL assignment.
url <- other.entity.url[which(k == names(x$other.entity))]
if ((url == "") | is.na(url)) {
physical$distribution <- list()
} else {
physical$distribution$online$url <- url
}
} else {
physical$distribution <- list()
}
# Create otherEntity
list(
entityName = other.entity.name[
which(k == names(x$other.entity))],
entityDescription = other.entity.description[
which(k == names(x$other.entity))],
physical = physical,
entityType = "unknown")
})
}
# Create <additionalMetadata> -----------------------------------------------
if (!is.null(x$template$custom_units.txt)) {
message(" <additionalMetadata>")
eml$additionalMetadata[[
length(eml$dataset$additionalMetadata)+1]]$metadata$unitList <- EML::set_unitList(
x$template$custom_units.txt$content)
}
# Create <annotations> ------------------------------------------------------
if (any(stringr::str_detect(names(x$template), "annotations.txt"))) {
message(" <annotations>")
eml <- suppressMessages(
annotate_eml(
annotations = x$template$annotations.txt$content,
eml.in = eml))
}
# Write EML -----------------------------------------------------------------
message("</eml>")
if (isTRUE(write.file)) {
message(paste0("Writing EML (", package.id, ".xml)"))
emld::eml_version("eml-2.2.0")
EML::write_eml(eml, paste0(eml.path, "/", package.id, ".xml"))
# Fix TextType nodes - EML::set_TextType() and EML::set_methods() replace
# special XML characters &, <, >, with their encoded representations. These
# characters are encoded a second time by EML::write_eml() resulting in
# replacement of "&" by "&" resulting in "&gt;" etc. The below code
# block patches this issue.
txt <- readLines(paste0(eml.path, "/", package.id, ".xml"), encoding = "UTF-8")
for (x in seq_along(txt)) {
txt[x] <- stringr::str_replace_all(txt[x], "&gt;", ">")
txt[x] <- stringr::str_replace_all(txt[x], "&lt;", "<")
txt[x] <- stringr::str_replace_all(txt[x], "&amp;", "&")
}
writeLines(txt, paste0(eml.path, "/", package.id, ".xml"), useBytes = T)
}
# Validate EML --------------------------------------------------------------
message("Validating EML")
r <- EML::eml_validate(eml)
if (isTRUE(r)) {
message(" Validation passed :)")
} else {
message(" Validation failed :(")
}
message("Done.")
if (isTRUE(return.obj)) {
eml
}
}
Try the ecocomDP package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.