0byt3m1n1
Path:
C:
/
Program Files
/
RStudio
/
resources
/
app
/
R
/
modules
/
[
Home
]
File: SessionDataViewer.R
# # SessionDataViewer.R # # Copyright (C) 2022 by Posit Software, PBC # # Unless you have received this program directly from Posit Software pursuant # to the terms of a commercial license agreement with Posit Software, then # this program is licensed to you under the terms of version 3 of the # GNU Affero General Public License. This program is distributed WITHOUT # ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT, # MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the # AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details. # # # host environment for cached data; this allows us to continue to view data # even if the original object is deleted .rs.setVar("CachedDataEnv", new.env(parent = emptyenv())) # host environment for working data; this allows us to sort/filter/page the # data without recomputing on the original object every time .rs.setVar("WorkingDataEnv", new.env(parent = emptyenv())) .rs.addFunction("subsetData", function(data, maxRows = -1, maxCols = -1) { if (!is.na(maxRows) && maxRows != -1 && nrow(data) > maxRows) data <- head(data, n = maxRows) if (!is.na(maxCols) && maxCols != -1 && ncol(data) > maxCols) data <- data[1:maxCols] data }) .rs.addFunction("formatDataColumn", function(x, start, len, ...) { # extract the visible part of the column col <- x[start:min(NROW(x), start + len)] # if this object has a format method, use it. catch errors # and validate that the format method has given us something 'sane' formatted <- .rs.tryCatch(.rs.formatDataColumnDispatch(col, ...)) if (is.character(formatted) && length(formatted) == length(col)) return(formatted) # otherwise, delegate to internal methods if (is.numeric(col)) .rs.formatDataColumnNumeric(col, ...) else if (is.list(col) && !is.data.frame(col)) .rs.formatDataColumnList(col, ...) else .rs.formatDataColumnDefault(col, ...) }) .rs.addFunction("formatDataColumnDispatch", function(col, ...) { formatter <- NULL for (class in class(col)) { formatter <- utils::getS3method( "format", class = class, optional = TRUE ) if (!is.null(formatter)) break } if (is.null(formatter)) return(NULL) formatted <- formatter(col, trim = TRUE, justify = "none", ...) if (is.character(formatted) && length(formatted) == length(col)) formatted[is.na(col)] <- NA formatted }) .rs.addFunction("formatDataColumnNumeric", function(col, ...) { # show numbers as doubles storage.mode(col) <- "double" # remember which values are NA naVals <- is.na(col) # format all the numeric values; this drops NAs (the na.encode option only # preserves NA for character cols) vals <- format(col, trim = TRUE, justify = "none", ...) # restore NA values if there were any if (any(naVals)) vals[naVals] <- col[naVals] # return formatted values vals }) .rs.addFunction("formatDataColumnList", function(col, ...) { limit <- .rs.nullCoalesce( .rs.readUserPref("data_viewer_max_cell_size"), 50L ) formatted <- as.character(col) na <- is.na(formatted) large <- !na & nchar(formatted) > limit formatted <- substr(formatted, 1, limit) formatted <- paste0(formatted, ifelse(large, " [...]", "")) formatted[na] <- NA_character_ formatted }) .rs.addFunction("formatDataColumnDefault", function(col, ...) { # show everything else as characters as.character(col) }) .rs.addFunction("describeCols", function(x, maxRows = -1, maxCols = -1, maxFactors = 64, totalCols = -1) { # subset the data if requested x <- .rs.subsetData(x, maxRows, maxCols) # get the variable labels, if any--labels may be provided either by this # global attribute or by a 'label' attribute on an individual column (as in # e.g. Hmisc), which takes precedence if both are present colNames <- names(x) colLabels <- attr(x, "variable.labels", exact = TRUE) if (!is.character(colLabels)) colLabels <- character() # we pass totalCols in the rownames col so we can pass this information # along when we retrieve column data, without changing the response format totalCols <- if (totalCols > 0) totalCols else ncol(x) # the first column is always the row names rowNameCol <- list( col_name = .rs.scalar(""), col_type = .rs.scalar("rownames"), col_min = .rs.scalar(0), col_max = .rs.scalar(0), col_search_type = .rs.scalar("none"), col_label = .rs.scalar(""), col_vals = "", col_type_r = .rs.scalar(""), total_cols = .rs.scalar(totalCols)) # if there are no columns, bail out if (length(colNames) == 0) { return(rowNameCol) } # get the attributes for each column colAttrs <- lapply(seq_along(colNames), function(idx) { col_name <- if (idx <= length(colNames)) colNames[idx] else as.character(idx) col_type <- "unknown" col_type_r <- "unknown" col_breaks <- c() col_counts <- c() col_vals <- "" col_search_type <- "" # extract label, if any, or use global label, if any label <- attr(x[[idx]], "label", exact = TRUE) col_label <- if (is.character(label)) { label } else if (idx <= length(colLabels)) { if (!is.null(names(colLabels))) { if (col_name %in% names(colLabels)) colLabels[[col_name]] else "" } else { colLabels[[idx]] } } else { "" } # ensure that the column contains some scalar values we can examine if (length(x[[idx]]) > 0) { val <- x[[idx]][[1]] col_type_r <- typeof(val) if (is.factor(val)) { col_type <- "factor" if (length(levels(val)) > maxFactors) { # if the number of factors exceeds the max, search the column as # though it were a character column col_search_type <- "character" } else { col_search_type <- "factor" col_vals <- levels(val) } } # for histograms, we support only the base R numeric class and its derivatives; # is.numeric can return true for values that can only be manipulated using # packages that are currently loaded (e.g. bit64's integer64) else if (is.numeric(x[[idx]]) && !is.object(x[[idx]])) { # ignore missing and infinite values (i.e. let any filter applied # implicitly remove those values); if that leaves us with nothing, # treat this column as untyped since we can do no meaningful filtering # on it hist_vals <- x[[idx]][is.finite(x[[idx]])] if (length(hist_vals) > 1) { # create histogram for brushing -- suppress warnings as in rare cases # an otherwise benign integer overflow can occurs; see # https://github.com/rstudio/rstudio/issues/3232 h <- suppressWarnings(graphics::hist(hist_vals, plot = FALSE)) col_breaks <- h$breaks col_counts <- h$counts # record column type col_type <- "numeric" col_search_type <- "numeric" } } else if (inherits(x[[idx]], "integer64")) { col_type <- "numeric" col_search_type <- "character" } else if (is.character(val)) { col_type <- "character" col_search_type <- "character" } else if (is.logical(val)) { col_type <- "boolean" col_search_type <- "boolean" } else if (is.data.frame(val)) { col_type <- "data.frame" } else if (is.list(val)) { col_type <- "list" } } list( col_name = .rs.scalar(col_name), col_type = .rs.scalar(col_type), col_breaks = as.character(col_breaks), col_counts = col_counts, col_search_type = .rs.scalar(col_search_type), col_label = .rs.scalar(col_label), col_vals = col_vals, col_type_r = .rs.scalar(col_type_r) ) }) c(list(rowNameCol), colAttrs) }) .rs.addFunction("describeColSlice", function(x, sliceStart = 1, sliceEnd = 1) { totalCols <- ncol(x) if (totalCols == 0) return(NULL) if (sliceEnd > totalCols || sliceEnd < 1) sliceEnd <- totalCols if (sliceStart > totalCols || sliceStart < 1 || sliceStart > sliceEnd) sliceStart <- 1 indices <- sliceStart:sliceEnd colSlice <- x[indices] # Make sure we preserve variable.labels if set. # # The structure of 'variable.labels' is not documented, # but it appears that the expectation is that it's a character # vector of the same length as 'x'. # # The vector can be optionally named (with names matching that of 'x'), # or it can be an unnamed vector -- in which case, the order of labels # needs to match the column order of 'x'. # # https://github.com/rstudio/rstudio/issues/14265 colLabels <- attr(x, "variable.labels", exact = TRUE) if (!is.null(colLabels)) { # Only subset 'variable.labels' if it's not named, since a named # attribute could potentially be in a different order than the # columns of 'x' itself. If 'variable.labels' is named, then all # we require is that it's a super-set of the names of 'x'. if (is.null(names(colLabels))) colLabels <- colLabels[indices] attr(colSlice, "variable.labels") <- colLabels } .rs.describeCols(colSlice, -1, -1, 64, totalCols) }) .rs.addFunction("formatRowNames", function(x, start, len) { # detect whether this is a data.frame that contains # row names, or if the row names are stored compactly if (is.data.frame(x)) { info <- .row_names_info(x, type = 0L) if (is.integer(info) && length(info) > 0 && is.na(info[[1]])) { # the second element indicates the number of rows, and is negative if they're # automatic n <- abs(info[[2]]) range <- seq(from = start, to = min(n, start + len)) return(as.character(range)) } } # otherwise, extract row names and subset as usual rownames <- row.names(x) rownames[start:min(length(rownames), start + len)] }) # wrappers for nrow/ncol which will report the class of object for which we # fail to get dimensions along with the original error .rs.addFunction("nrow", function(x) { rows <- 0 tryCatch({ rows <- NROW(x) }, error = function(e) { stop("Failed to determine rows for object of class '", class(x), "': ", e$message) }) if (is.null(rows)) 0 else rows }) .rs.addFunction("ncol", function(x) { cols <- 0 tryCatch({ cols <- NCOL(x) }, error = function(e) { stop("Failed to determine columns for object of class '", class(x), "': ", e$message) }) if (is.null(cols)) 0 else cols }) .rs.addFunction("toDataFrame", function(x, name, flatten) { # if we have a data.table, convert it to a data.frame explicitly if (inherits(x, "data.table")) x <- as.data.frame(x) # if it's not already a frame, coerce it to a frame if (!is.data.frame(x)) { frame <- NULL # attempt to coerce to a data frame--this can throw errors in the case # where we're watching a named object in an environment and the user # replaces an object that can be coerced to a data frame with one that # cannot tryCatch( { # create a temporary frame to hold the value; this is necessary because # "x" is a function argument and therefore a promise whose value won't # be bound via substitute() below. we use a random-looking name so we # can spot it later when relabeling columns. `__RSTUDIO_VIEWER_COLUMN__` <- x # perform the actual coercion in the global environment; this is # necessary because we want to honor as.data.frame overrides of packages # which are loaded after tools:rstudio in the search path frame <- eval(substitute(as.data.frame(`__RSTUDIO_VIEWER_COLUMN__`, optional = TRUE)), envir = globalenv()) }, error = function(e) { }) # as.data.frame uses the name of its argument to label unlabeled columns, # so label these back to the original name if (!is.null(frame) && !is.null(names(frame))) names(frame)[names(frame) == "__RSTUDIO_VIEWER_COLUMN__"] <- name x <- frame } # if coercion was successful (or we started with a frame), flatten the frame # if necessary and requested if (is.data.frame(x)) { # generate column names if we didn't have any to start if (is.null(names(x))) names(x) <- paste("V", seq_along(x), sep = "") if (flatten) x <- .rs.flattenFrame(x) return(x) } }) .rs.addFunction("multiCols", function(x) { fun <- function(col) is.data.frame(col) || is.matrix(col) which(vapply(x, fun, TRUE)) }) # given a 'data.frame' containing columns which themselves have # multiple columns (e.g. matrices, data.frames), expand those columns # such that we have a 'data.frame' with the nested columns e .rs.addFunction("flattenFrame", function(x) { # skip if we don't have any rectangular columns; # in this case, we can return the data as-is isRectangular <- vapply(x, function(column) { is.data.frame(column) || is.matrix(column) }, FUN.VALUE = logical(1)) if (!any(isRectangular)) return(x) # split into separate data.frames stack <- .rs.stack() .rs.enumerate(x, .rs.dataViewer.flatten, stack = stack) parts <- stack$data() # pull out pieces we need keys <- vapply(parts, `[[`, "name", FUN.VALUE = "character") vals <- lapply(parts, `[[`, "value") # turn it into a data.frame names(vals) <- keys attr(vals, "row.names") <- .set_row_names(length(vals[[1L]])) class(vals) <- "data.frame" # all done vals }) .rs.addFunction("dataViewer.flatten", function(name, value, stack) { if (is.matrix(value)) { .rs.dataViewer.flattenMatrix(name, value, stack) } else if (is.data.frame(value)) { .rs.dataViewer.flattenDataFrame(name, value, stack) } else { stack$push(list(name = name, value = value)) } }) .rs.addFunction("dataViewer.flattenMatrix", function(name, value, stack) { colNames <- if (is.null(colnames(value))) as.character(seq_len(ncol(value))) else encodeString(colnames(value), quote = '"') for (i in seq_len(ncol(value))) { .rs.dataViewer.flatten( name = sprintf("%s[, %s]", name, colNames[[i]]), value = value[, i, drop = TRUE], stack = stack ) } }) .rs.addFunction("dataViewer.flattenDataFrame", function(name, value, stack) { # a data.frame should almost always have names, but check just in case colNames <- names(value) if (is.null(colNames)) colNames <- sprintf("<%i>", seq_along(value)) for (i in seq_along(value)) { .rs.dataViewer.flatten( name = paste(name, colNames[[i]], sep = "$"), value = value[[i]], stack = stack ) } }) .rs.addFunction("applyTransform", function(x, filtered, search, cols, dirs) { # mark encoding on character inputs if not already marked filtered <- vapply(filtered, function(colfilter) { if (Encoding(colfilter) == "unknown") Encoding(colfilter) <- "UTF-8" colfilter }, "") if (Encoding(search) == "unknown") Encoding(search) <- "UTF-8" # coerce argument to data frame--data.table objects (for example) report that # they're data frames, but don't actually support the subsetting operations # needed for search/sort/filter without an explicit cast x <- .rs.toDataFrame(x, "transformed", TRUE) # apply columnwise filters for (i in seq_along(filtered)) { if (nchar(filtered[i]) > 0 && length(x[[i]]) > 0) { # split filter--string format is "type|value" (e.g. "numeric|12-25") filter <- strsplit(filtered[i], split="|", fixed = TRUE)[[1]] if (length(filter) < 2) { # no filter type information next } filtertype <- filter[1] filterval <- filter[2] # apply filter appropriate to type if (identical(filtertype, "factor")) { # apply factor filter: convert to numeric values and discard missing filterval <- as.numeric(filterval) matches <- as.numeric(x[[i]]) == filterval matches[is.na(matches)] <- FALSE x <- x[matches, , drop = FALSE] } else if (identical(filtertype, "character")) { # apply character filter: non-case-sensitive prefix # use PCRE and the special \Q and \E escapes to ensure no characters in # the search expression are interpreted as regexes x <- x[grepl(paste("\\Q", filterval, "\\E", sep = ""), x[[i]], perl = TRUE, ignore.case = TRUE), , drop = FALSE] } else if (identical(filtertype, "numeric")) { # apply numeric filter, range ("2-32") or equality ("15") filterval <- as.numeric(strsplit(filterval, "_")[[1]]) if (length(filterval) > 1) # range filter x <- x[is.finite(x[[i]]) & x[[i]] >= filterval[1] & x[[i]] <= filterval[2], , drop = FALSE] else # equality filter x <- x[is.finite(x[[i]]) & x[[i]] == filterval, , drop = FALSE] } else if (identical(filtertype, "boolean")) { filterval <- isTRUE(filterval == "TRUE") matches <- x[[i]] == filterval matches[is.na(matches)] <- FALSE x <- x[matches, , drop = FALSE] } } } # apply global search if (!is.null(search) && nchar(search) > 0) { x <- x[Reduce("|", lapply(x, function(column) { grepl(paste("\\Q", search, "\\E", sep = ""), column, perl = TRUE, ignore.case = TRUE) })), , drop = FALSE] } # apply sort if (length(cols) > 0) { vals <- list() for (i in length(cols)) { idx <- cols[[i]] if (length(x[[idx]]) > 0) { if (identical(dirs[[i]], "asc")) { vals <- append(vals, list(x[[idx]])) } else { vals <- append(vals, list(-xtfrm(x[[idx]]))) } } } if (length(vals) > 0) { x <- x[do.call(order, vals), , drop = FALSE] } } return(x) }) # returns envName as an environment, or NULL if the conversion failed .rs.addFunction("safeAsEnvironment", function(envName) { env <- NULL tryCatch( { env <- as.environment(envName) }, error = function(e) { }) env }) .rs.addFunction("findDataFrame", function(envName, objName, cacheKey, cacheDir) { env <- NULL # mark encoding on cache directory if (Encoding(cacheDir) == "unknown") Encoding(cacheDir) <- "UTF-8" # do we have an object name? if so, check in a named environment if (!is.null(objName) && nchar(objName) > 0) { if (is.null(envName) || identical(envName, "R_GlobalEnv") || nchar(envName) == 0) { # global environment env <- globalenv() } else { env <- .rs.safeAsEnvironment(envName) if (is.null(env)) env <- emptyenv() } # if the object exists in this environment, return it (avoid creating a # temporary here) if (exists(objName, where = env, inherits = FALSE)) { # attempt to coerce the object to a data frame--note that a null return # value here may indicate that the object exists in the environment but # is no longer a data frame (we want to fall back on the cache in this # case) dataFrame <- .rs.toDataFrame(get(objName, envir = env, inherits = FALSE), objName, TRUE) if (!is.null(dataFrame)) return(dataFrame) } } if (.rs.isNonEmptyScalarString(cacheKey)) { # if the object exists in the cache environment, return it. objects # in the cache environment have already been coerced to data frames. if (exists(cacheKey, where = .rs.CachedDataEnv, inherits = FALSE)) return(get(cacheKey, envir = .rs.CachedDataEnv, inherits = FALSE)) # perhaps the object has been saved? attempt to load it into the # cached environment cacheFile <- file.path(cacheDir, paste(cacheKey, "Rdata", sep = ".")) if (file.exists(cacheFile)) { status <- try(load(cacheFile, envir = .rs.CachedDataEnv), silent = TRUE) if (inherits(status, "try-error")) return(NULL) if (exists(cacheKey, where = .rs.CachedDataEnv, inherits = FALSE)) return(get(cacheKey, envir = .rs.CachedDataEnv, inherits = FALSE)) } } # failure return(NULL) }) # given a name, return the first environment on the search list that contains # an object bearing that name. .rs.addFunction("findViewingEnv", function(name) { # default to searching from the global environment env <- globalenv() # attempt to find a call frame from which View was invoked; this will allow # us to locate viewing environments further in the call stack # (e.g. in the debugger) for (i in seq_along(sys.calls())) { if (identical(deparse(sys.call(i)[[1]]), "View")) { env <- sys.frame(i - 1) break } } # NOTE: we previously looked through the parent environments of # the associated frame to find the actual environment hosting the # object being viewed, but this caused problems when attempting # to track object mutations. for example, the 'mtcars' dataset is # defined in 'package:datasets', but attempting to modify that # object would actually create that modified object in the R global # environment. for that reason, it's best to track objects from the # top-level environment where they were found, as that's where # "modified" versions of that object will be generated env }) # attempts to determine whether the View(...) function the user has an # override (i.e. it's not the handler RStudio uses) .rs.addFunction("isViewOverride", function() { # check to see if View has been overridden: find the View() call in the # stack and examine the function being evaluated there for (i in seq_along(sys.calls())) { if (identical(deparse(sys.call(i)[[1]]), "View")) { # the first statement in the override function should be a call to # .rs.callAs return(!identical(deparse(body(sys.function(i))[[1]]), ".rs.callAs")) } } # if we can't find View on the callstack, presume the common case (no # override) FALSE }) .rs.addFunction("viewHook", function(original, x, title) { # remember the expression from which the data was generated expr <- deparse(substitute(x), backtick = TRUE) # generate title if necessary (from deparsed expr) if (missing(title)) title <- paste(expr[1]) # collapse expr for serialization expr <- paste(expr, collapse = " ") name <- "" env <- emptyenv() if (.rs.isViewOverride()) { # if the View() invoked wasn't our own, we have no way of knowing what's # been done to the data since the user invoked View() on it, so just view # a snapshot of the data name <- title } else if (is.name(substitute(x))) { # if the argument is the name of a variable, we can monitor it in its # environment, and don't need to make a copy for viewing name <- paste(deparse(substitute(x))) env <- .rs.findViewingEnv(name) } # is this a function? if it is, view as a function instead if (is.function(x)) { # check the source refs to see if we can open the file itself instead of # opening a read-only source viewer srcref <- .rs.getSrcref(x) if (!is.null(srcref)) { srcfile <- attr(srcref, "srcfile", exact = TRUE) filename <- .rs.nullCoalesce(srcfile$filename, "") if (!identical(filename, "~/.active-rstudio-document") && file.exists(filename)) { # the srcref points to a valid file--go there .Call("rs_jumpToFunction", normalizePath(filename, winslash = "/"), srcref[[1]], srcref[[5]], TRUE, PACKAGE = "(embedding)") return(invisible(NULL)) } } # either this function doesn't have a source reference or its source # reference points to a file we can't locate on disk--show a deparsed # version of the function # remove package qualifiers from function name title <- sub("^[^:]+:::?", "", title) # infer environment location namespace <- .rs.environmentName(environment(x)) if (identical(namespace, "R_EmptyEnv") || identical(namespace, "")) namespace <- "viewing" else if (identical(namespace, "R_GlobalEnv")) namespace <- ".GlobalEnv" invisible(.Call("rs_viewFunction", x, title, namespace, PACKAGE = "(embedding)")) return(invisible(NULL)) } else if (inherits(x, "vignette")) { file.edit(file.path(x$Dir, "doc", x$File)) return(invisible(NULL)) } # delegate to object explorer if this is an 'explorable' object if (.rs.dataViewer.shouldUseObjectExplorer(x)) { view <- .rs.explorer.viewObject(x, title = title, envir = env) return(invisible(view)) } # convert Pandas DataFrames to R data.frames if (inherits(x, "pandas.core.frame.DataFrame")) x <- reticulate::py_to_r(x) # test for coercion to data frame--the goal of this expression is just to # raise an error early if the object can't be made into a frame; don't # require that we can generate row/col names coerced <- x eval( expr = substitute(as.data.frame(coerced, optional = TRUE)), envir = globalenv() ) # save a copy into the cached environment cacheKey <- .rs.addCachedData(force(x), name) if (!.rs.isNonEmptyScalarString(cacheKey)) return(invisible(NULL)) # call viewData invisible(.Call("rs_viewData", x, expr, title, name, env, cacheKey, FALSE)) }) .rs.registerReplaceHook("View", "utils", .rs.viewHook) .rs.addFunction("dataViewer.shouldUseObjectExplorer", function(object) { if (inherits(object, c("function", "vignette"))) return(FALSE) # prefer data viewer for pandas DataFrames if (inherits(object, "pandas.core.frame.DataFrame")) return(FALSE) # don't explore regular data.frames isTabular <- is.data.frame(object) || is.matrix(object) || is.table(object) if (isTabular) return(FALSE) # other objects are worth using object explorer for TRUE }) .rs.addFunction("viewDataFrame", function(x, title, preview) { cacheKey <- .rs.addCachedData(force(x), "") if (.rs.isNonEmptyScalarString(cacheKey)) invisible(.Call("rs_viewData", x, "", title, "", emptyenv(), cacheKey, preview)) }) .rs.addFunction("initializeDataViewer", function(server) { if (server) { .rs.registerReplaceHook("edit", "utils", function(original, name, ...) { if (is.data.frame(name) || is.matrix(name)) stop("Editing of data frames and matrixes is not supported in RStudio.", call. = FALSE) else original(name, ...) }) } }) .rs.addFunction("addCachedData", function(obj, objName) { cacheKey <- .Call("rs_generateShortUuid") .rs.assignCachedData(cacheKey, obj, objName) cacheKey }) .rs.addFunction("assignCachedData", function(cacheKey, obj, objName) { # coerce to data frame before assigning, and don't assign if we can't coerce frame <- .rs.toDataFrame(obj, objName, TRUE) if (!is.null(frame) && .rs.isNonEmptyScalarString(cacheKey)) assign(cacheKey, frame, .rs.CachedDataEnv) }) .rs.addFunction("removeCachedData", function(cacheKey, cacheDir) { # mark encoding on cache directory if (Encoding(cacheDir) == "unknown") Encoding(cacheDir) <- "UTF-8" if (.rs.isNonEmptyScalarString(cacheKey)) { # remove data from the cache environment if (exists(".rs.CachedDataEnv") && exists(cacheKey, where = .rs.CachedDataEnv, inherits = FALSE)) rm(list = cacheKey, envir = .rs.CachedDataEnv, inherits = FALSE) # remove data from the cache directory cacheFile <- file.path(cacheDir, paste(cacheKey, "Rdata", sep = ".")) if (file.exists(cacheFile)) file.remove(cacheFile) # remove any working data .rs.removeWorkingData(cacheKey) } invisible(NULL) }) .rs.addFunction("saveCachedData", function(cacheDir) { # mark encoding on cache directory if (Encoding(cacheDir) == "unknown") Encoding(cacheDir) <- "UTF-8" # no work to do if we have no cache if (!exists(".rs.CachedDataEnv")) return(invisible(NULL)) # save each active cache file from the cache environment lapply(ls(.rs.CachedDataEnv), function(cacheKey) { if (.rs.isNonEmptyScalarString(cacheKey)) save(list = cacheKey, file = file.path(cacheDir, paste(cacheKey, "Rdata", sep = ".")), envir = .rs.CachedDataEnv) }) # clean the cache environment # can generate warnings if .rs.CachedDataEnv disappears (we call this on # shutdown); suppress these suppressWarnings(rm(list = ls(.rs.CachedDataEnv), where = .rs.CachedDataEnv)) invisible(NULL) }) .rs.addFunction("findWorkingData", function(cacheKey) { if (.rs.isNonEmptyScalarString(cacheKey) && exists(".rs.WorkingDataEnv") && exists(cacheKey, where = .rs.WorkingDataEnv, inherits = FALSE)) get(cacheKey, envir = .rs.WorkingDataEnv, inherits = FALSE) else NULL }) .rs.addFunction("removeWorkingData", function(cacheKey) { if (.rs.isNonEmptyScalarString(cacheKey) && exists(".rs.WorkingDataEnv") && exists(cacheKey, where = .rs.WorkingDataEnv, inherits = FALSE)) rm(list = cacheKey, envir = .rs.WorkingDataEnv, inherits = FALSE) invisible(NULL) }) .rs.addFunction("assignWorkingData", function(cacheKey, obj) { if (.rs.isNonEmptyScalarString(cacheKey)) assign(cacheKey, obj, .rs.WorkingDataEnv) }) .rs.addFunction("findGlobalData", function(name) { if (exists(name, envir = globalenv())) { if (inherits(get(name, envir = globalenv()), "data.frame")) return(name) } invisible("") }) .rs.addFunction("isNonEmptyScalarString", function(x) { is.character(x) && length(x) == 1 && nzchar(x) })