R/cache-internals.R

In reproducible: Enhance Reproducibility of R Code

.CacheVerboseFn1 <- function(preDigest, fnDetails,
                             startHashTime, modifiedDots, quick,
                             verbose = getOption("reproducible.verbose", 1),
                             verboseLevel = 1) {
  preDigestUnlist <- .unlistToCharacter(preDigest, 4)
  endHashTime <- Sys.time()
  verboseDF <- data.frame(
    functionName = fnDetails$functionName,
    component = "Hashing",
    elapsedTime = as.numeric(difftime(endHashTime, startHashTime, units = "secs")),
    units = "secs",
    stringsAsFactors = FALSE
  )

  hashObjectSize <- unlist(lapply(modifiedDots, function(x) {
    if (getOption("reproducible.objSize", TRUE)) unname(attr(objSize(x), "objSize")) else NA
  }))

  lengths <- unlist(lapply(preDigestUnlist, function(x) length(unlist(x))))
  hashDetails <- data.frame(
    objectNames = rep(names(preDigestUnlist), lengths),
    hashElements = names(unlist(preDigestUnlist)),
    hash = unname(unlist(preDigestUnlist)),
    stringsAsFactors = FALSE
  )
  preDigestUnlistNames <- unlist(lapply(
    strsplit(names(unlist(preDigestUnlist)), split = "\\."), # nolint
    function(x) paste0(tail(x, 2), collapse = ".")
  ))
  hashObjectSizeNames <- unlist(lapply(
    strsplit(names(hashObjectSize), split = "\\$"),
    function(x) paste0(tail(x, 2), collapse = ".")
  ))
  hashObjectSizeNames <- gsub("\\.y", replacement = "", hashObjectSizeNames)
  hashObjectSizeNames <- unlist(lapply(
    strsplit(hashObjectSizeNames, split = "\\."),
    function(x) paste0(tail(x, 2), collapse = ".")
  ))
  hashDetails$objSize <- NA
  hashDetails$objSize[preDigestUnlistNames %in% hashObjectSizeNames] <-
    hashObjectSize[hashObjectSizeNames %in% preDigestUnlistNames]

  if (exists("hashDetails", envir = .reproEnv)) {
    .reproEnv$hashDetails <- rbind(.reproEnv$hashDetails, hashDetails)
  } else {
    .reproEnv$hashDetails <- hashDetails
    on.exit(
      {
        assign("hashDetailsAll", .reproEnv$hashDetails, envir = .reproEnv)
        messageDF(.reproEnv$hashDetails, colour = "blue", verbose = verbose, verboseLevel = verboseLevel)
        messageCache("The hashing details are available from .reproEnv$hashDetails",
          verbose = verbose, verboseLevel = verboseLevel
        )
        rm("hashDetails", envir = .reproEnv)
      },
      add = TRUE
    )
  }

  if (exists("verboseTiming", envir = .reproEnv)) {
    verboseDF$functionName <- paste0("  ", verboseDF$functionName)
    .reproEnv$verboseTiming <- rbind(.reproEnv$verboseTiming, verboseDF)
  } else {
    .reproEnv$verboseTiming <- verboseDF
  }
}


.CacheFn1 <- function(FUN, scalls) {
  if (!is(FUN, "function")) {
    # scalls <- sys.calls()
    if (any(startsWith(as.character(scalls), "function_list[[k"))) {
      srch <- search()
      whereRepro <- which(endsWith(srch, "reproducible")) - 1
      if (whereRepro > 1) {
        srchNum <- seq_len(whereRepro)
        for (sr in srchNum) {
          masker <- exists("%>%", srch[sr], inherits = FALSE)
          if (masker) break
        }
      }
      if (masker) {
        stop("It looks like the pipe (%>%) from package:reproducible is masked by ", srch[sr],
          ". Please make sure library(reproducible) is after library(",
          gsub(srch[sr], pattern = "package:", replacement = ""), ")",
          call. = FALSE
        )
      } else {
        stop("Is the %>% from reproducible masked?")
      }
    } else {
      stop(
        "Can't understand the function provided to Cache.\n",
        "Did you write it in the form: ",
        "Cache(function, functionArguments)?"
      )
    }
  } else {
    scalls <- NULL
  }

  scalls
}

.getFromRepo <- function(FUN, isInRepo, fullCacheTableForObj,
                         notOlderThan, lastOne, cachePath, fnDetails,
                         modifiedDots, debugCache, verbose, # sideEffect,
                         quick, # fileFormat = NULL,
                         algo, preDigest, startCacheTime,
                         drv = getDrv(getOption("reproducible.drv", NULL)),
                         conn = getOption("reproducible.conn", NULL), ...) {
  cacheObj <- isInRepo[[.cacheTableHashColName()]][lastOne]

  fromMemoise <- NA
  output <- loadFromCache(cachePath, isInRepo[[.cacheTableHashColName()[lastOne]]],
    fullCacheTableForObj = fullCacheTableForObj,
    # format = fileFormat, loadFun = loadFun,
    .functionName = fnDetails$functionName, preDigest = preDigest, .dotsFromCache = modifiedDots,
    drv = drv, conn = conn,
    verbose = verbose
  )
  # This is protected from multiple-write to SQL collisions
  .addTagsRepo(
    cacheId = isInRepo[[.cacheTableHashColName()]][lastOne],
    cachePath = cachePath, drv = drv, conn = conn
  )
  if (length(debugCache)) {
    if (!is.na(pmatch(debugCache, "complete")) || isTRUE(debugCache)) {
      output <- .debugCache(output, preDigest, ...)
    }
  }

  output <- .setSubAttrInList(output, ".Cache", "newCache", FALSE)
  # attr(output, ".Cache")$newCache <- FALSE
  if (!identical(attr(output, ".Cache")$newCache, FALSE)) stop("attributes are not correct 2")

  if (verbose > 3) {
    endCacheTime <- Sys.time()
    verboseDF <- data.frame(
      functionName = fnDetails$functionName,
      component = "Whole Cache call",
      elapsedTime = as.numeric(difftime(endCacheTime, startCacheTime, units = "secs")),
      units = "secs",
      stringsAsFactors = FALSE
    )

    if (exists("verboseTiming", envir = .reproEnv)) {
      .reproEnv$verboseTiming <- rbind(.reproEnv$verboseTiming, verboseDF)
    }
  }

  # If it was a NULL, the cachePath stored it as "NULL" ... return it as NULL
  if (is.character(output)) {
    if (identical(as.character(output), "NULL")) {
      output <- NULL
    }
  }

  return(output)
}