Created

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist

Sample code for unlocking environments in R

View unlockEnvironment.r
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
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

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.