Anyone know if the following can be achieved in R specifically S4
foo <- setClass("foo", contains = "matrix")
foo <- function(m = matrix(1:9, nrow = 3)) new("foo", m)
setMethod("dim", signature = "foo",
function(x) {
dd <- dim(x#.Data)
cat("foo dims: ")
return(dd)
}
)
# followed by
bar <- foo()
How or can it be achieved to distinguish between ...
dim(bar)
# which gives
foo dims: [1] 3 3
# and calling dim to assign the return value to a variable
# ie this call
bardims <- dim(bar)
# which does
foo dims:
# but I don't want it to produce any cat output to the console/screen
in the second case I would like to suppress the cat(....) part of the original "dim,foo-method".
I would not mind defining something like setMethod('<-dim', 'foo', function(.... but I guess that is not available?
Info: I am using R-4.0.5 here
It's generally not a great idea to use cat() to spit out messages in function. It gives users very little control over how they display and makes it very difficult to grab those values should they ever want them.
A possible alternative is to annotate the response with a custom class that will output a message only when print()-ed. Hence it will not show up during assignment because those results are returned invisibly.
Here's an S3 class that can help
annotate_value <- function(val, msg) {
attr(val, "message") <- msg
class(val) <- c("annotated", class(val))
val
}
print.annotated <- function(x) {
class(x) <- setdiff(class(x), "annotated")
cat(attr(x, "message"))
attr(x, "message") <- NULL
print(x)
}
And then you use it like
setMethod("dim", signature = "foo",
function(x) {
dd <- dim(x#.Data)
annotate_value(dd, "foo dims:")
}
)
Then when you run your code, you get the desired output
bar <- foo()
dim(bar)
# foo dims:[1] 3 3
bardims <- dim(bar)
#
Related
Consider the following function foo
foo <- function(x) {
print(x)
message("test message")
}
I'd like to deliver the message after the result of the function so that if the result is long I don't have to scroll up to see if there was an important message (or change my max.print option). The issue is when I want to assign the result without printing the actual result.
Is there a way to print the result of the function, followed by the message, but also so that when I assign the result nothing at all is printed? Ideally, I'd like to avoid the use of print altogether.
The desired result without assignment is
> foo(5)
# [1] 5
# test message
The desired result with assignment is
> bar <- suppressMessages(foo(5))
> bar
# [1] 5
You can achieve this by creating a class for your foo function, e.g. bar, and then creating a print method for this new class.
For example:
foo <- function(x) {
class(x) <- c("bar", class(x))
x
}
print.bar <- function(x, message=TRUE, ...){
class(x) <- setdiff("bar", class(x))
NextMethod(x)
if(message) message("test message")
}
Now try it:
foo(5)
[1] 5
test message
With assignment:
x <- foo(5)
x
[1] 5
test message
Some other ways of interacting with the print method:
print(x, message=FALSE)
[1] 5
suppressMessages(print(x))
[1] 5
For example, suppose I would like to be able to define a function that returned the name of the assignment variable concatenated with the first argument:
a <- add_str("b")
a
# "ab"
The function in the example above would look something like this:
add_str <- function(x) {
arg0 <- as.list(match.call())[[1]]
return(paste0(arg0, x))
}
but where the arg0 line of the function is replaced by a line that will get the name of the variable being assigned ("a") rather than the name of the function.
I've tried messing around with match.call and sys.call, but I can't get it to work. The idea here is that the assignment operator is being called on the variable and the function result, so that should be the parent call of the function call.
I think that it's not strictly possible, as other solutions explained, and the reasonable alternative is probably Yosi's answer.
However we can have fun with some ideas, starting simple and getting crazier gradually.
1 - define an infix operator that looks similar
`%<-add_str%` <- function(e1, e2) {
e2_ <- e2
e1_ <- as.character(substitute(e1))
eval.parent(substitute(e1 <- paste0(e1_,e2_)))
}
a %<-add_str% "b"
a
# "ab"
2 - Redefine := so that it makes available the name of the lhs to the rhs through a ..lhs() function
I think it's my favourite option :
`:=` <- function(lhs,rhs){
lhs_name <- as.character(substitute(lhs))
assign(lhs_name,eval(substitute(rhs)), envir = parent.frame())
lhs
}
..lhs <- function(){
eval.parent(quote(lhs_name),2)
}
add_str <- function(x){
res <- paste0(..lhs(),x)
res
}
a := add_str("b")
a
# [1] "ab"
There might be a way to redefine <- based on this, but I couldn't figure it out due to recursion issues.
3 - Use memory address dark magic to hunt lhs (if it exists)
This comes straight from: Get name of x when defining `(<-` operator
We'll need to change a bit the syntax and define the function fetch_name for this purpose, which is able to get the name of the rhs from a *<- function, where as.character(substitute(lhs)) would return "*tmp*".
fetch_name <- function(x,env = parent.frame(2)) {
all_addresses <- sapply(ls(env), pryr:::address2, env)
all_addresses <- all_addresses[names(all_addresses) != "*tmp*"]
all_addresses_short <- gsub("(^|<)[0x]*(.*?)(>|$)","\\2",all_addresses)
x_address <- tracemem(x)
untracemem(x)
x_address_short <- tolower(gsub("(^|<)[0x]*(.*?)(>|$)","\\2",x_address))
ind <- match(x_address_short, all_addresses_short)
x_name <- names(all_addresses)[ind]
x_name
}
`add_str<-` <- function(x,value){
x_name <- fetch_name(x)
paste0(x_name,value)
}
a <- NA
add_str(a) <- "b"
a
4- a variant of the latter, using .Last.value :
add_str <- function(value){
x_name <- fetch_name(.Last.value)
assign(x_name,paste0(x_name,value),envir = parent.frame())
paste0(x_name,value)
}
a <- NA;add_str("b")
a
# [1] "ab"
Operations don't need to be on the same line, but they need to follow each other.
5 - Again a variant, using a print method hack
Extremely dirty and convoluted, to please the tortured spirits and troll the others.
This is the only one that really gives the expected output, but it works only in interactive mode.
The trick is that instead of doing all the work in the first operation I also use the second (printing). So in the first step I return an object whose value is "b", but I also assigned a class "weird" to it and a printing method, the printing method then modifies the object's value, resets its class, and destroys itself.
add_str <- function(x){
class(x) <- "weird"
assign("print.weird", function(x) {
env <- parent.frame(2)
x_name <- fetch_name(x, env)
assign(x_name,paste0(x_name,unclass(x)),envir = env)
rm(print.weird,envir = env)
print(paste0(x_name,x))
},envir = parent.frame())
x
}
a <- add_str("b")
a
# [1] "ab"
(a <- add_str("b") will have the same effect as both lines above. print(a <- add_str("b")) would also have the same effect but would work in non interactive code, as well.
This is generally not possible because the operator <- is actually parsed to a call of the <- function:
rapply(as.list(quote(a <- add_str("b"))),
function(x) if (!is.symbol(x)) as.list(x) else x,
how = "list")
#[[1]]
#`<-`
#
#[[2]]
#a
#
#[[3]]
#[[3]][[1]]
#add_str
#
#[[3]][[2]]
#[1] "b"
Now, you can access earlier calls on the call stack by passing negative numbers to sys.call, e.g.,
foo <- function() {
inner <- sys.call()
outer <- sys.call(-1)
list(inner, outer)
}
print(foo())
#[[1]]
#foo()
#[[2]]
#print(foo())
However, help("sys.call") says this (emphasis mine):
Strictly, sys.parent and parent.frame refer to the context of the
parent interpreted function. So internal functions (which may or may
not set contexts and so may or may not appear on the call stack) may
not be counted, and S3 methods can also do surprising things.
<- is such an "internal function":
`<-`
#.Primitive("<-")
`<-`(x, foo())
x
#[[1]]
#foo()
#
#[[2]]
#NULL
As Roland pointed, the <- is outside of the scope of your function and could only be located looking at the stack of function calls, but this fail. So a possible solution could be to redefine the '<-' else than as a primitive or, better, to define something that does the same job and additional things too.
I don't know if the ideas behind following code can fit your needs, but you can define a "verbose assignation" :
`:=` <- function (var, value)
{
call = as.list(match.call())
message(sprintf("Assigning %s to %s.\n",deparse(call$value),deparse(call$var)))
eval(substitute(var <<- value))
return(invisible(value))
}
x := 1:10
# Assigning 1:10 to x.
x
# [1] 1 2 3 4 5 6 7 8 9 10
And it works in some other situation where the '<-' is not really an assignation :
y <- data.frame(c=1:3)
colnames(y) := "b"
# Assigning "b" to colnames(y).
y
# b
#1 1
#2 2
#3 3
z <- 1:4
dim(z) := c(2,2)
#Assigning c(2, 2) to dim(z).
z
# [,1] [,2]
#[1,] 1 3
#[2,] 2 4
>
I don't think the function has access to the variable it is being assigned to. It is outside of the function scope and you do not pass any pointer to it or specify it in any way. If you were to specify it as a parameter, you could do something like this:
add_str <- function(x, y) {
arg0 <-deparse(substitute(x))
return(paste0(arg0, y))
}
a <- 5
add_str(a, 'b')
#"ab"
I want to define (<- and access the name of the left hand side argument :
*<- functions use internally an intermediate '*tmp*' variable. Is it still possible to get the name of x ?
`(<-` <- function(x,value){
print(deparse(substitute(value)))
print(deparse(substitute(x)))
print(match.call())
value
}
foo <- 0
(foo) <- 3
# [1] "3"
# [1] "*tmp*"
# `(<-`(x = `*tmp*`, value = 3)# [1] "3"
I want to get "foo" from inside the function.
I tried to hack it by using tracemem, i.e. calling sapply(ls(envir = parent.frame()),tracemem) and tracemem(x) inside of the functions but the address of foo, *temp* and x are all different.
I hacked it, though I didn't understand everything that I did.
I noticed pryr::address was giving a different kind of results than tracemem and tried it (I had to dig into the code to use pryr:::address2 because pryr::address doesn't have an environment argument).
Then I noticed that mixing the results from tracemem on x and pryr:::address2 on the rest of the objects there was a match (after basic reformatting) :
`(<-` <- function(x,value){
pf <- parent.frame()
all_addresses <- sapply(ls(pf), pryr:::address2, pf)
all_addresses <- all_addresses[names(all_addresses) != "*tmp*"]
all_addresses_short <- gsub("(^|<)[0x]*(.*?)(>|$)","\\2",all_addresses)
x_address <- tracemem(x)
x_address_short <- tolower(gsub("(^|<)[0x]*(.*?)(>|$)","\\2",x_address))
ind <- match(x_address_short, all_addresses_short)
x_name <- names(all_addresses)[ind]
message("all_addresses, using pryr::address2")
print(all_addresses)
print(all_addresses_short)
message("x_address, using tracemem")
print(x_address)
print(x_address_short)
message("x_name, matching substrings")
print(x_name)
value
}
The regex used in gsub calls tries to account for the address formats we get with different systems, I'm not 100% sure that it's general.
output:
foo <- 1
bar <- 2
(foo) <- foo
# all_addresses, using pryr::address2
# (<- bar foo
# "0x1433df50" "0x14937678" "0x14937708"
# (<- bar foo
# "1433df50" "14937678" "14937708"
# x_address, using tracemem
# [1] "<0000000014937708>"
# [1] "14937708"
# x_name, matching substrings
# [1] "foo"
It breaks if x is not a variable name, for example:
foo <- iris
(foo$species) <- 3
We could assume that if the address isn't found x is a list item, and then lookup its address among the addresses of the items of all the lists we have in the parent.frame (recursively), but I think that's enough ugly hacks for today.
1) If you are willing to change it so that the call is:
fooify[foo] <- 99
then we can do it like this where foo need not exist beforehand:
fooify <- structure(NA, class = "fooify")
"[<-.fooify" <- function(x, var, value) {
print(deparse(substitute(var)))
eval.parent(substitute(var <- value))
x
}
# test
if (exists("foo")) rm(foo)
fooify[foo] <- 99
## [1] "foo" <-- this comes from the print statement
foo
## [1] 99
2) := If using := is ok then:
`:=` <- function(lhs, rhs) {
print(deparse(substitute(lhs)))
eval.parent(substitute(lhs <- rhs))
}
# test
if (exists("foo")) rm(foo)
foo := 99
## [1] foo <-- this comes from print statement
foo
## [1] 99
I have defined an S3 class in R that needs its own print method. When I create a list of these objects and print it, R uses my print method for each element of the list, as it should.
I would like to have some control over how much the print method actually shows. Therefore, the print method for my class takes a few additional arguments. However, I have not found a way to make use of these arguments, when printing a list of objects.
To make this more clear, I give an example. The following code defines two objects of class test, a list that contains both objects and a print method for the class:
obj1 <- list(a = 3, b = 2)
class(obj1) <- "test"
obj2 <- list(a = 1, b = 5)
class(obj2) <- "test"
obj_list <- list(obj1, obj2)
print.test <- function(x, show_b = FALSE, ...) {
cat("a is", x$a, "\n")
if (show_b) cat("b is", x$b, "\n")
}
Printing a single object works as expected:
print(obj1)
## a is 3
print(obj2, show_b = TRUE)
## a is 1
## b is 5
When I print obj_list, my print method is used to print each object in the list:
print(obj_list)
## [[1]]
## a is 3
##
## [[2]]
## a is 1
But I would like to be able to tell print() to show b also in this situation. The following (a bit naive...) code does not produce the desired result:
print(obj_list, show_b = TRUE)
## [[1]]
## a is 3
##
## [[2]]
## a is 1
Is it possible to print obj_list and at the same time pass the argument show_b = TRUE to print.test()? How?
Following Josh's suggestion, I found a way to avoid print.default() being called when printing a list. I simply wrote a print method for lists, since none seems to exist as part of base R:
print.list <- function(x, ...) {
list_names <- names(x)
if (is.null(list_names)) list_names <- rep("", length(x))
print_listelement <- function(i) {
if (list_names[i]=="") {
cat("[[",i,"]]\n", sep="")
} else {
cat("$", list_names[i], "\n", sep="")
}
print(x[[i]], ...)
cat("\n")
}
invisible(lapply(seq_along(x), print_listelement))
}
The relevant part is that ... is passed on to print, when the objects inside the list are printed. So now, coming back to the example in the question, printing a list of test objects works together with show_b =TRUE:
print(obj_list, show_b = TRUE)
## [[1]]
## a is 3
## b is 2
##
## [[2]]
## a is 1
## b is 5
However, I am a bit uncomfortable with defining print.list myself. Chances are that it is not working as well as the built-in printing mechanism for lists.
Consider the following function foo
foo <- function(x) {
print(x)
message("test message")
}
I'd like to deliver the message after the result of the function so that if the result is long I don't have to scroll up to see if there was an important message (or change my max.print option). The issue is when I want to assign the result without printing the actual result.
Is there a way to print the result of the function, followed by the message, but also so that when I assign the result nothing at all is printed? Ideally, I'd like to avoid the use of print altogether.
The desired result without assignment is
> foo(5)
# [1] 5
# test message
The desired result with assignment is
> bar <- suppressMessages(foo(5))
> bar
# [1] 5
You can achieve this by creating a class for your foo function, e.g. bar, and then creating a print method for this new class.
For example:
foo <- function(x) {
class(x) <- c("bar", class(x))
x
}
print.bar <- function(x, message=TRUE, ...){
class(x) <- setdiff("bar", class(x))
NextMethod(x)
if(message) message("test message")
}
Now try it:
foo(5)
[1] 5
test message
With assignment:
x <- foo(5)
x
[1] 5
test message
Some other ways of interacting with the print method:
print(x, message=FALSE)
[1] 5
suppressMessages(print(x))
[1] 5