diff --git a/DESCRIPTION b/DESCRIPTION index 7efa6d87..71a133da 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: soilDB Type: Package Title: Soil Database Interface -Version: 2.8.13 +Version: 2.8.14 Authors@R: c(person(given="Dylan", family="Beaudette", role = c("aut"), email = "dylan.beaudette@usda.gov", comment=c(ORCID="0009-0008-2780-4785")), person(given="Jay", family="Skovlin", role = c("aut")), person(given="Stephen", family="Roecker", role = c("aut")), diff --git a/R/SDA_query.R b/R/SDA_query.R index ccba57b5..9a3c01f5 100644 --- a/R/SDA_query.R +++ b/R/SDA_query.R @@ -105,6 +105,55 @@ format_SQL_in_statement <- function(x) { #' str(x) #' } SDA_query <- function(q, dsn = NULL) { + + # construct header for SDA metrics + fn <- NULL + fne <- NULL + + tryCatch({ + ## prepend info about the caller as query comment header + calls <- sys.calls() + + # prevent iteration over very large call stacks + if (length(calls) > 100) { + calls <- calls[1:100] + } + + # determine environment name for each call stack + envs <- sapply(calls, function(x) + try(environmentName(environment(eval(x[[1]]))), silent = TRUE)) + + # keep only soilDB calls + calls <- calls[grepl("soilDB", as.character(envs))] + + # extract the function call and environment name + fn <- calls[[1]][[1]] + fne <- try(environmentName(environment(eval(fn))), silent = TRUE) + + # handle namespaced function calls + fn <- as.character(fn)[length(fn)] + }, error = function(e) { + # silently skip to fallback on error + }, finally = { + if (length(fn) == 0 || + !nzchar(fn) || + !nzchar(fne) || + inherits(fne, 'try-error')) { + fn <- "SDA_query" + fne <- "soilDB" + } + }) + + if (nzchar(fne)) { + sep <- "::" + if (fne == "soilDB" && startsWith(fn, ".")) { + sep <- ":::" + } + fn <- paste0(fne, sep, fn) + } + + q <- paste0(.SDA_comment_header(fn), "\n", q) + if (is.null(dsn)) { res <- .SDA_query(q) if (inherits(res, 'try-error')) { diff --git a/R/utils.R b/R/utils.R index 5474d276..ef189007 100644 --- a/R/utils.R +++ b/R/utils.R @@ -15,6 +15,45 @@ }, simplify = FALSE))) } +#' Generate SDA SQL Comment Header +#' +#' This function generates a standardized SQL comment header string to be +#' prepended to SDA queries. +#' +#' @param function_name Character. The name of the high-level `soilDB` function +#' generating the query. +#' @param package_version Character. The current version of the `soilDB` +#' package. +#' +#' @return A character string containing the SQL comment header. +#' @noRd +#' @keywords internal +#' +#' @examples +#' generate_SDA_comment_header("soilDB::get_SDA_property") +.SDA_comment_header <- function(function_name, + package_version = as.character(packageVersion('soilDB'))) { + + if (!is.character(function_name) || + length(function_name) != 1 || + nchar(function_name) == 0) { + stop("`function_name` must be a non-empty character string.") + } + + if (!is.character(package_version) || + length(package_version) != 1 || + nchar(package_version) == 0) { + stop("`package_version` must be a non-empty character string.") + } + + # Construct the SQL comment header + sprintf( + "/** SDA Query application='soilDB' rule='%s' version='%s' **/", + function_name, + package_version + ) +} + # convert diagnostic horizon info into wide-formatted, boolean table .diagHzLongtoWide <- function(d, feature = 'featkind', id = 'peiid') {