Based on this question Link data.frame and matrix (Accepted answer), I tried to add dim to S3 class with this command:
dim.JoinedUp <- function(x)
{
print(paste(dim(x$data_frame), dim(x$matrix)))
}
This function worked but there is a problem with rownames:
rownames.JoinedUp <- function(x)
{
print(rownames(x$data_frame))
}
I get the dim results when I type rownames(new_obj).
That is because rownames isn't an S3 method. See the definition of rownames:
function (x, do.NULL = TRUE, prefix = "row")
{
dn <- dimnames(x)
if (!is.null(dn[[1L]]))
dn[[1L]]
else {
nr <- NROW(x)
if (do.NULL)
NULL
else if (nr > 0L)
paste0(prefix, seq_len(nr))
else character()
}
}
<bytecode: 0x3d0f2b0>
<environment: namespace:base>
It calls dimnames, so you will have to create an method dimnames for your class. Something like:
dimnames.JoinedUp <- function(x) {
dimnames(x$data_frame)
}
Related
I defined some S4 matrices, whose class is lazyMatrix. If M is such a matrix, I want to define M[2, ] as the second row of M, and M[2] as the second coefficient of M (when enumerating the coefficients column after column).
So I defined these two S4 methods:
setMethod( # to extract a coefficient
"[",
signature("lazyMatrix", i = "numeric"),
function(x, i) {
......
}
)
setMethod( # to extract a row
"[",
signature("lazyMatrix", i = "numeric", j = "missing", drop = "ANY"),
function(x, i, j, drop) {
......
}
)
But both M[2, ] and M[2] return the second row of M. I tried to exchange the order of the two method definitions, that does not change anything.
I found a solution in the source code of the onion package:
setMethod(
"[",
signature("lazyMatrix", i = "numeric", j = "missing", drop = "missing"),
function(x, i, j, ..., drop) {
n_args <- nargs()
if(n_args == 3L) { # M[i, ]
......
} else if(n_args == 2L) { # M[i]
......
} else {
stop("Invalid arguments in subsetting.")
}
}
)
setMethod(
"[",
signature("lazyMatrix", i = "numeric", j = "missing", drop = "ANY"),
function(x, i, j, ..., drop) {
n_args <- nargs()
if(n_args == 4L) { # M[i, ]
......
} else if(n_args == 3L) { # M[i]
......
} else {
stop("Invalid arguments in subsetting.")
}
}
)
Before finding this solution, I tried using nargs() in my attempts, unsuccessfully. The trick is to add the ... argument. But I don't understand how this works. Please leave another answer or a comment if you can explain.
The dispatch issue has nothing to do with the dots, though it is problematic that the formal arguments of your methods do not match those of the generic function:
> getGeneric("[")
standardGeneric for "[" defined from package "base"
function (x, i, j, ..., drop = TRUE)
standardGeneric("[", .Primitive("["))
<bytecode: 0x1403d1a28>
<environment: 0x1403c9d10>
Methods may be defined for arguments: x, i, j, drop
Use showMethods([) for currently available ones.
?setMethod is quite clear about that:
The definition must be a function with the same formal arguments as the generic; however, setMethod() will handle methods that add arguments, if ... is a formal argument to the generic. See the Details section.
Anyway, the real issue is that setMethod interprets your first signature
signature("lazyMatrix", i = "numeric")
as
signature("lazyMatrix", i = "numeric", j = "ANY", drop = "ANY")
and both of the calls M[2] and M[2, ] match your second signature
signature("lazyMatrix", i = "numeric", j = "missing", drop = "ANY")
more closely than the first (because "missing" is more specific than "ANY"). Hence dispatch in both cases favours the second method.
It is still true that the primitive function [ is the trickiest generic function out there, due to all of the special cases handled in C code for traditional matrices (of implicit class matrix). The nargs() approach is correct and also used by package Matrix, which is really the canonical reference for this kind of thing:
> library(Matrix)
> selectMethod("[", signature = c("Matrix", "numeric", "missing", "missing"))
Method Definition:
function (x, i, j, ..., drop = TRUE)
{
Matrix.msg("M[i,m,m] : nargs()=", nargs(), .M.level = 2)
if (nargs() == 2) {
.M.vectorSub(x, i)
}
else {
callGeneric(x, i = i, , drop = TRUE)
}
}
<bytecode: 0x128e94a90>
<environment: namespace:Matrix>
Signatures:
x i j drop
target "Matrix" "numeric" "missing" "missing"
defined "Matrix" "index" "missing" "missing"
I am studying Advanced R from Hadley and he shows the example below:
new_secret <- function(x = double()) {
stopifnot(is.double(x))
structure(x, class = "secret")
}
print.secret <- function(x, ...) {
print(strrep("x", nchar(x)))
invisible(x)
}
that's when he tries to create a [.secret method:
`[.secret` <- function(x, i) {
new_secret(x[i])
}
Could someone explain to me why this method, when called, goes into a loop?
x <- new_secret(c(15, 1, 456))
x[1]
I am having problems how to make the following code work. In particular what should I have in the place of '???' to obtain the result c(4,7,1)
letter<- function()
{
x<- numeric(0)
class(x)<- append(class(x), "letter")
return(x)
}
a<- function()
{
obj<- letter()
class(obj)<- append(class(obj),"a")
return(obj)
}
aa<- function()
{
obj<- a()
class(obj)<- append(class(obj),"aa")
return(obj)
}
met<- function(obj, ...)
{
UseMethod("met", obj)
}
met.letter<- function(obj, ???)
{
NextMethod(???)
}
met.a<- function(obj, ???)
{
x<-4
z<-1
NextMethod(???)
}
met.aa<- function(obj, ???)
{
y=y+1
return(c(x,y,z))
}
aaobj<- aa()
met(aaobj, y=6)
# to return c(4,7,1)
I can not understand how to pass arguments to the next method, when they are created in the current method, and I don't want to pass these arguments to the call to the method.
Here is an OO-alike version of your code with "log output" to indicate how it works:
# Class Hierarchy:
# AA inherits from A inherits from letter (= base class)
# Constructors ---------------------------------------------
letter <- function()
{
x <- numeric(0) # this shall be an class attribute
class(x) <- append("letter", class(x))
return(x)
}
a <- function() # class "a" inherits from class "letter"
{
obj <- letter()
class(obj) <- append("a", class(obj)) # attach the specialized class first!
return(obj)
}
aa <- function() # class "aa" inherits from class "a"
{
obj <- a()
class(obj) <- append("aa", class(obj))
return(obj)
}
# Class methods -------------------------------------------
# This is a function in the base class "letter" that is inherited in the sub classes
# so that every sub class can provide its own implementation (polymorphism).
# To register such a generic function (= function call dispatching to class-specific functions/methods)
# "UseMethod" is called
met <- function(obj, x) # met = method?!
{
UseMethod("met", obj) # "dispatch": Call the first existing function of pattern "met.<class>"
# Code after this line will never be executed due to calling "UseMethod"
print("met")
}
met.aa <- function(obj, x)
{
print("met.aa - starting")
x = x + 1
NextMethod("met", obj) # as last code in the function: Returns the return value of this function!
# Do not add code after "NextMethod" or you will get the output of this code as return value
# instead of the return value of NextMethod!
# print("met.aa - leaving")
}
met.a <- function(obj, x)
{
print("met.a - starting")
x <- c(4, x, 1)
res <- NextMethod("met", obj) # , c(4, x, 1))
print("met.a - leaving") #
return(res)
}
met.letter<- function(obj, x) # x may be a vector!
{
print("met.letter starting")
# "append" looses the attributes (class!) so we reassign it
# a() should better return a list with one vector element as "class attribute"
# so that the attributes keep untouched if changing the "class attribute"
old.classes <- class(obj)
obj <- append(obj, x)
class(obj) <- old.classes
# no NextMethod() call - it is the base class (= root!)
return(obj)
}
met.default <- function(obj, x) {
warning("met.default: not implemented")
}
aaobj <- aa()
aaobj
# numeric(0)
# attr(,"class")
# [1] "aa" "a" "letter" "numeric"
aaobj <- met(aaobj, 6)
aaobj
# [1] 4 7 1
Note: You should put your class name at the beginning (not the end) of the class attribute so that if you call a generic method the most specialized class method will be found and called first.
For details see http://www.stackoverflow.com/q/45175988
I have a generic function like this:
convert <- function(x) UseMethod("simplifyResultConvert")
convert.default <- function(x) {
x
}
convert.POSIXct <- function(x) {
as.character(x)
}
convert.factor <- function(x) {
as.character(x)
}
convert.Date <- function(x) {
as.character(x)
}
Is there any way to simplify it by making one generic for type: POSIXct, Date and factor?
To make it clear: I need something like:
convert.(POSIXct || factor || date) <- funciton(x) {as.character(x)}
Write it like this:
convert.default <- function(x) x
convert.Date <-
convert.factor <-
convert.POSIXct <- function(x) as.character(x)
A further simplification would be:
convert.default <- identity
convert.Date <-
convert.factor <-
convert.POSIXct <- as.character
You can put a test of the class in the default method, for example:
convert.default <- function(x) {
if (inherits(x, "POSIXct") ||
inherits(x, "factor") ||
inherits(x, "Date"))
as.character(x)
else
x
}
This is not quite the same as what you want, because an object could have class c("POSIXct", "other") and if there was a convert.other() method set, it would be called instead of the default.
If you really want the behaviour you asked for, you need the three functions, but you can save a bit of typing by using
convert.Date <- convert.factor <- convert.POSIXct <- function(x) {
as.character(x)
}
Since there are no super-classes in S3, this is not possible with S3. However, you can easily do this with S4 which allows defining super-classes:
setGeneric("convert", function(object) {
standardGeneric("convert")
})
setClassUnion("fooClasses", members = c("factor", "Date", "POSIXt")) #POSIXt is a super-class
setMethod("convert", signature(object = "fooClasses"), function(object) {
as.character(object)
})
class(convert(as.Date("2010-10-10")))
#[1] "character"
class(convert(as.POSIXct("2010-10-10")))
#[1] "character"
How do I partially bind/apply arguments to a function in R?
This is how far I got, then I realized that this approach doesn't work...
bind <- function(fun,...)
{
argNames <- names(formals(fun))
bindedArgs <- list(...)
bindedNames <- names(bindedArgs)
function(argNames[!argNames %in% bindedArgs])
{
#TODO
}
}
Thanks!
Here's a version of Curry that both preserves lazy evaluation of function argument, but constructs a function that prints moderately nicely:
Curry <- function(FUN, ...) {
args <- match.call(expand.dots = FALSE)$...
args$... <- as.name("...")
env <- new.env(parent = parent.frame())
if (is.name(FUN)) {
fname <- FUN
} else if (is.character(FUN)) {
fname <- as.name(FUN)
} else if (is.function(FUN)){
fname <- as.name("FUN")
env$FUN <- FUN
} else {
stop("FUN not function or name of function")
}
curry_call <- as.call(c(list(fname), args))
f <- eval(call("function", as.pairlist(alist(... = )), curry_call))
environment(f) <- env
f
}
It basically works by generating an anonymous function in exactly the same way you would if you were constructing the partial binding yourself.
Actually, this seems to work as a work around
bind <- function(fun,...)
{
boundArgs <- list(...)
formals(fun)[names(boundArgs)] <- boundArgs
fun
}
However, ideally I want the bound arguments to disappear completely from the new function so that calls to the new function can happen with name specification, e.g. with add <- function(a,b) a+b I would like (bind(add,a=2))(1) to return 3.
Have you tried looking at roxygen's Curry function?
> library(roxygen)
> Curry
function (FUN, ...)
{
.orig = list(...)
function(...) do.call(FUN, c(.orig, list(...)))
}
<environment: namespace:roxygen>
Example usage:
> aplusb <- function(a,b) {
+ a + 2*b
+ }
> oneplusb <- Curry(aplusb,1)
> oneplusb(2)
[1] 5
Edit:
Curry is concisely defined to accept named or unnamed arguments, but partial application of fun to arguments by way of formal() assignment requires more sophisticated matching to emulate the same functionality. For instance:
> bind <- function(fun,...)
+ {
+ argNames <- names(formals(fun))
+ boundArgs <- list(...)
+ boundNames <- names(boundArgs)
+ if(is.null(boundNames)) {
+ formals(fun)[1:length(boundArgs)] <- boundArgs
+ } else {
+ formals(fun)[match(names(boundArgs),argNames)] <- boundArgs
+ }
+ fun
+ }
> oneplusb <- bind(aplusb,1)
> oneplusb(2)
Error in 2 * b : 'b' is missing
Because the first argument in this function is still a, you need to specify which argument 2 is intended for (b=), or pass it as the second argument.
> oneplusb
function (a = 1, b)
{
a + 2 * b
}
> oneplusb(b=2) ## or oneplusb(,2)
[1] 5