Nothing
## Various internal utility functions for trackObjs
## Design:
##
## There is a trackingEnv variable in the tracked
## environment (e.g., .GlobalEnv)
##
## Tracked vars are active bindings, whose function refers to their
## name and trackingEnv
##
## The trackingEnv has several pieces of metadata:
## * .trackingSummary
## * .trackingFileMap (contains all objects)
## * .trackingUnsaved (contains names of unsaved objects, only used if writeToDisk==FALSE)
## * .trackOptions (list(writeToDisk=TRUE/FALSE, cache=TRUE/FALSE)) (default TRUE/TRUE)
## * .trackingDir (absolute path -- don't depend on getwd() -- can be changed
## The first two are stored on disk, and written back out whenever
## they are changed.
## .trackingUnsaved is only stored in memory.
## When the database is initially read, .trackingFileMap and .trackingSummary
## might be created. Note that object names are stored in RData files,
## so we can recreate these objects if they are missing, and check
## consistency when we read them.
##
## Functions: ( * = to be written)
## track.start(dir=trackingDir)
## track.dir()
## track.stop()
## track(var) track(var <- value) track(list=...) track(all=TRUE)
## track.status(): return a list of track env, track dir, and tracked, untracked, and untrackable vars
## untrack(var) untrack(list=) untrack(all=TRUE)
## track.remove(var) track.remove(list=) track.remove(all=TRUE) (call this track.remove() ?)
## track.summary()
##
## tracked(): return all tracked variables
## untracked(): return all untracked, but trackable variables
## untrackable(): return all untrackable variables
## track.unsaved(): return all tracked but unsaved variables
## track.orphaned(): return variables that exist in the tracking dir, but have no binding
## track.masked(): return variables that exist in the tracking dir, but have an ordinary binding
##
## track.flush(var, list, all): write unsaved variables to disk, and remove from memory
## track.save(var, list, all, book): write unsaved variables to disk
## track.forget(var, list, all): delete cached versions without saving to file
## track.rescan(): reload info from disk (forget all cached vars, might remove some no-longer existing tracked vars)
## track.rebuild(dir=trackingDir)
##
## Don't need to use delayedAssign if use makeActiveBinding
## vars that have a binding, and no corresponding var in trackingEnv
## means the var must be out on disk. However, can still use
## the same structure as a ddp from g.data().
##
## database of object data is stored in .trackingSummary
## contains the following columns:
## name
## class
## mode
## extent
## length
## size
## time: modified
## time: created
## time: accessed
## ES: sessions alive
## SA: num accesses this session
## SW: num writes this session
## PA: total accesses before this session
## PW: total writes before this session
##
## Also need to have mapping of object names -> file names:
## store this in .trackingFileMap.
## Any names that contain upper case letters or don't conform
## to starting with alphanum and then continuing with alphanum . _
## are given a filename like .XXXX where XXXX is a number.
##
## When reconstructing trackingSummary, use file.info() to get file
## creation, modification and last access times.
##
## Rules for names of RData files:
## 'simple' names satisfy the following conditions:
## * contain lowercase letters, digits, '.', "_"
## * start with a lowercase letter
## * are 55 characters or less
## * are not one of 'con', 'prn', 'aux', 'nul', 'com1' .. 'com9', 'lpt1' .. 'lpt9'
## * when an object has a filename that does not begin with a '_',
## the filename and the object name must be simple and identical
## * objects that do not have a simple name must be stored in
## files with names beginning with a '_'
env.is.tracked <- function(pos=1, envir=as.environment(pos)) {
# .trackingEnv could be present and NULL for a non-tracked environment
env <- mget(".trackingEnv", ifnotfound=list(NULL), envir=envir)[[1]]
return(!is.null(env)
&& exists(".trackingPid", envir=env, inherits=FALSE)
&& identical(get(".trackingPid", envir=env, inherits=FALSE), Sys.getpid()))
}
getDataDir <- function(trackingDir) {
## If we wanted to store saved RData files in a subdirectory called 'data',
## we would use this here:
## return(file.path(dir, "data"))
trackingDir
}
tracked.envs <- function(envirs=search()) {
## returns environment names, not environments!
i <- sapply(envirs, function(envir) env.is.tracked(envir=as.environment(envir)))
envirs[i]
}
# Create or update a row for the summary data frame
summaryRow <- function(name, opt, sumRow=NULL, obj=NULL, file=NULL, change=FALSE, times=NULL, accessed=TRUE) {
if (opt$use.fake.Sys.time)
tt <- fake.Sys.time()
else
tt <- Sys.time()
new <- FALSE
if (is.null(sumRow)) {
new <- TRUE
sumRow <- data.frame(row.names=name, class="", mode="", extent="",
length=length(obj), size=as.double(object.size(obj)),
modified=tt, created=tt, accessed=tt,
A=as.integer(1), ES=as.integer(1), SA=as.integer(0),
SW=as.integer(0), PA=as.integer(0), PW=as.integer(0),
cache=NA, stringsAsFactors=FALSE)
if (!is.null(file) && file.exists(file)
&& !inherits(info <- try(file.info(file), silent=TRUE), "try-error")) {
if (length(info$mtime)==1 && !is.na(info$mtime))
sumRow$modified <- info$mtime
if (length(info$ctime)==1 && !is.na(info$ctime))
sumRow$created <- info$ctime
if (length(info$atime)==1 && !is.na(info$atime))
sumRow$accessed <- info$atime
}
}
if (change || new) {
cl <- class(obj)
## Neither the first or last element of the returned value of 'class' is
## clearly the most useful class to note, so include all classes as a comma
## separated string.
## E.g., class of an object returned by 'glm()': "glm" "lm"
## while class of an object returned by Sys.time(): "POSIXt" "POSIXct"
sumRow$class <- if (length(cl)==0) "?" else paste(cl, collapse=",")
sumRow$mode <- mode(obj)
if (new || (change && (is.na(sumRow$cache) || ! (sumRow$cache %in% c("fixedyes", "fixedno"))))) {
sumRow$cache <- factor(ifelse( is.element(name, opt$alwaysCache)
|| any(is.element(cl, opt$alwaysCacheClass)),
"yes", "no"),
levels=c("fixedno", "no", "yes", "fixedyes"))
}
l <- try(length(obj), silent=TRUE)
if (inherits(l, "try-error"))
sumRow$length <- NA
else
sumRow$length <- as.integer(l)
d <- try(dim(obj), silent=TRUE)
if (inherits(d, "try-error"))
sumRow$extent <- "(error)"
else if (is.numeric(d))
sumRow$extent <- paste("[", paste(d, collapse="x"), "]", sep="")
else
sumRow$extent <- paste("[", format(sumRow$length), "]", sep="")
if (is.list(obj))
sumRow$extent <- paste("[", sumRow$extent, "]", sep="")
sumRow$size <- object.size(obj)
if (accessed)
sumRow$modified <- tt
sumRow$SW <- sumRow$SW + as.integer(1)
} else if (accessed) {
sumRow$accessed <- tt
sumRow$SA <- sumRow$SA + as.integer(1)
}
if (!is.null(times)) {
sumRow$modified <- times$mtime
sumRow$created <- times$ctime
sumRow$accessed <- times$atime
}
return(sumRow)
}
isReservedName <- function(objName)
## ".trackingEnv" is a reserved name to allow for storing the
## tracking env as an object in the tracked environment instead
## of an attribute on the tracked environment.
return((regexpr("[\n\r]", objName) > 0)
| is.element(objName, c(".trackingEnv", ".trackingDir", ".trackingFileMap",
".trackingUnsaved", ".trackingSummary",
".trackingSummaryChanged", ".trackingOptions",
".trackingPid", ".trackingCreated", ".trackingCacheMark",
".trackAuto", ".trackingFinished", ".trackingModTime")))
objIsTracked <- function(objNames, envir, trackingEnv, all.objs=ls(envir=envir, all.names=TRUE)) {
if (length(objNames)==0)
return(logical(0))
fileMap <- getFileMapObj(trackingEnv)
return(sapply(objNames, function(objName) {
## an object is already tracked if the following 2 conditions are met:
## - it exists as an activing binding in envir
## - there is an entry in the fileMap in the trackingEnv
## Don't use exists() because it gets the object
## if (!exists(objName, envir=envir, inherits=FALSE))
if (!is.element(objName, all.objs))
return(FALSE)
if (!bindingIsActive(objName, envir))
return(FALSE)
if (!is.element(objName, names(fileMap)))
return(FALSE)
return(TRUE)
}))
}
getTrackingDir <- function(trackingEnv) {
dir <- NULL
## avoid partial name matching for attributes...
dir <- mget(".trackingDir", ifnotfound=list(NULL), envir=trackingEnv)[[1]]
if (is.null(dir))
stop("trackingEnv ", envname(trackingEnv), " has no '.trackingDir' variable")
if (!is.character(dir) || length(dir)!=1)
stop("variable '.trackingDir' in trackingEnv ", envname(trackingEnv),
" must be a length one character vector")
return(dir)
}
setTrackingEnv <- function(trackedEnv, trackingEnv, readonly=FALSE) {
## When trackingEnv=NULL, this function should remove the tracking env
## if it can, otherwise set it to NULL.
if (is.null(trackingEnv) && !environmentIsLocked(trackedEnv)) {
if (exists(".trackingEnv", envir=trackedEnv, inherits=FALSE))
remove(list=".trackingEnv", envir=trackedEnv)
} else {
assign(".trackingEnv", trackingEnv, envir=trackedEnv)
}
invisible(NULL)
}
getTrackingEnv <- function(trackedEnv, stop.on.not.tracked = TRUE) {
env <- mget(".trackingEnv", ifnotfound=list(NULL), envir=trackedEnv)[[1]]
if (is.null(env))
if (stop.on.not.tracked)
stop("env ", envname(trackedEnv), " is not tracked (has no '.trackingEnv' variable)")
else
return(NULL)
if (!is.environment(env))
stop("variable '.trackingEnv' in env ", envname(trackedEnv),
" is not an environment")
return(env)
}
getFileMapObj <- function(trackingEnv) {
fileMap <- mget(".trackingFileMap", envir=trackingEnv, ifnotfound=list(NULL))[[1]]
if (is.null(fileMap) || !is.character(fileMap))
stop("no usable .trackingFileMap object in tracking env ", envname(trackingEnv), " - recommend using track.rebuild()")
return(fileMap)
}
writeFileMapFile <- function(fileMap, trackingEnv, dataDir, assignObj=TRUE) {
if (assignObj && inherits(try(assign(".trackingFileMap", fileMap, envir=trackingEnv), silent=TRUE), "try-error"))
warning("failed to assign '.trackingFileMap' in ", envname(trackingEnv))
if (length(fileMap)) {
i <- order(names(fileMap))
fileData <- paste(fileMap[i], ":", names(fileMap)[i], sep="")
} else {
fileData <- character(0)
}
## open in binary mode so that we use just "\n" as a separator
open.res <- (con <- file(file.path(dataDir, "filemap.txt"), open="wb"))
if (inherits(open.res, "try-error")) {
warning("failed to open ", file.path(dataDir, "filemap.txt"), " for writing: if this message appears repeatedly try to fix problem, then do 'track.resave()'")
return(FALSE)
}
on.exit(close(con))
save.res <- try(writeLines(text=fileData, con=con, sep="\n"), silent=TRUE)
if (inherits(save.res, "try-error")) {
warning("failed to save filemap.txt: if this message appears repeatedly try to fix problem, then do 'track.resave()'")
return(FALSE)
}
return(TRUE)
}
readFileMapFile <- function(trackingEnv, dataDir, assignObj) {
## open in binary mode so that we use just "\n" as a separator
open.res <- (con <- file(file.path(dataDir, "filemap.txt"), open="rb"))
if (inherits(open.res, "try-error"))
stop("failed to open \"", file.path(dataDir, "filemap.txt"), "\" for reading: try using track.rebuild()")
on.exit(close(con))
fileData <- try(readLines(con=con, n=-1), silent=TRUE)
if (inherits(fileData, "try-error"))
stop("failed to read file map data from \"", file.path(dataDir, "filemap.txt"), "\": try using track.rebuild()")
## Remove Windows line termination
fileData <- gsub("\r", "", fileData)
i <- regexpr(":", fileData, fixed=TRUE)
if (any(i < 1))
stop("file map contains invalid data (need a ':' in each line): \"", file.path(dataDir, "filemap.txt"), "\": try using track.rebuild()")
fileMap <- substring(fileData, 1, i-1)
names(fileMap) <- substring(fileData, i+1)
if (assignObj && inherits(try(assign(".trackingFileMap", fileMap, envir=trackingEnv), silent=TRUE), "try-error"))
warning("failed to assign '.trackingFileMap' in ", envname(trackingEnv))
return(fileMap)
}
getObjSummary <- function(trackingEnv, opt, stop.if.not.found=TRUE, fromWhere=paste('tracking env ', envname(trackingEnv))) {
objSummary <- mget(".trackingSummary", envir=trackingEnv, ifnotfound=list(NULL))[[1]]
problem <- NULL
if (is.null(objSummary))
problem <- paste("no .trackingSummary object ", fromWhere,
" - recommend using track.rebuild()", sep='')
else if (!is.data.frame(objSummary))
problem <- paste(".trackingSummary object found in ", fromWhere,
" but is not a data frame - recommend using track.rebuild()", sep='')
if (!is.null(problem))
if (stop.if.not.found)
stop(problem)
else
return(structure(problem, class='try-error'))
## The 'cache' column was added in version 1.03.
## If we read a .trackingSummary without it, just add it.
if (!is.element("cache", names(objSummary)))
objSummary$cache <- factor(rep(NA, nrow(objSummary)), levels=c("fixedno", "no", "yes", "fixedyes"))
i <- is.na(objSummary$cache)
objSummaryChanged <- FALSE
## If there are any NA values in 'cache', set them based on name and class.
if (any(i)) {
j <- is.element(rownames(objSummary)[i], opt$alwaysCache)
if (any(j))
objSummary[which(i)[j], "cache"] <- "yes"
i <- is.na(objSummary$cache)
if (any(i) & length(opt$alwaysCacheClasses)) {
j <- sapply(strsplit(objSummary$class[i], ","), is.element, opt$alwaysCacheClasses)
if (any(j))
objSummary[which(i)[j], "cache"] <- "yes"
}
i <- is.na(objSummary$cache)
if (any(i))
objSummary[i, "cache"] <- "no"
objSummaryChanged <- TRUE
}
if (objSummaryChanged) {
assign(".trackingSummary", objSummary, envir=trackingEnv)
assign(".trackingSummaryChanged", TRUE, envir=trackingEnv)
}
return(objSummary)
}
getUnsavedObj <- function(trackingEnv, notfound=character(0))
mget(".trackingUnsaved", envir=trackingEnv, ifnotfound=list(notfound))[[1]]
envname <- function(envir) {
# Produce a 1-line name for the environment.
# Use the name it has on the search() list, if possible.
# This is simpler now that R has the environmentName() function
n <- environmentName(envir)
if (n!="") {
return(paste("<env ", n, ">", sep=""))
}
return(capture.output(print(envir))[1])
}
notyetdone <- function(msg) cat("Not yet done: ", msg, "\n", sep="")
isSimpleName <- function(objName) {
return(nchar(objName)<=55
&& regexpr("^[[:lower:]][._[:digit:][:lower:]]*$", objName, perl=TRUE)==1
&& regexpr("^(prn|aux|con|nul|com[1-9]|lpt[1-9])(\\.|$)", objName)<0)
}
makeObjFileName <- function(objName, fileNames) {
## check if we can use objName as a filename
if (isSimpleName(objName))
return(objName)
## fileNames is a list of vectors of file names that are already used.
## Generate a filename of the form _NNN (NNN is a number without a leading zero)
## work out what numbers have been used
if (is.list(fileNames))
used <- unlist(use.names=FALSE, lapply(fileNames, function(x) as.numeric(substring(grep("^_[1-9][0-9]*$", x, value=TRUE), 2))))
else
used <- as.numeric(substring(grep("^_[1-9][0-9]*$", fileNames, value=TRUE), 2))
used <- unique(used)
used <- sort(c(0, used, length(used)+2))
## find the first gap
i <- used[c(diff(used)!=1, TRUE)][1] + 1
if (is.element(i, used))
stop("algorithm failure!")
file <- paste("_", i, sep="")
return(file)
}
setTrackedVar <- function(objName, value, trackingEnv, opt=track.options(trackingEnv=trackingEnv), times=NULL, file=NULL, doAssign=TRUE) {
## 'file' should be without path or suffix
if (opt$readonly)
stop("variable '", objName, "' cannot be changed -- it is in a readonly tracking environment")
## Set the tracked var, and write it to disk if required
if (opt$debug)
cat("setting tracked var '", objName, "' in ", envname(trackingEnv), "\n", sep="")
## Need to assign it in the tracking env, because save() requires
## an object in an env. Maybe we could skip this step when cache=FALSE,
## but then we'd need to try to find it in its original location (if any).
## No longer true: could remove doAssign arg -- in one use case, the var
## is already in the env, so don't need the assign.
##
## Robustness: what to do if the assign fails?
if (doAssign)
assign(objName, value, envir=trackingEnv)
## Find the directory where we are saving, and create subdirs if necessary
dir <- getTrackingDir(trackingEnv)
for (d in unique(c(dir, getDataDir(dir))))
if (!dir.exists(d))
dir.create(d)
## Work out the name of the file to use for this var
if (is.null(file)) {
fileMap <- getFileMapObj(trackingEnv)
fileMapChanged <- FALSE
isNew <- FALSE
if (is.na(file <- fileMap[match(objName, names(fileMap))])) {
file <- makeObjFileName(objName, fileMap)
fileMap[objName] <- file
fileMapChanged <- TRUE
isNew <- TRUE
}
if (fileMapChanged) {
## always write a changed file map back out to disk
writeFileMapFile(fileMap, trackingEnv=trackingEnv, dataDir=getDataDir(dir))
}
}
fullFile <- NULL
if (opt$writeToDisk && !is.element("eotPurge", opt$cachePolicy)) {
## the value of 'file' is the base of the filename -- work out the full pathname
fullFile <- file.path(getDataDir(dir), paste(file, opt$RDataSuffix, sep="."))
if (opt$debug)
cat("saving '", objName, "' to file ", fullFile, "\n", sep="")
save.res <- try(save(list=objName, file=fullFile, envir=trackingEnv,
compress=opt$compress, compression_level=opt$compression_level), silent=TRUE)
if (!inherits(save.res, "try-error")) {
if (opt$debug >= 2)
cat('setTrackedVar: removing', paste(objName, collapse=', '), 'from trackingEnv\n')
if (!opt$cache && !is.element(objName, opt$alwaysCache))
remove(list=objName, envir=trackingEnv)
unsaved <- getUnsavedObj(trackingEnv)
if (length(unsaved) && is.element(objName, unsaved))
if (length(unsaved)>1)
assign(".trackingUnsaved", setdiff(unsaved, objName), envir=trackingEnv)
else
remove(".trackingUnsaved", envir=trackingEnv)
} else {
stop("failed to save obj '", objName, "' in file '", fullFile,
"' (", as.character(save.res), ") - '", objName,
"' is currently in env ", envname(trackingEnv), " but is not saved to disk",
" (suggestion: fix disk problems then do track.save())")
}
} else {
## mark the object as unsaved
unsaved <- getUnsavedObj(trackingEnv)
if (!is.element(objName, unsaved))
assign(".trackingUnsaved", sort(c(objName, unsaved)), envir=trackingEnv)
}
if (opt$maintainSummary) {
objSummary <- getObjSummary(trackingEnv, opt=opt)
if (!is.data.frame(objSummary)) {
warning(".trackingSummary in ", envname(trackingEnv), " is not a data.frame: not updating summary; run track.rebuild()")
} else {
if (is.element(objName, rownames(objSummary))) {
sumRow <- summaryRow(objName, opt=opt, sumRow=objSummary[objName, , drop=FALSE], obj=value,
file=NULL, change=TRUE, times=times)
} else {
## Don't have a row in the summary for this object.
if (!isNew) {
if (is.null(fullFile))
fullFile <- file.path(getDataDir(dir), paste(file, opt$RDataSuffix, sep="."))
if (!file.exists(fullFile)) {
## This can happen when an object is created via track.ff() -- want to avoid noise
## so don't issue this warning.
## warning("file '", fullFile, "' does not yet exist (for obj '", objName, "') - will create it when needed")
fullFile <- NULL
}
}
## summaryRow will get times from the file if we supply it -- only
## want to do this in the exceptional case that this object was not
## new, but didn't have a summary row.
sumRow <- summaryRow(objName, opt=opt, obj=value, file=if (!isNew) fullFile else NULL,
change=TRUE, times=times)
## If this is not a new object, record that the times are not accurrate.
if (!isNew)
sumRow$A <- 0
}
objSummary[objName, ] <- sumRow
assign.res <- try(assign(".trackingSummary", objSummary, envir=trackingEnv), silent=TRUE)
if (inherits(assign.res, "try-error")) {
warning("unable to assign .trackingSummary back to tracking env on ",
envname(trackingEnv), ": ", assign.res)
} else {
assign(".trackingSummaryChanged", TRUE, envir=trackingEnv)
if (opt$writeToDisk && !is.element("eotPurge", opt$cachePolicy)) {
save.res <- saveObjSummary(trackingEnv, opt=opt, dataDir=getDataDir(dir))
if (inherits(save.res, "try-error"))
warning("unable to save .trackingSummary to ", dir)
else
assign(".trackingSummaryChanged", FALSE, envir=trackingEnv)
}
}
}
}
## return the value of the variable
return(invisible(value))
}
getTrackedVar <- function(objName, trackingEnv, opt=track.options(trackingEnv=trackingEnv)) {
## Get the tracked var if it exists, or load it from disk if it doesn't
## Special case when getting variable '.Last' -- don't want to stop with
## an error because that can cause an infinite loop, so if can't retrieve
## that var, then print a warning and return NULL
if (!is.character(objName) || length(objName)!=1)
stop("objName must be a length one character vector")
if (exists(objName, envir=trackingEnv, inherits=FALSE)) {
if (opt$debug)
cat("getTrackedVar: '", objName, "' from cached obj in ", envname(trackingEnv), "\n", sep="")
value <- get(objName, envir=trackingEnv, inherits=FALSE)
dir <- NULL
fullFile <- NULL
} else {
if (opt$debug)
cat("getting tracked var '", objName, "' from file\n", sep="")
fileMap <- getFileMapObj(trackingEnv)
file <- fileMap[match(objName, names(fileMap))]
if (is.na(file))
if (objName=='.Last') {
warning("'", objName, "' does not exist in tracking env ", envname(trackingEnv),
" (has no entry in .trackingFileMap); returning NULL")
return(NULL)
} else {
stop("'", objName, "' does not exist in tracking env ", envname(trackingEnv),
" (has no entry in .trackingFileMap)")
}
dir <- getTrackingDir(trackingEnv)
fullFile <- file.path(getDataDir(dir), paste(file, opt$RDataSuffix, sep="."))
if (!file.exists(fullFile)) {
if (objName=='.Last') {
warning("file '", fullFile, "' does not exist (for obj '", objName, "'); returning NULL")
return(NULL)
} else {
stop("file '", fullFile, "' does not exist (for obj '", objName, "')")
}
}
tmpenv <- new.env(parent=emptyenv())
## hopefully, no actual copies are made while loading the object into tmpenv,
## then copying it to envir and returning it as the value of this function
load.res <- load(fullFile, envir=tmpenv)
## call the load callback
if (length(load.res)<1 || load.res[1] != objName)
stop("file '", fullFile, "' did not contain obj '", objName, "' as its first object")
if (length(load.res)>1)
warning("ignoring ", length(load.res)-1, " other objects in file '", fullFile, "'")
value <- get(objName, envir=tmpenv, inherits=FALSE)
if (opt$cache)
assign(objName, value, envir=trackingEnv)
## Call the load hooks based on class
if (is.element('ff', class(value))) {
fff <- attr(attr(value, 'physical'), 'filename')
ffd <- dirname(fff)
ffd2 <- dirname(ffd)
fff1 <- basename(fff)
fff2 <- basename(ffd)
## If the ff filename looks like .../ff/<varfile>.ff, and
## the file <trackingDir>/ff/<varfile>.ff exists, then
## switch to using that file.
if (fff2 == 'ff' && fff1 == paste(file, '.ff', sep='')) {
fffr <- file.path(dir, 'ff', fff1)
if (file.exists(fffr) && fffr != fff) {
attr(attr(value, 'physical'), 'orig.filename') <- fff
attr(attr(value, 'physical'), 'filename') <- fffr
}
}
}
}
## Update the object table (object characteristics, accesses)
if (opt$maintainSummary && opt$recordAccesses) {
objSummary <- getObjSummary(trackingEnv, opt=opt)
if (!is.data.frame(objSummary)) {
warning(".trackingSummary in ", envname(trackingEnv), " is not a data.frame: not updating objSummary; run track.rebuild()")
} else {
if (is.element(objName, rownames(objSummary))) {
sumRow <- summaryRow(objName, opt=opt, sumRow=objSummary[objName, , drop=FALSE], obj=value,
file=NULL, change=FALSE, times=NULL)
} else {
if (is.null(fullFile)) {
fileMap <- getFileMapObj(trackingEnv)
file <- fileMap[match(objName, names(fileMap))]
if (is.na(file)) {
warning("'", objName, "' does not exist in tracking env ", envname(trackingEnv),
" (has no entry in .trackingFileMap)")
} else {
dir <- getTrackingDir(trackingEnv)
fullFile <- file.path(getDataDir(dir), paste(file, opt$RDataSuffix, sep="."))
if (!file.exists(fullFile)) {
warning("file '", fullFile, "' does not exist (for obj '", objName, "')")
fullFile <- NULL
}
}
}
sumRow <- summaryRow(objName, opt=opt, obj=value, file=fullFile, change=FALSE, times=NULL)
## Since this is not a new object, but this we are creating a new summary
## row for it, record that the times are not accurrate
sumRow$A <- 0
}
objSummary[objName, ] <- sumRow
assign.res <- try(assign(".trackingSummary", objSummary, envir=trackingEnv))
if (inherits(assign.res, "try-error")) {
warning("unable to assign .trackingSummary back to tracking env on ", envname(trackingEnv))
} else {
## only makes sense to save() .trackingSummary if we were able to assign it
assign(".trackingSummaryChanged", TRUE, envir=trackingEnv)
if (opt$alwaysSaveSummary && !is.element("eotPurge", opt$cachePolicy)) {
if (is.null(dir))
dir <- getTrackingDir(trackingEnv)
save.res <- saveObjSummary(trackingEnv, opt=opt, dataDir=getDataDir(dir))
if (inherits(save.res, "try-error"))
warning("unable to save .trackingSummary to ", dir, ": ", save.res)
else
assign(".trackingSummaryChanged", FALSE, envir=trackingEnv)
}
}
}
}
return(value)
}
quietNormalizePath <- function(path, winslash='/', mustWork=FALSE) {
if (isTRUE(mustWork))
return(normalizePath(path, winslash='/', mustWork=mustWork))
newPath <- try(normalizePath(path, winslash='/', mustWork=mustWork), silent=TRUE)
if (inherits(newPath, 'try-error'))
newPath <- path
allComp <- strsplit(gsub('[/\\\\]', winslash, newPath), winslash)[[1]]
newComp <- allComp
j <- 2
for (i in seq(2, len=length(allComp)-1)) {
if (allComp[i]=='.') {
newComp <- newComp[-j]
} else if (allComp[i]=='..') {
newComp <- newComp[-c(j, j-1)]
j <- max(1, j-1)
} else {
j <- j+1
}
}
paste0(allComp, collapse=winslash)
}
find.relative.path <- function(path, file) {
## Find a way to express file as a relative path to path
path <- quietNormalizePath(path, winslash='/')
file <- quietNormalizePath(file, winslash='/')
if (.Platform$OS.type == "windows") {
path <- gsub("\\", "/", path, fixed=TRUE)
file <- gsub("\\", "/", file, fixed=TRUE)
}
path.comp <- strsplit(path, split="/", fixed=TRUE)[[1]]
file.comp <- strsplit(file, split="/", fixed=TRUE)[[1]]
## Windows doesn't normalize drive letters to all caps,
## which can result in a mismatch
if (.Platform$OS.type == "windows") {
if (length(grep("^[a-zA-Z]:$", path.comp[1])))
path.comp[1] <- casefold(path.comp[1], upper=FALSE)
if (length(grep("^[a-zA-Z]:$", file.comp[1])))
file.comp[1] <- casefold(file.comp[1], upper=FALSE)
}
i <- 1
while (i <= min(length(path.comp), length(file.comp))
&& path.comp[i] == file.comp[i])
i <- i+1
if (i>1) {
file.rel <- file.comp[seq(to=length(file.comp), len=length(file.comp)-(i-1))]
## path.use <- path.comp[seq(from=1, len=i-1)]
if (i <= length(path.comp))
file.rel <- c(rep("..", length(path.comp)-(i-1)), file.rel)
if (length(file.rel)==0)
file.rel <- "."
return(paste(file.rel, collapse=.Platform$file.sep))
} else {
return(paste(file.comp, collapse=.Platform$file.sep))
}
}
exclude.from.tracking <- function(objName, objClasses=NULL, opt) {
exclude <- rep(FALSE, length(objName))
if (length(objName) > 1 && length(objClasses) && (!is.list(objClasses) || length(objClasses)!=length(objName)))
stop("objClasses must be list the same length as objName when objName is a vector")
if (length(objName)==1 && !is.list(objClasses) && length(objClasses))
objClasses <- list(objClasses)
if (length(opt$autoTrackExcludeClass) && length(objClasses))
exclude <- sapply(objClasses, is.element, opt$autoTrackExcludeClass)
for (re in opt$autoTrackExcludePattern)
exclude <- exclude | regexpr(re, objName) >= 1
exclude
}
dir.exists <- function(dir) {
## Need this because sometimes directories on network drives
## under windows aren't seen by file.exists(). This can be
## true even if they have files in them. In such cases the
## tests for existence for the files in them seem to work fine.
## However, file.access() seems more reliable, so try both.
file.exists(dir) || (file.access(dir, mode=0)==0)
}
## Use these to override Sys.time() for testing purposes (to get Sys.time() to return
## reproducible, steadily incrementing "times". This just counts 1 second forward
## from a fixed starting time each time it is called.
## Only use these for testing because they introduce overhead for Sys.time().
fake.Sys.time <- function() {
fake.Sys.time.counter <- get("fake.Sys.time.counter", envir=fake.Sys.time.env)
assign("fake.Sys.time.counter", fake.Sys.time.counter + 1, envir=fake.Sys.time.env)
return(fake.Sys.time.counter)
}
fake.Sys.time.env <- as.environment(list(fake.Sys.time.counter=as.POSIXct("2001/01/01 09:00:00", tz="GMT")+1))
set.fake.Sys.time <- function(offset=1) {
assign("fake.Sys.time.counter", as.POSIXct("2001/01/01 09:00:00", tz="GMT")+offset, envir=fake.Sys.time.env)
return(invisible(get("fake.Sys.time.counter", envir=fake.Sys.time.env)))
}
saveObjSummary <- function(trackingEnv,
opt=track.options(trackingEnv=trackingEnv),
dataDir=getDataDir(getTrackingDir(trackingEnv)),
envir=trackingEnv) {
## Save the object summary out to the file system
## envir is the actual environment where the .trackingSummary object lives; it is
## usually the same as trackingEnv
file <- file.path(dataDir, paste(".trackingSummary", opt$RDataSuffix, sep="."))
if (!exists(".trackingSummary", envir=envir, inherits=FALSE))
return(structure('saveObjSummary: .trackingSummary does not exist', class='try-error'))
objSummary <- get(".trackingSummary", envir=envir, inherits=FALSE)
## pad just serves to make the saved tracking summary have different size on disk
## which helps with noticing when a tracking summary has changed, because if
## it changes within the same second, it will still have the same mod time.
## However, most of the time, we're not concerned with second-level accuracy.
if (opt$debug) {
pad <- attr(objSummary, 'pad')
if (is.null(pad))
pad <- raw(1)
length(pad) <- (length(pad) + 17) %% 101
attr(objSummary, 'pad') <- pad
assign(".trackingSummary", objSummary, envir=envir)
}
save.res <- try(save(list=".trackingSummary", file=file, envir=envir, compress=FALSE), silent=TRUE)
if (inherits(save.res, 'try-error'))
attr(save.res, 'file') <- file
if (identical(envir, trackingEnv)) {
modTime <- file.info(file)
if (!is.na(modTime$mtime))
try(assign('.trackingModTime', modTime[,c('size','mtime')], envir=trackingEnv), silent=TRUE)
}
save.res
}
loadObjSummary <- function(trackingEnv,
opt=track.options(trackingEnv=trackingEnv),
dataDir=getDataDir(getTrackingDir(trackingEnv)),
stop.on.not.exists=FALSE) {
# Load the object summary from the file system
file <- file.path(dataDir, paste(".trackingSummary", opt$RDataSuffix, sep="."))
tmpenv <- new.env(parent=emptyenv())
if (!file.exists(file))
if (stop.on.not.exists)
stop("file storing object summary doesn't exist: ", file)
else
return(NULL)
load.res <- try(load(file, envir=tmpenv), silent=TRUE)
if (inherits(load.res, "try-error"))
stop(file, " cannot be loaded -- for recovery see ?track.rebuild (",
as.character(load.res), ")")
if (length(load.res)!=1 || load.res != ".trackingSummary")
stop(file, " does not contain just '.trackingSummary' -- for recovery see ?track.rebuild")
modTime <- file.info(file)
if (!is.na(modTime$mtime))
try(assign('.trackingModTime', modTime[,c('size','mtime')], envir=trackingEnv), silent=TRUE)
## .trackingSummary has to exist in tmpenv because we just loaded it
getObjSummary(tmpenv, opt=opt, fromWhere=file)
}
# used to store data around failures in an attempt to avoid infinite loops
track.private.env <- as.environment(list(standard.Last=FALSE, last.failed.get=character(100), last.failed.time=rep(Sys.time(), 100), last.failed.i=1))
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.