redirect for fingerprint

R/fingerprint.R

@@ -52,11 +52,12 @@ fingerprint <- function(name, details = FALSE, graph = NULL, ...) {
     fingerprintMonitored <- fingerprintCall(setdiff(monitor, names(fingerprintFunctions)))
     # ignore functions mentioned in the ignore list
     fingerprintFunctions <- fingerprintFunctions[setdiff(names(fingerprintFunctions), ignore)]
+
     sources <- substring(dependencies$func[dependencies$type == "read"], 5)
-    if (length(sources) > 0) {
-      sources <- paste0(getConfig("sourcefolder"), "/", robustSort(sources))
-    }
+    sources <- robustSort(sources)
+    sources <- vapply(sources, function(t) getSourceFolder(type = t, subtype = NULL), character(1))
     fingerprintSources <- fingerprintFiles(sources)
+
     fingerprintMappings <- fingerprintFiles(attr(dependencies, "mappings"))
     fingerprint <- c(fingerprintFunctions, fingerprintSources, fingerprintMappings, fingerprintMonitored)
     fingerprint <- fingerprint[robustOrder(basename(names(fingerprint)))]

R/getConfig.R

@@ -40,7 +40,6 @@
 getConfig <- function(option = NULL, raw = FALSE, verbose = TRUE, print = FALSE) { # nolint
   initializeConfig(verbose = verbose)
 
-  # TODO revisit
   allowedOptions <- list(downloadSource = c("debug", "tmpfolder"),
                          readSource = c("debug", "tmpfolder"),
                          calcOutput = c("regionmapping", "extramappings", "debug", "tmpfolder"),

R/getSourceFolder.R

@@ -0,0 +1,23 @@
+#' getSourceFolder
+#'
+#' Return the path to source data files for the given type and subtype. This
+#' applies redirections, see \code{\link{localRedirect}} for more details.
+#'
+#' @param type Dataset name, e.g. "Tau" for \code{\link{readTau}}
+#' @param subtype Subtype of the dataset, e.g. "paper" for \code{\link{readTau}}, NULL is allowed
+#' @return Path to source data files
+#' @author Pascal Sauer
+getSourceFolder <- function(type, subtype) {
+  redirections <- getConfig("redirections")
+  if (type %in% names(redirections)) {
+    sourcefolder <- normalizePath(redirections[[type]], mustWork = TRUE)
+  } else {
+    sourcefolder <- file.path(getConfig("sourcefolder"), make.names(type))
+  }
+
+  if (!is.null(subtype) && file.exists(file.path(sourcefolder, make.names(subtype), "DOWNLOAD.yml"))) {
+    sourcefolder <- file.path(sourcefolder, make.names(subtype))
+  }
+
+  return(sourcefolder)
+}

R/localRedirect.R

@@ -1,3 +1,27 @@
+
+#' localRedirect
+#'
+#' Redirect a given dataset type to a different source folder. The redirection
+#' is local, so it will be reset when the current function call returns. See
+#' example for more details.
+#'
+#' @param type Dataset name, e.g. "Tau" for \code{\link{readTau}}
+#' @param target Path to the new source folder, NULL to remove the redirection
+#' @return Invisibly, a list of all redirections where names are types and
+#' values are the paths these types are redirected to.
+#' @author Pascal Sauer
+#' @examples \dontrun{
+#' f <- function() {
+#'   localRedirect("Tau", "~/TauExperiment")
+#'   # the following call will change directory
+#'   # into ~/TauExperiment instead of <getConfig("sourcefolder")>/Tau
+#'   readSource("Tau")
+#' }
+#' f()
+#' # Tau is only redirected in the local environment of f,
+#' # so it will use the usual source folder here
+#' readSource("Tau")
+#' }
 #' @export
 localRedirect <- function(type, target) {
   if (!is.null(target)) {
@@ -7,5 +31,5 @@ localRedirect <- function(type, target) {
   redirections <- getConfig("redirections")
   redirections[[type]] <- target
   setConfig(redirections = redirections, .local = parent.frame())
-  return(redirections) # TODO invisible
+  return(invisible(redirections))
 }

R/readSource.R

@@ -112,24 +112,9 @@ readSource <- function(type, subtype = NULL, subset = NULL, # nolint: cyclocomp_
     return(xList)
   }
 
-  .getSourceFolder <- function(type, subtype) {
-    redirections <- getConfig("redirections")
-    if (type %in% names(redirections)) {
-      sourcefolder <- normalizePath(redirections[[type]], mustWork = TRUE)
-    } else {
-      sourcefolder <- file.path(getConfig("sourcefolder"), make.names(type))
-    }
-
-    if (!is.null(subtype) && file.exists(file.path(sourcefolder, make.names(subtype), "DOWNLOAD.yml"))) {
-      sourcefolder <- file.path(sourcefolder, make.names(subtype))
-    }
-
-    return(sourcefolder)
-  }
-
   # get data either from cache or by calculating it from source
   .getData <- function(type, subtype, subset, args, prefix) {
-    sourcefolder <- .getSourceFolder(type, subtype)
+    sourcefolder <- getSourceFolder(type, subtype)
 
     xList <- .getFromCache(prefix, type, args, subtype, subset)
     if (!is.null(xList)) {
@@ -227,7 +212,7 @@ readSource <- function(type, subtype = NULL, subset = NULL, # nolint: cyclocomp_
   }
 
   # Check whether source folder exists (ignore subtype for now) and try do download source data if it is missing
-  sourcefolder <- .getSourceFolder(type, subtype = NULL)
+  sourcefolder <- getSourceFolder(type, subtype = NULL)
 
   # if any DOWNLOAD.yml exists use these files as reference,
   # otherwise just check whether the sourcefolder exists

tests/testthat/test-localRedirect.R

@@ -1,5 +1,4 @@
 test_that("localRedirect works", {
-  localConfig(globalenv = T) # TODO
   localConfig(redirections = list())
   withr::local_dir(withr::local_tempdir())
 
@@ -29,6 +28,5 @@ test_that("localRedirect works", {
 
   expect_identical(as.vector(readSource("Example")), 123)
   localRedirect("Example", "Example2")
-  setConfig(ignorecache = TRUE) # TODO fingerprint should be different!
   expect_identical(as.vector(readSource("Example")), 456)
 })