Having trouble with running Breadth-first search algorithm on a graph, my current concern is with the environment parameter, where the callback function is evaluated.
This is the callback function
f.in <- function(graph, data, extra) {
time <- get.vertex.attribute(graph, "time", index=data["vid"])
root_time <- get.vertex.attribute(graph, "time", index=extra)
print(ls(environment()))
if (time != 0){
time_difference <- time - root_time
result_list <- c(list(), time_difference)
}
}
This is the context where the functions is called
graphs <- decompose.graph(network_graph, max.comps = NA, min.vertices = 0)
lapply(graphs, function(g){
v0 <- which(degree(g, mode="out") == 0)
t0 <- get.vertex.attribute(g, "time", index=v0)
if (t0 != 0) {
bfs_environment <- new.env()
assign("result_list", list(), envir=bfs_environment)
graph.bfs(g, v0, neimode="in", callback=f.in, extra=v0, rho=bfs_environment)
}
})
Now the print of environment shows me the following variables
"data" "extra" "graph" "root_time" "time"
The question is that when I have passed the environment where the callback function is evaluated, then why the "result_list" is not available? Is there something wrong with passing this environment?
Btw using R 2.15.3 and iGraph 0.7.0
When the documentation states:
rho: The environment in which the callback function is evaluated
it means that the passed environment is the parent of the callback environment.
So you can retrieve your variable using get() and parent.frame() functions, as shown in the following example:
myCallBack <- function(graph, data, extra) {
print(ls(parent.frame()))
print(get('result_list', envir=parent.frame()))
stop('just to stop at the first call...')
}
# a simple tree with 3 nodes
g <- graph.tree(3, children = 2, mode='out')
bfs_environment <- new.env()
assign("result_list", list(A=3), envir=bfs_environment)
graph.bfs(g, 1, callback=myCallBack, extra=NULL, rho=bfs_environment)
Output:
[1] "result_list"
$A
[1] 3
Related
In Advanced R, environments are advertised as a useful way to get pass-by-reference semantics in R: instead of passing a list, which gets copied, I can pass an environment, which is not. This is useful to know.
But it assumes that whoever is calling my function is happy to agree on an "environment"-based data type, with named slots corresponding to the variables we want to modify.
Hasn't someone made a class which allows me to just refer to a single variable by reference? For example,
v = 1:5
r <- ref(v)
(function() {
getRef(r) # same as v
setRef(r, 1:6) # same as v <<- 1:6, in this case
})()
It would seem to be pretty easy to do this, by storing the character name of v together with the environment where it is bound.
Is there a standard library which accomplishes this semantics, or can someone provide a short snippet of code? (I haven't finished reading "Advanced R"; apologies if this is covered later in the book)
As you have already mentioned in your question, you can store the variable name and its environment and access it with get and assign what will be somehow like a reference to a single variable.
v <- 1:5
r <- list(name="v", env=environment())
(function() {
get(r$name, envir = r$env)
assign(r$name, 1:6, envir = r$env)
})()
v
#[1] 1 2 3 4 5 6
Alternatively you can store the reference to an environment but then you can access everything in this referenced environment.
v <- 1:5
r <- globalenv() #reference to everything in globalenv
(function() {
r$v
r$v <- 1:6
})()
v
#[1] 1 2 3 4 5 6
You can also create an environment with only one variable and make a reference to it.
v <- new.env(parent=emptyenv())
v$v <- 1:5
r <- v
(function() {
r$v
r$v <- 1:6
})()
v$v
#[1] 1 2 3 4 5 6
Implemented as functions using find or set the environment during creation. Have also a look at How to get environment of a variable in R.
ref <- function(name, envir = NULL) {
name <- substitute(name)
if (!is.character(name)) name <- deparse(name)
if(length(envir)==0) envir <- as.environment(find(name))
list(name=name, envir=envir)
}
getRef <- function(r) {
get(r$name, envir = r$envir, inherits = FALSE)
}
setRef <- function(r, x) {
assign(r$name, x, envir = r$envir, inherits = FALSE)
}
x <- 1
r1 <- ref(x) #x from Global Environment
#x from Function Environment
r2 <- (function() {x <- 2; ref(x, environment())})()
#But simply returning x might here be better
r2b <- (function() {x <- 2; x})()
a <- new.env(parent=emptyenv())
a$x <- 3
r3 <- ref(x, a) #x from Environment a
This is based on GKi's answer, thanks to him for stepping up.
It includes pryr::where so you don't have to install the whole library
Note that we need to point "where" to parent.frame() in the definition of "ref"
Added some test cases which I used to check correctness
The code:
# copy/modified from pryr::where
where = function(name, env=parent.frame()) {
if (identical(env, emptyenv())) {
stop("Can't find ", name, call. = FALSE)
}
if (exists(name, env, inherits = FALSE)) {
env
} else {
where(name, parent.env(env))
}
}
ref <- function(v) {
arg <- deparse(substitute(v))
list(name=arg, env=where(arg, env=parent.frame()))
}
getRef <- function(r) {
get(r$name, envir = r$env, inherits = FALSE)
}
setRef <- function(r, x) {
assign(r$name, x, envir = r$env)
}
if(1) { # tests
v <- 1:5
r <- ref(v)
(function() {
stopifnot(identical(getRef(r),1:5))
setRef(r, 1:6)
})()
stopifnot(identical(v,1:6))
# this refers to v in the global environment
v=2; r=(function() {ref(v)})()
stopifnot(getRef(r)==2)
setRef(r,5)
stopifnot(getRef(r)==5)
stopifnot(v==5)
# same as above
v=2; r=(function() {v <<- 3; ref(v)})()
stopifnot(getRef(r)==3)
setRef(r,5)
stopifnot(getRef(r)==5)
stopifnot(v==5)
# this creates a local binding first, and refers to that. the
# global binding is unaffected
v=2; r=(function() {v=3; ref(v)})()
stopifnot(getRef(r)==3)
setRef(r,5)
stopifnot(getRef(r)==5)
stopifnot(v==2)
# additional tests
r=(function() {v=4; (function(v1) { ref(v1) })(v)})()
stopifnot(r$name=="v1")
stopifnot(getRef(r)==4)
setRef(r,5)
stopifnot(getRef(r)==5)
# check that outer v is not modified
v=2; r=(function() {(function(v1) { ref(v1) })(v)})()
stopifnot(getRef(r)==2)
setRef(r,5)
stopifnot(getRef(r)==5)
stopifnot(v==2)
}
I imagine there may be some garbage collection inefficiency if you're creating a reference to a small variable in a temporary environment with a different large variable, since the reference must retain the whole environment - although the same problem could arise with other uses of lexical scoping.
I will probably use this code next time I need pass-by-reference semantics.
Sorry if this is a duplicate. I am very new to data.table. Basically, I am able to get my code to work outside of functions, but when I pack the operations inside of a function, they breakdown. Ultimately, I had hoped to make the functions age.inds and m.inds internal functions in a package.
# required functions ------------------------------------------------------
# create object
create.obj <- function(n = 100){
obj = list()
obj$inds <- data.table(age = rep(0.1, n), m = NA)
obj$m$model <- function(age, a){return(age^a)}
obj$m$params <- list(a = 2)
return(obj)
}
# calculate new 'age' of inds
age.inds <- function(obj){
obj$inds[, age := age + 1]
return(obj)
}
# calculate new 'm' of inds
m.inds <- function(obj){
ARGS <- list()
args.incl <- which(names(obj$m$params) %in% names(formals(obj$m$model)))
ARGS <- c(ARGS, obj$m$params[args.incl])
args.incl <- names(obj$inds)[names(obj$inds) %in% names(formals(obj$m$model))]
ARGS <- c(ARGS, obj$inds[, ..args.incl]) # double dot '..' version
# ARGS <- c(ARGS, inds[, args.incl, with = FALSE]) # 'with' version
obj$inds[, m := do.call(obj$m$model, ARGS)]
return(obj)
}
# advance object
adv.obj <- function(obj, times = 1){
for(i in seq(times)){
obj <- age.inds(obj)
obj <- m.inds(obj)
}
return(obj)
}
# Example ----------------------------------------------------------------
# this doesn't work
obj <- create.obj(n = 10)
obj # so far so good
obj <- age.inds(obj)
obj # 'inds' gone
# would ultimately like to call adv.obj
obj <- adv.obj(obj, times = 5)
Also (as a side note), most of what I would like to do in my code would be vectorized calculations (i.e. updating variables in obj$inds), so I don't even know if going to data.tables makes too much sense for me (i.e. no by grouping operations as of yet). I am dealing with large objects and wondered if switching from data.frame objects would speed things up (I can get my code to work using data.frames).
Thanks
Update
OK, the issue with the printing has been solved thanks to #eddi. I am however unable to use these "inds" functions when they are located internally within a package (i.e not exported). I made a small package (DTtester), that has this example in the help file for adv.obj:
obj <- create.obj(n=10)
obj <- adv.obj(obj, times = 5)
# Error in `:=`(age, new.age) :
# Check that is.data.table(DT) == TRUE. Otherwise, := and `:=`(...) are
# defined for use in j, once only and in particular ways. See help(":=").
Any idea why the functions would fail in this way?
What I want to accomplish
I have an R package with some internal R functions (called f and g in the example below) that are used in a recursive manner. In the minimal example the functions just return the length of their argument, but in the real code they trigger more complex calculations.
What I want to do is the following:
If the user passes an object to the function g, R should lookup if we have a S3 method we can call on this object.
If the object is a list, the function g should be applied to each object within the list. If we did not yet reached the maximum recursion depth go to 1. If we reached the maximum recursion level stop.
Code that shows the problem
It is important that the follwing code is put into a package. The error I get is only reproducible if the code is part of a package.
utils.R
g <- function(x, depth = 0) {
stopifnot(depth <= 1)
UseMethod("g")
}
g.numeric <- function(x, depth = 0) {
length(x)
}
g.integer <- function(x, depth = 0) {
length(x)
}
g.double <- function(x, depth = 0) {
length(x)
}
g.list <- function(x, depth = 0) {
sum(sapply(x, g, depth = depth + 1))
}
core.R
#' #export
core_fun <- function(x) {
g(x)
}
What I expect
Error
The result should be 6;
x <- c(1.0, 1.3, 1.5)
core_fun(list(x,x))
But I get an error message:
Error in UseMethod("g") :
no applicable method for 'g' applied to an object of class "c('double','numeric')"
Passes
The result should be 3.
x <- c(1.0, 1.3, 1.5)
core_fun(x)
Remarks
When I call the example, that fails, after loading the function g into the global namespace I get the expected result, 6.
So I think it is an namespace / S3 related problem, but I don't know how to fix it.
I believe this has to do with this Note in ?lapply. If you run it with a wrapper as they suggest, the dispatch is done correctly.
g.list <- function(x, depth = 0) {
sum(sapply(x, function(x_i) g(x_i, depth = depth + 1)))
}
I am running into a similar issue as this unanswered question on R-pkg-devel about NOTES during R CMD Check of a package.
Given a function that assigns a function to an object depending on a conditional, R CMD Check throws a note. This function is an example. The function is pulling data objects from the package's internal namespace (data objects that are lookup tables not exported to the user). Depending on the user specified option, different lookup tables and different assignment functions are created and passed out in a list for use elsewhere.
get_baseline <- function(bl){
if(bl == "ell"){
data <- ell
keys <- c("race", "age")
fun <- function(x) rbinom(1, 1, x)
} else if(bl == "ses"){
data <- ses
keys <- c("race")
fun <- function(x) rbinom(1, 1, x)
} else if(bl == "program"){
data <- prog_baseline
keys <- NULL
fun <- function() {prog_baseline[sample(rownames(prog_baseline), 1,
prob = prog_baseline$prob), 1:3]}
} else if(bl == "grade"){
data <- age_grade
keys <- "age"
fun <- function(x){
if(x %in% age_grade$age){
probs <- age_grade[which(age_grade$age == x),][-1]
out <-sample(names(age_grade)[-1], 1, prob = probs)
out <- convert_grade(out)
return(out)
} else{
return(NA)
}
}
} else{
stop("Baseline not currently defined. Maybe you can write your own?")
}
return(list(data = data, keys = keys, fun = fun))
}
If this is included in an R package, R CMD CHECK says:
get_baseline: multiple local function definitions for 'fun' with
different formal arguments
I am doing this on R 3.3.3, but this seems to have been around well before. Is there a better pattern for assigning FUN conditionally? Or is this one of those notes to just live with?
I know about methods(), which returns all methods for a given class. Suppose I have x and I want to know what method will be called when I call foo(x). Is there a oneliner or package that will do this?
The shortest I can think of is:
sapply(class(x), function(y) try(getS3method('foo', y), silent = TRUE))
and then to check the class of the results... but is there not a builtin for this?
Update
The full one liner would be:
fm <- function (x, method) {
cls <- c(class(x), 'default')
results <- lapply(cls, function(y) try(getS3method(method, y), silent = TRUE))
Find(function (x) class(x) != 'try-error', results)
}
This will work with most things but be aware that it might fail with some complex objects. For example, according to ?S3Methods, calling foo on matrix(1:4, 2, 2) would try foo.matrix, then foo.numeric, then foo.default; whereas this code will just look for foo.matrix and foo.default.
findMethod defined below is not a one-liner but its body has only 4 lines of code (and if we required that the generic be passed as a character string it could be reduced to 3 lines of code). It will return a character string representing the name of the method that would be dispatched by the input generic given that generic and its arguments. (Replace the last line of the body of findMethod with get(X(...)) if you want to return the method itself instead.) Internally it creates a generic X and an X method corresponding to each method of the input generic such that each X method returns the name of the method of the input generic that would be run. The X generic and its methods are all created within the findMethod function so they disappear when findMethod exits. To get the result we just run X with the input argument(s) as the final line of the findMethod function body.
findMethod <- function(generic, ...) {
ch <- deparse(substitute(generic))
f <- X <- function(x, ...) UseMethod("X")
for(m in methods(ch)) assign(sub(ch, "X", m, fixed = TRUE), "body<-"(f, value = m))
X(...)
}
Now test it. (Note that the one-liner in the question fails with an error in several of these tests but findMethod gives the expected result.)
findMethod(as.ts, iris)
## [1] "as.ts.default"
findMethod(print, iris)
## [1] "print.data.frame"
findMethod(print, Sys.time())
## [1] "print.POSIXct"
findMethod(print, 22)
## [1] "print.default"
# in this example it looks at 2nd component of class vector as no print.ordered exists
class(ordered(3))
## [1] "ordered" "factor"
findMethod(print, ordered(3))
## [1] "print.factor"
findMethod(`[`, BOD, 1:2, "Time")
## [1] "[.data.frame"
I use this:
s3_method <- function(generic, class, env = parent.frame()) {
fn <- get(generic, envir = env)
ns <- asNamespace(topenv(fn))
tbl <- ns$.__S3MethodsTable__.
for (c in class) {
name <- paste0(generic, ".", c)
if (exists(name, envir = tbl, inherits = FALSE)) {
return(get(name, envir = tbl))
}
if (exists(name, envir = globalenv(), inherits = FALSE)) {
return(get(name, envir = globalenv()))
}
}
NULL
}
For simplicity this doesn't return methods defined by assignment in the calling environment. The global environment is checked for convenience during development. These are the same rules used in r-lib packages.