Create a gist now

Instantly share code, notes, and snippets.

Sample code for unlocking environments in R
library(inline)
inc <- '
/* This is taken from envir.c in the R 2.15.1 source
https://github.com/SurajGupta/r-source/blob/master/src/main/envir.c
*/
#define FRAME_LOCK_MASK (1<<14)
#define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK)
#define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~ FRAME_LOCK_MASK))
'
src <- '
if (TYPEOF(env) == NILSXP)
error("use of NULL environment is defunct");
if (TYPEOF(env) != ENVSXP)
error("not an environment");
UNLOCK_FRAME(env);
// Return TRUE if unlocked; FALSE otherwise
SEXP result = PROTECT( Rf_allocVector(LGLSXP, 1) );
LOGICAL(result)[0] = FRAME_IS_LOCKED(env) == 0;
UNPROTECT(1);
return result;
'
unlockEnvironment <- cfunction(signature(env = "environment"),
includes = inc,
body = src)
unlockEnvironment(new.env()) # TRUE
unlockEnvironment('foo') # error
# TODO: Write proper R wrapper function
# - should return(invisible(TRUE)) if successful, error otherwise.
# - should also check type is environment
# - add 'bindings' option to also unlock bindings
# ============== test unlocking bindings
e <- new.env()
e$x <- 5
e$x # 5
lockEnvironment(e, bindings = TRUE)
e$x <- 6 # ERROR
environmentIsLocked(e) # TRUE
e$y <- 6 # ERROR
bindingIsLocked('x', e) # TRUE
unlockBinding('x', e)
bindingIsLocked('x', e) # FALSE
e$x <- 7 # OK
# Re-lock environment and bindings
lockEnvironment(e, bindings = TRUE)
e$y <- 6 # ERROR
# Run our custom function
unlockEnvironment(e) # TRUE
environmentIsLocked(e) # FALSE
e$y <- 8 # OK
bindingIsLocked('x', e) # TRUE
e$x <- 7 # ERROR
unlockBinding(ls(e, all.names=TRUE), e)
e$x <- 7 # OK
bindingIsLocked('x', e) # FALSE
bindingIsLocked('y', e) # FALSE
e$y <- 8 # OK
e$z <- 9 # OK
# =============== test on a real package
# Modify devtools namespace
# We'll insert a function 'foo()' into the namespace env and package env,
# and also add it to the namespace's exports
library(devtools)
# Add something to namespace environment
ns_env <- asNamespace('devtools')
unlockEnvironment(ns_env)
ns_env$foo <- function() {
ls(parent.env(environment()))
}
environment(ns_env$foo) <- ns_env # Set the environment of the function to the namespace
devtools:::foo # prints function, with environment
devtools:::foo() # returns contents of devtools, including non-exported objects
# Add to package environment
pkg_env <- as.environment('package:devtools')
unlockEnvironment(pkg_env)
pkg_env$foo <- ns_env$foo
pkg_env$foo # OK
devtools::foo # Error: 'foo' is not an exported object from 'namespace:devtools'
# Add to exports for devtools
export_env <- ns_env$.__NAMESPACE__.$exports
ls(export_env)
export_env$foo <- c(foo="foo")
devtools::foo # OK
devtools::foo() # returns contents of devtools, including non-exported objects
@jangorecki

Soon it will be is 3 years since that gist, maybe there is some better way? without inline dependency?

@SymbolixAU

This SO answer looks like an alternative?

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment