Nothing
# Copyright (C) Brodie Gaslam
#
# This file is part of "unitizer - Interactive R Unit Tests"
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
#' @include class_unions.R
NULL
# Class To Track History Changes
setClass(
"unitizerNsListData", contains="unitizerList",
validity=function(object) {
if(!all(vapply(object@.items, is, logical(1L), "unitizerNamespaceData")))
return("Object may only contain environments")
TRUE
}
)
# # Deprecated b/c way too slow
# setClass(
# "unitizerSearchData", contains="unitizerList",
# slots=c(ns.dat="unitizerNsListData"),
# prototype=list(data=NULL),
# validity=function(object) {
# if(!all(vapply(object@.items, is.environment, logical(1L))))
# return("Object may only contain environments")
# TRUE
# }
# )
# setGeneric(
# # nocov start
# "unitizerGetPaths", function(x, ...) StandardGeneric("unitizerGetPaths")
# # nocov end
# )
# setMethod(
# "unitizerGetPaths", "unitizerSearchData",
# function(x, ...) lapply(as.list(x), attr, "path")
# )
# setGeneric(
# # nocov start
# "unitizerGetVersions", function(x, ...) StandardGeneric("unitizerGetVersions")
# # nocov end
# )
#' @importFrom utils sessionInfo
get_package_versions <- function(x) {
ns.loaded <- names(x$ns.dat)
ns.version <- vapply(x$ns.dat, "[[", character(1L), "version")
pkg.names <- names(x$search.path)
are.pkg <- grepl("^package:.+", pkg.names)
pkg.names <- sub("^package:(.*)", "\\1", pkg.names)
# base packages should not show version (issue203)
base.pkg <- sessionInfo()$basePkgs
pkg.sub <- match(pkg.names, ns.loaded)
pkg.ver <- ns.version[pkg.sub]
pkg.ver[!are.pkg | pkg.names %in% base.pkg] <- NA_character_
pkg.ver[pkg.names == "base"] <- as.character(getRversion())
pkg.ver
}
# Used to be an S4 method for the search data objects
#
# Checks whether the search data objects are equivalent, note we check names b/c
# environments will usually not be equal
search_dat_equal <- function(target, current) {
res <- character()
tar <- target$search.path
cur <- current$search.path
if(!isTRUE(name.comp <- all.equal(names(tar), names(cur))))
res <- c("Search Path Name Mismatch:", name.comp)
if(
!isTRUE(
path.comp <- all.equal(
lapply(tar, attr, "path"), lapply(cur, attr, "path")
) ) )
res <- c("Search Path Object Path Mismatch:", path.comp)
if(length(res)) res else TRUE
}
# setClass(
# "unitizerNamespaceData",
# slots=c(
# name="character", lib.loc="characterOrNULL", version="characterOrNULL"
# ) )
# setClass(
# "unitizerPackageData",
# slots=c(
# name="character", lib.loc="characterOrNULL", version="characterOrNULL"
# ) )
# Reduce search path info to pkg name and version
compress_search_data <- function(x) {
res <- names(x$search.path)
res.pkg <- grepl("^package:.+", res)
ver <- get_package_versions(x)
res[!is.na(ver)] <- paste0(res[!is.na(ver)], " (v", ver[!is.na(ver)], ")")
res
}
compress_ns_data <- function(x) {
vapply(x, function(y) sprintf("%s (v%s", y$names, y$version), character(1L))
}
# Search Path Management Functions
#
# Set of functions used to manage search path state. Strategy is to
# keep track of every different search path state encountered which is done
# with \code{.global}, and then allow restoring to previous states with these
# functions.
#
# While we believe the strategy used here is mostly robust, users can defeat
# by changing search paths multiple times withing a single test, which we will
# not journal properly, though this is not likely to be a major issue.
#
# \code{search_path_trim} attempts to recreate a clean environment by
# unloading all packages and objects that are not loaded by default in the
# default R configuration.
#
# This function is intended to be called after journaling has been enabled.
#
# \code{tools:rstudio} is kept in search path as the default argument because
# it is not possible to cleanly unload and reload it because \code{attach}
# actually attaches a copy of it's argument, not the actual object, and that
# causes problems for that search path item.
#
# @keywords internal
# @rdname search_path
# @param keep character names of packages/objects to keep in search path;
# note that base packages (see .unitizer.base.packages) that come typically
# pre attached are always kept. The \code{keep} packages are an addition
# to those.
# @param id integer(1L) what recorded state to revert to
# @param global reference object of class "unitizerGlobal" that holds the
# global settings
search_path_update <- function(id, global) {
stopifnot(is(global, "unitizerGlobal"), is.int.pos.1L(id))
if(!id %in% seq_along(global$tracking@search.path)) {
stop( # nocov start
"Internal Error: attempt to reset state to unknown index; contact ",
"maintainer"
) # nocov end
}
search.target <- global$tracking@search.path[[id]]
search.curr <- global$tracking@search.path[[global$indices.last@search.path]]
curr.env.check <- search_as_envs()
if(!isTRUE(search_dat_equal(curr.env.check, search.curr))) {
# not entirely sure this check is needed, or might be too stringent
# new version of comparing entire object not tested
# nocov start
stop("Internal Error: mismatch between actual search path and tracked path")
# nocov end
}
# If we exit pre-maturely we'll be in a weird state so we need to mark this
# state so that next time we get here during the overall `on.exit` we can
# proceed
on.exit(global$state())
# Get uniquely identified objects on search path; this isn't completely
# perfect because some objects that are genuinely the same might be identified
# as different because R copied them during attach / detach
st.id <- unitizerUniqueNames(search.target)
sc.id <- sc.id.tmp <- unitizerUniqueNames(search.curr)
# Drop the stuff that definitely needs to be dropped, from back so that
# numbering doesn't get messed up
to.detach <- which(is.na(match(sc.id, st.id)))
for(i in sort(to.detach, decreasing=TRUE)) detach(pos=i)
if(length(to.detach)) sc.id.tmp <- sc.id.tmp[-to.detach]
# Add the stuff that definitely needs to get added, but this time from the
# front so the positions make sense
for(i in sort(which(is.na(match(st.id, sc.id.tmp))))) {
obj.name <- names(search.target$search.path)[[i]]
if(is.null(obj.name)) obj.name <- ""
obj.type <- if(grepl("^package:.+", obj.name)) "package" else "object"
obj.name.clean <- sub("^package:", "", obj.name)
extra <- if(!is.null(attr(search.target$search.path[[i]], "path")))
dirname(attr(search.target$search.path[[i]], "path"))
reattach(
i, name=obj.name.clean, type=obj.type,
data=search.target$search.path[[i]], extra=extra, global=global
)
sc.id.tmp <- append(sc.id.tmp, st.id[[i]], i - 1L)
}
# Now see what needs to be swapped; make sure not to detach environments that
# are not package environments that should be kept on the search path as doing
# so leads to them getting copied
search.keep <- keep_sp_default(global$unitizer.opts)
j <- 0
repeat {
reord <- match(sc.id.tmp, st.id)
if(any(is.na(reord)) || !identical(length(reord), length(st.id)))
# nocov start
stop("Internal Error: incorrect path remapping; contact maintainer.")
# nocov end
if(!any(mismatch <- reord != seq_along(reord))) break
if((j <- j + 1) > length(st.id) || length(which(mismatch)) < 2L)
# nocov start
stop("Internal Error: unable to reorder search path; contact maintainer.")
# nocov end
swap.valid <- mismatch & (
grepl("package:.+", sc.id.tmp) | !sc.id.tmp %in% search.keep
)
if(!any(swap.valid))
# nocov start
stop(
"Internal Error: unable to reorder search path because of ",
"'unitizer.search.path.keep' limitations. If you added objects ",
"to that option, make sure you're not also attaching/detaching ",
"them in your tests. If you are not doing those things, contact ",
"maintainer."
)
# nocov end
swap.id <- min(reord[swap.valid])
swap.pos <- which(reord == swap.id)
move_on_path(new.pos=swap.id, old.pos=swap.pos, global=global)
sc.id.tmp <- unitizerUniqueNames(search_as_envs())
}
search.new <- search()
sp.check <- match(search.new, names(search.target$search.path))
if(any(is.na(sp.check)) || any(diff(sp.check) < 1L))
# nocov start
stop("Internal Error: path reorder failed; contact maintainer.")
# nocov end
search.target$search.path <- search.target$search.path[search.new]
# Replace all non packages with those in the target list since those may have
# been changed (note, using search.new as it is possible we failed to fully
# restore path (e.g. if a package is removed but not dettached/unloaded))
tar.objs <- vapply(search.new, is.loaded_package, logical(1L))
cur.objs <- vapply(
names(search_as_envs()$search.path), is.loaded_package, logical(1L)
)
if(!identical(tar.objs, cur.objs))
# nocov start
stop("Internal Error: search path object type mismatch; contact maintainer.")
# nocov end
if(!all(tar.objs)) {
for(
i in which(!tar.objs & !(search.new %in% search.keep))
) {
# Don't replace identical elements; this is meant to avoid re-attaching
# environments since doing so actually leads to a copy of the
# environment being made
if(identical(as.environment(i), search.target$search.path[[i]])) next
detach(pos=i, character.only=TRUE)
reattach(
i, names(search.target$search.path)[[i]], type="object",
data=search.target$search.path[[i]],
global=global
) } }
# Updated comparison method (might be too stringent)
if(!isTRUE(search_dat_equal(search_as_envs(), search.target)))
# nocov start
stop("Internal Error: path reorder failed at last step; contact maintainer.")
# nocov end
on.exit(NULL)
invisible(TRUE)
}
# This also unloads namespaces so that packages can
# be reloaded with all corresponding hooks evaluating as with a normal load.
# As documented in \code{?detach}, it is likely there may be some issues with
# some packages with this approach.
#
# This function is intended to be called after journaling has been enabled.
#
# @param id integer(1L) what recorded state to revert to
# @param global reference object of class "unitizerGlobal" that holds the
# global settings
namespace_update <- function(id, global) {
stopifnot(is(global, "unitizerGlobal"), is.int.pos.1L(id))
if(!id %in% seq_along(global$tracking@namespaces))
# nocov start
stop(
"Internal Error: attempt to reset namespaces to unknown index; contact ",
"maintainer"
)
# nocov end
ns.target <- global$tracking@namespaces[[id]]
# should this be get_namespace_data()?
ns.curr <- global$tracking@namespaces[[global$indices.last@namespaces]]
ns.in.common <- intersect(names(ns.target), names(ns.curr))
ns.extra <- setdiff(names(ns.curr), ns.in.common)
# Line up the namespaces
cur.lns <- loadedNamespaces()
# may contain nulls
tar.lns.loc <- sapply(as.list(ns.target), "[[", "lib.loc", simplify=FALSE)
tar.lns <- names(ns.target)
to.unload <- setdiff(cur.lns, tar.lns)
unload_namespaces(
to.unload, global=global,
keep.ns=global$unitizer.opts[["unitizer.namespace.keep"]]
)
to.load <- setdiff(tar.lns, loadedNamespaces())
for(i in to.load) {
try.ln <- try(loadNamespace(i, lib.loc=dirname(tar.lns.loc[[i]])))
if(inherits(try.ln, "try-error"))
warning(
"Unable to fully restore previously loaded namespaces.",
immediate.=TRUE
)
}
invisible(TRUE)
}
search_path_trim <- function(
keep.path=keep_sp_default(options()),
global
) {
stopifnot(
is.character(keep.path) && !any(is.na(keep.path)),
is(global, "unitizerGlobal")
)
on.exit(global$state())
# detach each object, but make sure we do so in an order that doesn't cause
# issues with namespace dependencies
search.path.pre <- search()
to.detach <- setdiff(search.path.pre, c(keep.path, .unitizer.base.packages))
to.detach.pkg <- vapply(to.detach, is.loaded_package, logical(1L))
to.detach.pkg.names <- sub("^package:", "", to.detach[to.detach.pkg])
to.keep <- intersect(c(keep.path, .unitizer.base.packages), search.path.pre)
to.keep.pkg <- vapply(to.keep, is.loaded_package, logical(1L))
to.keep.pkg.names <- sub("^package:", "", to.keep[to.keep.pkg])
# start by detaching without unloading
for(pack in to.detach) {
if(!is.chr1(pack))
# nocov start
stop("Internal Error: invalid search path token; contact maintainer.")
# nocov end
detach(pack, character.only=TRUE)
}
invisible(TRUE)
}
namespace_trim <- function(
keep.ns=keep_ns_default(options()),
global
) {
stopifnot(
is.character(keep.ns) && !any(is.na(keep.ns)), is(global, "unitizerGlobal")
)
on.exit(global$state())
unload_namespaces(loadedNamespaces(), global=global, keep.ns=keep.ns)
invisible(TRUE)
}
# Unload Namespaces
#
# Attempts to unload namespaces in an order that avoids dependency issues
# based on data from \code{getNamespaceImports}
#
# Needs to be thought through a bit more in terms of how integrated it should
# be with the functions that use it.
unload_namespaces <- function(
unload=loadedNamespaces(), global, keep.ns=union(
getOption("unitizer.namespace.keep.base"),
getOption("unitizer.namespace.keep")
)
) {
stopifnot(
is.character(unload), all(!is.na(unload)),
is.character(keep.ns) && !any(is.na(keep.ns)),
is(global, "unitizerGlobal")
)
# We can't unload any namespaces associated with packages; packages must be
# unloaded first
search.path.pre <- search()
search.path.pkg <- vapply(search.path.pre, is.loaded_package, logical(1L))
search.path.pkg.names <-
sub("^package:", "", search.path.pre[search.path.pkg])
sp.depends <- unique(
c(
search.path.pkg.names,
unlist(
lapply(search.path.pkg.names, function(x) names(getNamespaceImports(x)))
) ) )
unload <- setdiff(unload, sp.depends)
# Check that none of the keep namespaces reference namespaces other than the
# keep namespaces, and warn otherwise since we won't be able to unload /
# re-load that one
to.keep.depends <- unlist(
lapply(
keep.ns[keep.ns %in% loadedNamespaces()],
function(x) names(getNamespaceImports(x))
) )
# Since `getNamespaceImports` is supposed to be a bit experimental, make sure
# that all namespaces we got are actually loaded, which they really should be
if(!all(union(sp.depends, to.keep.depends) %in% loadedNamespaces()))
# nocov start
stop(
"Internal Error: loaded namespace dependency calculation produced ",
"non-loaded namespaces; this should not happen; contact maintainer."
)
# nocov end
# Stuff left to unload
unload.net <- setdiff(unload, c(keep.ns, to.keep.depends))
# Now unload namespaces
lns.raw <- loadedNamespaces()
if(!all(unload.net %in% lns.raw))
# nocov start
stop(
"Internal Error: attempting to unload namespaces that are not loaded; ",
"contact maintainer."
)
# nocov end
lns.tmp <- sapply(
unload.net, function(x) unique(names(getNamespaceImports(x))),
simplify=FALSE
)
# Get lib locations to unload DLLs later (if applicable)
lib.locs <- vapply(
unload.net,
function(x) {
if(inherits(loc <- try(find.package(x), silent=TRUE), "try-error")) {
# nocov start
warning(
"Internal Warning: Unloading namespace \"", x, "\", but it does ",
"not appear to have a corresponding installed package; if this",
"warning persists please contact maintainer about it.",
immediate.=TRUE
)
""
# nocov end
} else loc
},
character(1L)
)
# Cycle through path attempting to unload namespaces until we cannot unload
# any more. This is not a particularly efficient algorithm, but should make
# do for our purposes. Really should create a dependency matrix, decrementing
# dependencies as we unload them, and look for rows (or cols) with zero values
# to find namespaces to unload
lns.orig <- lns <- lns.tmp
safety <- 0
unloaded.success <- character(0L)
repeat {
if(safety <- safety + 1L > 1000)
# nocov start
stop(
"Internal Error: namespace unloading not complete after 1000 iterations"
)
# nocov end
lns.names <- names(lns)
unloaded.try <- integer(0L)
for(i in seq_along(lns)) {
tar.ns <- names(lns)[[i]]
if(!tar.ns %in% unlist(lns[-i])) {
# No dependencies, so attempt to unload
unloaded.try <- c(unloaded.try, i)
attempt <- try(unloadNamespace(tar.ns))
if(inherits(attempt, "try-error")) {
# nocov start
# no good way to test this
warning(
"Error while attempting to unload namespace `", tar.ns, "`",
immediate.=TRUE
)
# nocov end
} else {
unloaded.success <- c(unloaded.success, tar.ns)
}
}
}
# Keep looping until length of remaining namespaces doesn't decrease anymore
lns <- lns[-unloaded.try]
if(!length(unloaded.try)) break
}
# Unload any dynamic libraries associated with the stuff we detached by
# matching paths to what's in dynlibs
dyn.lib.fnames <- vapply(.dynLibs(), "[[", character(1L), "path")
dls <- sub("/libs/[^/].*$", "", dyn.lib.fnames)
lib.locs.ul <- lib.locs[unloaded.success]
dls.to.ul <- lib.locs.ul[lib.locs.ul %in% dls]
for(i in names(dls.to.ul)) library.dynam.unload(i, dls.to.ul[i])
if(length(lns)) {
# nocov start
# no good way to test this
warning(
"Unable to unload the following namespaces: ",
char_to_eng(sort(names(lns)), "", ""), immediate.=TRUE
)
# nocov end
}
# Warn if some namespaces could not be unloaded (likely due to dependency),
# and register the conflict if we're tracking options
if(
(
length(unload.conf <- which(unload %in% keep.ns)) ||
length(lns)
) && global$status@options
) {
global$ns.opt.conflict@conflict <- TRUE
global$ns.opt.conflict@namespaces <- c(unload[unload.conf], names(lns))
global$status@options <- 0L
global$disabled@options <- TRUE
global$state() # mark state if we're not able to completely clean it up
}
NULL
}
# Check Whether a Package Is Loaded
#
# A package is considered loaded if it is in the search path and there is a
# namespace loaded with the same name as the package
#
# @keywords internal
# @param pkg.name character(1L) must be in format "package:pkgname"
# @return TRUE if it is a loaded package
is.loaded_package <- function(pkg.name) {
if(!is.character(pkg.name) || length(pkg.name) != 1L)
stop("Argument `pkg.name` must be character 1L")
if(!isTRUE(grepl("^package:", pkg.name)))
return(FALSE)
just.name <- sub("^package:(.*)", "\\1", pkg.name)
pkg.name %in% search() && just.name %in% loadedNamespaces()
}
# Path manipulation functions
#
# Reattaches a previously detached package to the search path
reattach <- function(pos, name, type, data, extra=NULL, global) {
stopifnot(
is.integer(pos), identical(length(pos), 1L), !is.na(pos), pos > 0L,
is.chr1plain(name), !is.na(name),
is.chr1plain(type), !is.na(type), type %in% c("package", "object"),
is.environment(data),
is(global, "unitizerGlobal")
)
if(identical(type, "package")) {
suppressPackageStartupMessages(
lib.try <- try(library(
name, pos=pos, quietly=TRUE, character.only=TRUE,
lib.loc=extra, warn.conflicts=FALSE
) ) )
if(inherits(lib.try, "try-error")) {
# nocov start
warning(
"Warning: unable to fully restore search path; see prior ",
"error, and consult `?unitizerState`, searching for \"Caveats\". ",
"Contact maintainer if your problem is not covered by documentation.",
immediate.=TRUE
)
global$state()
# nocov end
}
} else {
base::attach(data, pos=pos, name=name, warn.conflicts=FALSE)
}
}
# @keywords internal
# @rdname reattach
move_on_path <- function(new.pos, old.pos, global) {
stopifnot(
is.integer(new.pos), length(new.pos) == 1L, !is.na(new.pos),
is.integer(old.pos), length(old.pos) == 1L, !is.na(old.pos),
old.pos > new.pos, # otherwise detaching old.pos would mess path up
new.pos > 1L, # can't attach at 1L
is(global, "unitizerGlobal")
)
sp <- search()
stopifnot(new.pos <= length(sp), old.pos <= length(sp))
name <- sp[[old.pos]]
obj <- as.environment(old.pos)
if(is.loaded_package(name)) {
type <- "package"
extra <- dirname(attr(obj, "path"))
} else {
type <- "object"
extra <- NULL
}
name.clean <- sub("package:", "", name)
detach(pos=old.pos)
reattach(
pos=new.pos, name=name.clean, type=type, data=obj, extra=extra,
global=global
)
}
# Make Unique IDs For Search Path Object
#
# adds ".1", ".2" etc if there are non-unique values, but first occurence is
# not modified so we can match between a list with duplicates and one without.
#
# This use to be for unitizerSearchData objects but that was way too slow to use
# in general search path tracking so had to switch to list.
setGeneric(
# nocov start
"unitizerUniqueNames", function(x, ...)
StandardGeneric("unitizerUniqueNames")
# nocov end
)
setMethod(
"unitizerUniqueNames", "list",
function(x, ...) {
sp.id.base <- names(x$search.path)
ave(
sp.id.base, sp.id.base,
FUN=function(x) {
if(length(x) == 1L) return(x)
c(head(x, 1L), paste0(tail(x, -1L), ".", 1:(length(x) - 1L)))
}
)
}
)
## Generate An Identifier out of SP objects
##
## If this needs to be optimized look at `get_namespace_data` that is very
## similar but runs on `loadedNamespaces`.
##
## Not perfect, by any means, but necessary because we can't directly compare
## the search path environments as they change on detach / re-attach
get_package_data <- function() {
sapply(
search(),
function(x) {
loc <- if(grepl("^package:.+", x))
try(path.package(sub("^package:(.*)", "\\1", x))) else ""
ver <- try(getNamespaceVersion(x), silent=TRUE)
list(
names=x,
lib.loc=if(!inherits(loc, "try-error")) loc else "",
version=if(!inherits(ver, "try-error")) ver else ""
)
},
simplify=FALSE
)
}
# Helper function for loading options
#
# @param opts a list of options to look in for the relevant options
keep_ns_default <- function(opts=options()) {
ns.opts <- c("unitizer.namespace.keep.base", "unitizer.namespace.keep")
valid_sp_np_default(opts, ns.opts)
keep.sp <- keep_sp_default(opts)
keep.sp.ns <- sub("^package:", "", grep("^package:.+", keep.sp, value=TRUE))
unique(c(unlist(opts[ns.opts]), keep.sp.ns))
}
keep_sp_default <- function(opts=options()) {
sp.opts <- c("unitizer.search.path.keep.base", "unitizer.search.path.keep")
valid_sp_np_default(opts, sp.opts)
unique(unlist(opts[sp.opts]))
}
# Validation function shared by ns and sp funs
valid_sp_np_default <- function(opts, valid.names) {
stopifnot(
is.list(opts),
is.character(valid.names) && !any(is.na(valid.names)),
all(valid.names %in% names(opts)),
all(
vapply(
opts[valid.names], function(x) is.character(x) && !any(is.na(x)),
logical(1L)
) ) )
invisible(TRUE)
}
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.