convert cache write errors to warnings

pik-piam · Jul 25, 2023 · 4a86b6d · 4a86b6d
1 parent 1c5bed8
commit 4a86b6d
Show file tree

Hide file tree

Showing 7 changed files with 106 additions and 81 deletions.
diff --git a/.buildlibrary b/.buildlibrary
@@ -1,4 +1,4 @@
-ValidationKey: '7081806'
+ValidationKey: '7101369'
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
 - 'Warning: namespace ''.*'' is not available and has been replaced'

diff --git a/CITATION.cff b/CITATION.cff
@@ -2,7 +2,7 @@ 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.6.2
+version: 3.6.3
 date-released: '2023-07-25'
 abstract: Provides a framework which should improve reproducibility and transparency
   in data processing. It provides functionality such as automatic meta data creation

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: madrat
 Title: May All Data be Reproducible and Transparent (MADRaT) *
-Version: 3.6.2
+Version: 3.6.3
 Date: 2023-07-25
 Authors@R: c(
     person("Jan Philipp", "Dietrich", , "dietrich@pik-potsdam.de", role = c("aut", "cre")),

diff --git a/R/cachePut.R b/R/cachePut.R
@@ -20,35 +20,38 @@
 #' @importFrom digest digest
 
 cachePut <- function(x, prefix, type, args = NULL, graph = NULL, ...) {
-
-  if (is.list(x) && isFALSE(x$cache)) {
-    vcat(1, " - cache disabled for ", prefix, type, fill = 300, show_prefix = FALSE)
-    return()
-  }
-
-  fname <- cacheName(prefix = prefix, type = type, args = args,  graph = graph, mode = "put", ...)
-  if (!is.null(fname)) {
-    if (!dir.exists(dirname(fname))) {
-      dir.create(dirname(fname), recursive = TRUE)
+  tryCatch({
+    if (is.list(x) && isFALSE(x$cache)) {
+      vcat(1, " - cache disabled for ", prefix, type, fill = 300, show_prefix = FALSE)
+      return()
     }
-    attr(x, "cachefile") <- basename(fname)
-    vcat(1, " - writing cache ", basename(fname), fill = 300, show_prefix = FALSE)
-    if (is.list(x)) {
-      for (elem in c("x", "weight")) {
-        if (inherits(x[[elem]], c("SpatRaster", "SpatVector"))) {
-          x[[elem]] <- toolTerraToCache(x[[elem]], elem, fname)
+
+    fname <- cacheName(prefix = prefix, type = type, args = args,  graph = graph, mode = "put", ...)
+    if (!is.null(fname)) {
+      if (!dir.exists(dirname(fname))) {
+        dir.create(dirname(fname), recursive = TRUE)
+      }
+      attr(x, "cachefile") <- basename(fname)
+      vcat(1, " - writing cache ", basename(fname), fill = 300, show_prefix = FALSE)
+      if (is.list(x)) {
+        for (elem in c("x", "weight")) {
+          if (inherits(x[[elem]], c("SpatRaster", "SpatVector"))) {
+            x[[elem]] <- toolTerraToCache(x[[elem]], elem, fname)
+          }
         }
       }
-    }
 
-    attr(x, "madratMessage") <- getMadratMessage(fname = paste0(prefix, type))
+      attr(x, "madratMessage") <- getMadratMessage(fname = paste0(prefix, type))
 
-    # write to tempfile to avoid corrupt cache files in parallel running preprocessings
-    tempfileName <- paste0(fname, Sys.getenv("SLURM_JOB_ID", unset = ""))
-    saveRDS(x, file = tempfileName, compress = getConfig("cachecompression"))
-    file.rename(tempfileName, fname)
-    Sys.chmod(fname, mode = "0666", use_umask = FALSE)
-  }
+      # write to tempfile to avoid corrupt cache files in parallel running preprocessings
+      tempfileName <- paste0(fname, Sys.getenv("SLURM_JOB_ID", unset = ""))
+      saveRDS(x, file = tempfileName, compress = getConfig("cachecompression"))
+      file.rename(tempfileName, fname)
+      Sys.chmod(fname, mode = "0666", use_umask = FALSE)
+    }
+  }, error = function(e) {
+    vcat(0, " - could not write cache file: ", e$message, fill = 300, show_prefix = FALSE)
+  })
 }
 
 # madrat is confused when using tools::, maybe thinks this has to do with tool functions, so need to import

diff --git a/R/calcOutput.R b/R/calcOutput.R
@@ -117,7 +117,7 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
   }
 
   if (!dir.exists(getConfig("cachefolder"))) {
-      dir.create(getConfig("cachefolder"), recursive = TRUE)
+    dir.create(getConfig("cachefolder"), recursive = TRUE)
   }
 
   if (!is.null(regionmapping)) localConfig(regionmapping = regionmapping)
@@ -127,31 +127,44 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
   if (length(type) != 1) stop("Invalid type (must be a single character string)!")
 
   .checkData <- function(x, functionname) {
-    if (!is.list(x)) stop("Output of function \"", functionname,
-      "\" is not list of two MAgPIE objects containing the values and corresponding weights!")
-    if (is.null(x$class)) x$class <- "magpie"
-    if (!is.character(x$class) || length(x$class) != 1) stop("x$class must be a single element of class",
-      " character or NULL!")
-    if (x$class == "magpie" && !is.magpie(x$x)) stop("Output x of function \"", functionname,
-      "\" is not a MAgPIE object!")
-    if (!(x$class %in% class(x$x))) stop("Output x of function \"", functionname, "\" is not of promised class \"",
-      x$class, "\"!")
-    if (x$class != "magpie" && !is.null(x$weight)) stop("Weights are currently not supported for objects of class \"",
-      x$class, "\"!")
-    if (!is.magpie(x$weight) && !is.null(x$weight)) stop("Output weight of function \"", functionname,
-      "\" is not a MAgPIE object!")
+    if (!is.list(x)) {
+      stop("Output of function \"", functionname,
+           "\" is not list of two MAgPIE objects containing the values and corresponding weights!")
+    }
+    if (is.null(x$class)) {
+      x$class <- "magpie"
+    }
+    if (!is.character(x$class) || length(x$class) != 1) {
+      stop("x$class must be a single element of class character or NULL!")
+    }
+    if (x$class == "magpie" && !is.magpie(x$x)) {
+      stop("Output x of function \"", functionname, "\" is not a MAgPIE object!")
+    }
+    if (!(x$class %in% class(x$x))) {
+      stop("Output x of function \"", functionname, "\" is not of promised class \"", x$class, "\"!")
+    }
+    if (x$class != "magpie" && !is.null(x$weight)) {
+      stop("Weights are currently not supported for objects of class \"", x$class, "\"!")
+    }
+    if (!is.magpie(x$weight) && !is.null(x$weight)) {
+      stop("Output weight of function \"", functionname, "\" is not a MAgPIE object!")
+    }
     if (!is.null(x$weight)) {
-      if (nyears(x$x) != nyears(x$weight) && nyears(x$weight) != 1) stop("Number of years disagree between data and ",
-        "weight of function \"", functionname, "\"!")
-      if (nyears(x$weight) == 1) getYears(x$weight) <- NULL
+      if (nyears(x$x) != nyears(x$weight) && nyears(x$weight) != 1) {
+        stop("Number of years disagree between data and ", "weight of function \"", functionname, "\"!")
+      }
+      if (nyears(x$weight) == 1) {
+        getYears(x$weight) <- NULL
+      }
     }
     x$package <- attr(functionname, "pkgcomment")
 
     # read and check x$isocountries value which describes whether the data is in
     # iso country resolution or not (affects aggregation and certain checks)
     if (x$class != "magpie") {
-      if (!is.null(x$isocountries) && x$isocountries != FALSE) stop("x$isocountries can only be set ",
-        "if x$class==\"magpie\"")
+      if (!is.null(x$isocountries) && x$isocountries != FALSE) {
+        stop("x$isocountries can only be set if x$class==\"magpie\"")
+      }
       x$isocountries <- FALSE
     }
     if (is.null(x$isocountries)) {
@@ -175,33 +188,40 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
         isoCountry1 <- as.vector(isoCountry[, "x"])
         names(isoCountry1) <- isoCountry[, "X"]
         isocountries <- robustSort(isoCountry1)
-        if (length(isocountries) != length(datacountries)) stop("Wrong number of countries in ", name,
-          " returned by ", functionname, "!")
-        if (any(isocountries != datacountries)) stop("Countries in ", name, " returned by ", functionname,
-          " do not agree with iso country list!")
+        if (length(isocountries) != length(datacountries)) {
+          stop("Wrong number of countries in ", name, " returned by ", functionname, "!")
+        }
+        if (any(isocountries != datacountries)) {
+          stop("Countries in ", name, " returned by ", functionname, " do not agree with iso country list!")
+        }
       }
       .countrycheck(getItems(x$x, dim = 1.1), "x")
-      if (!is.null(x$weight) && nregions(x$weight) > 1) .countrycheck(getItems(x$weight, dim = 1.1), "weight")
+      if (!is.null(x$weight) && nregions(x$weight) > 1) {
+        .countrycheck(getItems(x$weight, dim = 1.1), "weight")
+      }
     }
     # perform additional checks
     if (x$class != "magpie" && (!is.null(x$min) || !is.null(x$max))) {
       stop("Min/Max checks cannot be used in combination with x$class!=\"magpie\"")
     }
-    if (!is.null(x$min) && any(x$x < x$min, na.rm = TRUE)) vcat(0, "Data returned by ", functionname,
-      " contains values smaller than the predefined minimum",
-      " (min = ", x$min, ")")
-    if (!is.null(x$max) && any(x$x > x$max, na.rm = TRUE)) vcat(0, "Data returned by ", functionname,
-      " contains values greater than the predefined maximum",
-      " (max = ", x$max, ")")
+    if (!is.null(x$min) && any(x$x < x$min, na.rm = TRUE)) {
+      vcat(0, "Data returned by ", functionname, " contains values smaller than the predefined minimum",
+           " (min = ", x$min, ")")
+    }
+    if (!is.null(x$max) && any(x$x > x$max, na.rm = TRUE)) {
+      vcat(0, "Data returned by ", functionname, " contains values greater than the predefined maximum",
+           " (max = ", x$max, ")")
+    }
     checkNameStructure <- function(x, structure, dim, class) {
-      if (class != "magpie" && !is.null(structure)) stop("Structure checks cannot be used in combination",
-        " with x$class!=\"magpie\"")
+      if (class != "magpie" && !is.null(structure)) {
+        stop("Structure checks cannot be used in combination with x$class!=\"magpie\"")
+      }
       if (!is.null(structure)) {
         if (is.null(getItems(x, dim))) {
           vcat(0, paste("Missing names in dimension", dim, "!"))
         } else if (!all(grepl(structure, getItems(x, dim)))) {
           vcat(0, paste0("Invalid names (dim=", dim, ', structure=\"', structure, '\"): '),
-            paste(grep(structure, getItems(x, dim), value = TRUE, invert = TRUE), collapse = ", "))
+               paste(grep(structure, getItems(x, dim), value = TRUE, invert = TRUE), collapse = ", "))
         }
       }
     }
@@ -262,8 +282,8 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
   if (is.logical(x$putInPUC)) saveCache <- x$putInPUC
 
   if (saveCache) {
-   write(cacheName(prefix = "calc", type = type, args = args),
-         file = "pucFiles", append = TRUE)
+    write(cacheName(prefix = "calc", type = type, args = args),
+          file = "pucFiles", append = TRUE)
   }
 
 
@@ -272,8 +292,8 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
     # check that years exist in provided data
     if (!all(as.integer(sub("y", "", years)) %in% getYears(x$x, as.integer = TRUE))) {
       stop("Some years are missing in the data provided by function ", functionname, "(",
-        paste(years[!(as.integer(sub("y", "", years)) %in% getYears(x$x, as.integer = TRUE))], collapse = ", "),
-        ")!")
+           paste(years[!(as.integer(sub("y", "", years)) %in% getYears(x$x, as.integer = TRUE))], collapse = ", "),
+           ")!")
     }
     x$x <- x$x[, years, ]
     if (!is.null(x$weight)) if (nyears(x$weight) > 1) x$weight <- x$weight[, years, ]
@@ -304,12 +324,12 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
 
   unit        <- .prepComment(x$unit, "unit", paste0('Missing unit information for data set "', type, '"!'))
   description <- .prepComment(x$description, "description",
-    paste0('Missing description for data set "', type,
-      '"! Please add a description in the corresponding calc function!'))
+                              paste0('Missing description for data set "', type,
+                                     '"! Please add a description in the corresponding calc function!'))
   comment     <- .prepComment(.cleanComment(x$x), "comment")
   origin      <- .prepComment(paste0(gsub("\\s{2,}", " ", paste(deparse(match.call()), collapse = "")),
-    " (madrat ", unname(getNamespaceVersion("madrat")), " | ", x$package, ")"),
-  "origin")
+                                     " (madrat ", unname(getNamespaceVersion("madrat")), " | ", x$package, ")"),
+                              "origin")
   date        <- .prepComment(date(), "creation date")
   note        <- .prepComment(x$note, "note")
 
