Merge pull request #229 from pascal-sauer/master

fix prepExtendedComment called from package::fun

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '63144016'
+ValidationKey: '63182967'
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
 - 'Warning: namespace ''.*'' is not available and has been replaced'

CITATION.cff

@@ -2,8 +2,8 @@ cff-version: 1.2.0
 message: If you use this software, please cite it using the metadata from this file.
 type: software
 title: 'madrat: May All Data be Reproducible and Transparent (MADRaT) *'
-version: 3.15.2
-date-released: '2024-11-06'
+version: 3.15.3
+date-released: '2024-11-12'
 abstract: Provides a framework which should improve reproducibility and transparency
   in data processing. It provides functionality such as automatic meta data creation
   and management, rudimentary quality management, data caching, work-flow management

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: madrat
 Title: May All Data be Reproducible and Transparent (MADRaT) *
-Version: 3.15.2
-Date: 2024-11-06
+Version: 3.15.3
+Date: 2024-11-12
 Authors@R: c(
     person("Jan Philipp", "Dietrich", , "[email protected]", role = c("aut", "cre"),
            comment = c(affiliation = "Potsdam Institute for Climate Impact Research", ORCID = "0000-0002-4309-6431")),

R/calcOutput.R

@@ -114,6 +114,8 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
   saveCache <- isWrapperActive("saveCache")
   setWrapperInactive("saveCache")
 
+  callString <- functionCallString("calcOutput", argumentValues)
+
   if (!is.null(na_warning)) {
     warning('Argument "na_warning" is deprecated. Please use "warnNA" instead!')
     warnNA <- na_warning
@@ -129,7 +131,7 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
   if (!is.character(type)) stop("Invalid type (must be a character)!")
   if (length(type) != 1) stop("Invalid type (must be a single character string)!")
 
-  .checkData <- function(x, functionname) {
+  .checkData <- function(x, functionname, callString) {
     if (!is.list(x)) {
       stop("Output of function \"", functionname,
            "\" is not list of two MAgPIE objects containing the values and corresponding weights!")
@@ -247,7 +249,7 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
     vcat(-2, "")
   }
 
-  startinfo <- toolstartmessage("calcOutput", argumentValues, "+")
+  startinfo <- toolstartmessage(callString, "+")
   defer({
     toolendmessage(startinfo, "-")
   })
@@ -262,7 +264,7 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
   x <- cacheGet(prefix = "calc", type = type, args = args)
 
   if (!is.null(x)) {
-    x <- try(.checkData(x, functionname), silent = TRUE)
+    x <- try(.checkData(x, functionname, callString), silent = TRUE)
     if ("try-error" %in% class(x)) {
       vcat(2, " - cache file corrupt for ", functionname, show_prefix = FALSE)
       x <- NULL
@@ -282,7 +284,7 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
       x <- withMadratLogging(eval(parse(text = functionname)))
     }
     setWrapperInactive("wrapperChecks")
-    x <- .checkData(x, functionname)
+    x <- .checkData(x, functionname, callString)
     cachePut(x, prefix = "calc", type = type, args = args)
   }
 
@@ -307,7 +309,7 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
     if (!is.null(x$weight)) if (nyears(x$weight) > 1) x$weight <- x$weight[, years, ]
   }
 
-  extendedComment <- prepExtendedComment(x, type)
+  extendedComment <- prepExtendedComment(x, type, callString)
 
   if (!isFALSE(aggregate)) {
 

R/downloadSource.R

@@ -50,7 +50,7 @@ downloadSource <- function(type, subtype = NULL, overwrite = FALSE, numberOfTrie
   setWrapperActive("downloadSource")
   setWrapperInactive("wrapperChecks")
 
-  startinfo <- toolstartmessage("downloadSource", argumentValues, "+")
+  startinfo <- toolstartmessage(functionCallString("downloadSource", argumentValues), "+")
   defer({
     toolendmessage(startinfo, "-")
   })

R/functionCallString.R

@@ -0,0 +1,29 @@
+#' functionCallString
+#'
+#' Create a string representation for a function call. If the resulting string
+#' is longer than getConfig("maxLengthLogMessage") arguments are printed as
+#' passed (e.g. as variable name instead of the evaluated content of that
+#' variable), if that is still too long it is cropped.
+#'
+#' @param functionName name of the called function
+#' @param argumentValues the list of arguments passed
+#' @return A string representing the given function call
+#'
+#' @author Pascal Sauer
+functionCallString <- function(functionName, argumentValues) {
+  nonDefaultArguments <- getNonDefaultArguments(functionName, argumentValues)
+  argsString <- paste0(list(nonDefaultArguments)) # wrap everything in list for nicer string output
+  argsString <- substr(argsString, 6, nchar(argsString) - 1) # remove superfluous list from string
+
+  callWithEvaluatedArgs <- paste0(functionName, "(", argsString, ")")
+  if (nchar(callWithEvaluatedArgs) <= getConfig("maxLengthLogMessage")) {
+    functionCallString <- callWithEvaluatedArgs
+  } else {
+    functionCallString <- paste0(deparse(sys.call(-1)), collapse = "")
+    if (nchar(functionCallString) > getConfig("maxLengthLogMessage")) {
+      functionCallString <- paste0(substr(callWithEvaluatedArgs, 1,
+                                          getConfig("maxLengthLogMessage") - 3), "...")
+    }
+  }
+  return(functionCallString)
+}

R/prepExtendedComment.R

@@ -6,24 +6,12 @@
 #' @md
 #' @param x list containing the metadata to be condensed
 #' @param type output type, e.g. "TauTotal"
+#' @param functionCallString A string representation of the function call
+#' that created the object this comment is attached to
 #' @param warn boolean indicating whether warnings should be triggered
 #' if entries are missing, or not.
-#' @param n the number of functions to go back for the extraction of the call
-#' information
-#' @author Jan Philipp Dietrich
-#' @examples
-#' test <- function(a = 1) {
-#'    return(madrat:::prepExtendedComment(list(unit = "m", description = "example", package = "blub")))
-#'  }
-#'  test(a = 42)
-#'
-prepExtendedComment <- function(x, type = "#undefined", warn = TRUE, n = 1) {
-
-  # extract function call information for the parent call defined by n
-  cl <- sys.call(-n)
-  f <- get(as.character(cl[[1]]), mode = "function", sys.frame(-n - 1))
-  cl <- match.call(definition = f, call = cl)
-
+#' @author Jan Philipp Dietrich, Pascal Sauer
+prepExtendedComment <- function(x, type, functionCallString, warn = TRUE) {
   if (isTRUE(warn)) {
     unitWarning <- paste0('Missing unit information for data set "', type, '"!')
     descriptionWarning <- paste0('Missing description for data set "', type,
@@ -36,7 +24,7 @@ prepExtendedComment <- function(x, type = "#undefined", warn = TRUE, n = 1) {
   unit        <- prepComment(x$unit, "unit", unitWarning)
   description <- prepComment(x$description, "description", descriptionWarning)
   comment     <- prepComment(cleanComment(x$x), "comment")
-  origin      <- prepComment(paste0(gsub("\\s{2,}", " ", paste(deparse(cl), collapse = "")),
+  origin      <- prepComment(paste0(gsub("\\s{2,}", " ", functionCallString),
                                     " (madrat ", unname(getNamespaceVersion("madrat")), " | ", x$package, ")"),
                              "origin")
   date        <- prepComment(date(), "creation date")

R/pucAggregate.R

@@ -38,7 +38,7 @@ pucAggregate <- function(puc, regionmapping = getConfig("regionmapping"), ..., r
   setWrapperActive("pucAggregate")
 
   extraArgs <- list(...)
-  startinfo <- toolstartmessage("pucAggregate", argumentValues, "+")
+  startinfo <- toolstartmessage(functionCallString("pucAggregate", argumentValues), "+")
   puc <- normalizePath(puc)
   if (file.exists(regionmapping)) regionmapping <- normalizePath(regionmapping)
 

R/readSource.R

@@ -56,8 +56,10 @@ readSource <- function(type, subtype = NULL, subset = NULL, # nolint: cyclocomp_
   setWrapperActive("readSource")
   setWrapperInactive("wrapperChecks")
 
+  callString <- functionCallString("readSource", argumentValues)
+
   withr::local_dir(getConfig("mainfolder"))
-  startinfo <- toolstartmessage("readSource", argumentValues, "+")
+  startinfo <- toolstartmessage(callString, "+")
   withr::defer({
     toolendmessage(startinfo, "-")
   })
@@ -113,7 +115,7 @@ readSource <- function(type, subtype = NULL, subset = NULL, # nolint: cyclocomp_
   }
 
   # get data either from cache or by calculating it from source
-  .getData <- function(type, subtype, subset, args, prefix) {
+  .getData <- function(type, subtype, subset, args, prefix, callString) {
     sourcefolder <- getSourceFolder(type, subtype)
 
     xList <- .getFromCache(prefix, type, args, subtype, subset)
@@ -129,7 +131,7 @@ readSource <- function(type, subtype = NULL, subset = NULL, # nolint: cyclocomp_
       } else {
         upstreamPrefix <- "read"
       }
-      xList <- .getData(type, subtype, subset, args, upstreamPrefix)
+      xList <- .getData(type, subtype, subset, args, upstreamPrefix, callString)
       # this x is passed to correct or convert function
       x <- xList$x
     }
@@ -173,7 +175,7 @@ readSource <- function(type, subtype = NULL, subset = NULL, # nolint: cyclocomp_
       }
     }
 
-    extendedComment <- prepExtendedComment(xList, type, n = 2, warn = FALSE)
+    extendedComment <- prepExtendedComment(xList, type, callString, warn = FALSE)
     if (xList$class == "magpie") {
       getComment(xList$x) <- extendedComment
     } else {
@@ -254,7 +256,7 @@ readSource <- function(type, subtype = NULL, subset = NULL, # nolint: cyclocomp_
     stop('Unknown convert setting "', convert, '" (allowed: TRUE, FALSE and "onlycorrect")')
   }
 
-  xList <- .getData(type, subtype, subset, args, prefix)
+  xList <- .getData(type, subtype, subset, args, prefix, callString)
   if (magclass::is.magpie(xList$x)) {
     xList$x <- clean_magpie(xList$x)
   }

R/retrieveData.R

@@ -63,6 +63,8 @@ retrieveData <- function(model, rev = 0, dev = "", cachetype = "def", puc = iden
   setWrapperActive("saveCache")
   setWrapperInactive("wrapperChecks")
 
+  callString <- functionCallString("retrieveData", argumentValues)
+
   local_options(madratWarningsCounter = 0)
 
   if (!(cachetype %in% c("rev", "def"))) {
@@ -81,7 +83,7 @@ retrieveData <- function(model, rev = 0, dev = "", cachetype = "def", puc = iden
     matchingCollections <- .match(getConfig("outputfolder"), "tgz", cfg$collectionName)
 
     if (length(matchingCollections) > 0) {
-      startinfo <- toolstartmessage("retrieveData", argumentValues, 0)
+      startinfo <- toolstartmessage(callString, 0)
       vcat(-2, " - data is already available and not calculated again.", fill = 300)
       toolendmessage(startinfo)
       return(invisible(file.path(getConfig("outputfolder"), matchingCollections)))
@@ -133,7 +135,7 @@ retrieveData <- function(model, rev = 0, dev = "", cachetype = "def", puc = iden
   vcat(3, paste(c("sessionInfo:", capture.output(sessionInfo()), "\n"), collapse = "\n"))
 
   # run full* functions
-  startinfo <- toolstartmessage("retrieveData", argumentValues, 0)
+  startinfo <- toolstartmessage(callString, 0)
 
   vcat(2, " - execute function ", cfg$functionName, fill = 300, show_prefix = FALSE)
 

R/toolstartmessage.R

@@ -3,8 +3,7 @@
 #' This function writes a process start message (what function was called with which arguments) and stores the current
 #' time, so the corresponding call to \code{\link{toolendmessage}} can calculate the elapsed time.
 #'
-#' @param functionName The name of the calling function as a string.
-#' @param argumentValues A list of the evaluated arguments of the calling function.
+#' @param functionCallString A string representing the function call that should be logged
 #' @param level This argument allows to establish a hierarchy of print statements. The hierarchy is preserved for the
 #' next vcat executions. Currently this setting can have 4 states: NULL (nothing will be changed), 0 (reset
 #' hierarchies), "+" (increase hierarchy level by 1) and "-" (decrease hierarchy level by 1).
@@ -15,39 +14,20 @@
 #' @examples
 #'
 #' innerFunction <- function() {
-#'   startinfo <- madrat:::toolstartmessage("innerFunction", list(argumentsToPrint = 123), "+")
+#'   startinfo <- madrat:::toolstartmessage("innerFunction(argumentsToPrint = 123)", "+")
 #'   vcat(1, "inner")
 #'   madrat:::toolendmessage(startinfo, "-")
 #' }
 #' outerFunction <- function() {
-#'   startinfo <- madrat:::toolstartmessage("outerFunction", list(), "+")
+#'   startinfo <- madrat:::toolstartmessage("outerFunction()", "+")
 #'   vcat(1, "outer")
 #'   innerFunction()
 #'   madrat:::toolendmessage(startinfo, "-")
 #' }
 #' outerFunction()
-toolstartmessage <- function(functionName, argumentValues, level = NULL) {
-
+toolstartmessage <- function(functionCallString, level = NULL) {
   setWrapperInactive("wrapperChecks")
 
-  nonDefaultArguments <- getNonDefaultArguments(functionName, argumentValues)
-  argsString <- paste0(list(nonDefaultArguments)) # wrap everything in list for nicer string output
-  argsString <- substr(argsString, 6, nchar(argsString) - 1) # remove superfluous list from string
-
-  callWithEvaluatedArgs <- paste0(functionName, "(", argsString, ")")
-  if (nchar(callWithEvaluatedArgs) <= getConfig("maxLengthLogMessage")) {
-    functionCallString <- callWithEvaluatedArgs
-    hint <- ""
-  } else {
-    functionCallString <- paste0(deparse(sys.call(-1)), collapse = "")
-    if (nchar(functionCallString) > getConfig("maxLengthLogMessage")) {
-      functionCallString <- paste0(substr(callWithEvaluatedArgs, 1,
-                                          getConfig("maxLengthLogMessage") - 3), "...")
-    }
-    hint <- paste0(" -- to print all evaluated arguments: setConfig(maxLengthLogMessage = ",
-                   nchar(callWithEvaluatedArgs), ")")
-  }
-
-  vcat(1, "Run ", functionCallString, hint, level = level, fill = 300, show_prefix = FALSE)
+  vcat(1, "Run ", functionCallString, level = level, fill = 300, show_prefix = FALSE)
   return(list(time1 = proc.time(), functionCallString = functionCallString))
 }

README.md

@@ -1,6 +1,6 @@
 # May All Data be Reproducible and Transparent (MADRaT) *
 
-R package **madrat**, version **3.15.2**
+R package **madrat**, version **3.15.3**
 
 [![CRAN status](https://www.r-pkg.org/badges/version/madrat)](https://cran.r-project.org/package=madrat) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.1115490.svg)](https://doi.org/10.5281/zenodo.1115490) [![R build status](https://github.com/pik-piam/madrat/workflows/check/badge.svg)](https://github.com/pik-piam/madrat/actions) [![codecov](https://codecov.io/gh/pik-piam/madrat/branch/master/graph/badge.svg)](https://app.codecov.io/gh/pik-piam/madrat) [![r-universe](https://pik-piam.r-universe.dev/badges/madrat)](https://pik-piam.r-universe.dev/builds)
 
@@ -55,7 +55,7 @@ In case of questions / problems please contact Jan Philipp Dietrich <dietrich@pi
 
 To cite package **madrat** in publications use:
 
-Dietrich J, Baumstark L, Wirth S, Giannousakis A, Rodrigues R, Bodirsky B, Leip D, Kreidenweis U, Klein D, Sauer P (2024). _madrat: May All Data be Reproducible and Transparent (MADRaT)_. doi:10.5281/zenodo.1115490 <https://doi.org/10.5281/zenodo.1115490>, R package version 3.15.2, <https://github.com/pik-piam/madrat>.
+Dietrich J, Baumstark L, Wirth S, Giannousakis A, Rodrigues R, Bodirsky B, Leip D, Kreidenweis U, Klein D, Sauer P (2024). _madrat: May All Data be Reproducible and Transparent (MADRaT)_. doi:10.5281/zenodo.1115490 <https://doi.org/10.5281/zenodo.1115490>, R package version 3.15.3, <https://github.com/pik-piam/madrat>.
 
 A BibTeX entry for LaTeX users is
 
@@ -64,7 +64,7 @@ A BibTeX entry for LaTeX users is
   title = {madrat: May All Data be Reproducible and Transparent (MADRaT)},
   author = {Jan Philipp Dietrich and Lavinia Baumstark and Stephen Wirth and Anastasis Giannousakis and Renato Rodrigues and Benjamin Leon Bodirsky and Debbora Leip and Ulrich Kreidenweis and David Klein and Pascal Sauer},
   year = {2024},
-  note = {R package version 3.15.2},
+  note = {R package version 3.15.3},
   url = {https://github.com/pik-piam/madrat},
   doi = {10.5281/zenodo.1115490},
 }