@@ -366,11 +386,11 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
   }
 
   extendedComment <- c(description,
-    unit,
-    note,
-    comment,
-    origin,
-    date)
+                       unit,
+                       note,
+                       comment,
+                       origin,
+                       date)
   if (x$class == "magpie") {
     getComment(x$x) <- extendedComment
     x$x <- clean_magpie(x$x)
@@ -502,8 +522,10 @@ calcOutput <- function(type, aggregate = TRUE, file = NULL, years = NULL, # noli
   relFitting <- which(vapply(rel, nrow, FUN.VALUE = integer(1)) == length(items) &
                         !vapply(columnNameWithItems, identical, character(0), FUN.VALUE = logical(1)))
 
-  if (length(relFitting) == 0) stop("Neither getConfig(\"regionmapping\") nor getConfig(\"extramappings\")",
-                                    " contain a mapping compatible to the provided data!")
+  if (length(relFitting) == 0) {
+    stop("Neither getConfig(\"regionmapping\") nor getConfig(\"extramappings\")",
+         " contain a mapping compatible to the provided data!")
+  }
 
   # keep mappings only that fit the data
   rel <- rel[relFitting]

diff --git a/README.md b/README.md
@@ -1,6 +1,6 @@
 # May All Data be Reproducible and Transparent (MADRaT) *
 
-R package **madrat**, version **3.6.2**
+R package **madrat**, version **3.6.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, Führlich P (2023). _madrat: May All Data be Reproducible and Transparent (MADRaT)_. doi: 10.5281/zenodo.1115490 (URL: https://doi.org/10.5281/zenodo.1115490), R package version 3.6.2, <URL: https://github.com/pik-piam/madrat>.
+Dietrich J, Baumstark L, Wirth S, Giannousakis A, Rodrigues R, Bodirsky B, Leip D, Kreidenweis U, Klein D, Führlich P (2023). _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.6.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 Führlich},
   year = {2023},
-  note = {R package version 3.6.2},
+  note = {R package version 3.6.3},
   doi = {10.5281/zenodo.1115490},
   url = {https://github.com/pik-piam/madrat},
 }

diff --git a/tests/testthat/test-caching.R b/tests/testthat/test-caching.R
@@ -42,7 +42,7 @@ test_that("Argument hashing works", {
   expect_null(cacheArgumentsHash(readTau, list(subtype = "paper")))
   expect_identical(cacheArgumentsHash(readTau, args = list(subtype = "historical")), "-50d72f51")
   expect_identical(cacheArgumentsHash(c(readTau, convertTau),
-                                               args = list(subtype = "historical")), "-50d72f51")
+                                      args = list(subtype = "historical")), "-50d72f51")
   # nonexisting arguments will be ignored if ... is missing
   expect_identical(cacheArgumentsHash(readTau, args = list(subtype = "historical", notthere = 42)),
                    "-50d72f51")
@@ -169,8 +169,8 @@ test_that("terra objects can be cached", {
     return(list(x = a, class = "SpatRaster"))
   }
   globalassign("readMultiSource")
-  expect_error(readSource("MultiSource"),
-               "file-based and in-memory parts in the same terra object can currently not be cached")
+  expect_warning(readSource("MultiSource"),
+                 "file-based and in-memory parts in the same terra object can currently not be cached")
 
 
   downloadSpatVector <- function() {