Hello everyone,
I'm working on a package using S4 classes and methods and I ran into the
following "problem" when I tried to create an "apply" method
for objects
of one of my new classes. I've found a way around the problem but I
wonder if I did not paint myself into the corner. I'd like your opinion
about that.
So I have an object "myObj" of class "myClass". I define a
new function
".apply.myClass" which is a "myClass" specific version of
"apply". The
trick is that I would like to have an additional formal argument in
.apply.myClass compared to apply. More precisely we have:
apply(X, MARGIN, FUN, ...)
and I want:
.apply.myClass(x, margin, fun, groups = NULL, ...)
As long as I stay at the function level there is no problem. Life
becomes harder when I want to define an "apply" method for myClass
objects, method which should call .apply.myClass.
The formal argument "groups" in the myClass specific apply method will
have to be passed in the dots argument, together with the "FUN"
specific
arguments. Then if the "groups" argument is provided it will have to
be
extracted and the remaining dots argument(s), if any, will have to be
passed as such to .apply.myClass. Here is the way I did it:
## Start by setting a generic apply method
if (!isGeneric("apply"))
setGeneric("apply", function(X, MARGIN, FUN, ...)
standardGeneric("apply"))
## set apply method for myClass objects
setMethod("apply",
signature(X = "myClass",
MARGIN = "numeric",
FUN = "function"),
function(X, MARGIN, FUN, ...) {
.call <- match.call(.apply.myClass)
if (is.null(.call$groups)) myGroups <- NULL
else myGroups <- .call$groups
argList <- list(obj = .call$obj,
margin = .call$margin,
fun = .call$fun,
groups = myGroups
)
if(!all(names(.call)[-1] %in% names(formals(.apply.myClass)))) {
## Some dots arguments have been provided
otherNames <- (names(.call)[-1])[!(names(.call)[-1] %in%
names(formals(.apply.myClass)))]
remainingDots <- lapply(otherNames, function(i) .call[[i]])
names(remainingDots) <- otherNames
argList <- c(argList,remainingDots)
}
do.call(.apply.myClass, args = argList)
}
)
Does anyone have a quicker solution?
Thanks in advance,
Christophe.
PS: If you want a full example with actual class and .apply.myClass
definitions, here is one:
## define class myClass
setClass("myClass", representation(Data = "data.frame",
timeRange =
"numeric"))
## create myObj an instantiation of myClass
myObj <- new("myClass",
Data = data.frame(Time = sort(runif(10)),
observation = I(matrix(rnorm(20),nrow=10,ncol=2)),
label = factor(rep(1:2,5),levels = 1:2, labels = c("cat.
1", "cat. 2"))
),
timeRange = c(0,1)
)
## create function .apply.myClass for myClass objects
.apply.myClass <- function(obj, ## object of class myClass
margin, ## a numeric which should be 1 or 2
fun, ## a function
groups = NULL, ## should fun be applied in a
group
## specific manner?
... ## additional arguments passed to fun
) {
## attach the data frame contained in obj
attach(obj at Data)
## make sure to detach it at the end
on.exit(detach(obj at Data))
## get the variable names
variableNames <- names(obj at Data)
## check that one variable is named "observation"
if (!("observation" %in% variableNames))
stop(paste("The slot Data of",
deparse(substitute(obj)),
"does not contain an observation variable as it
should."
)
)
if (margin == 1) {
## in that case we don't care of the group
myResult <- apply(observation, 1, fun, ...)
return(myResult)
} else if (margin == 2) {
if (is.null(groups)) {
## no groups defined
myResult <- apply(observation, 2, fun, ...)
return(myResult)
} else {
## groups defined
groups <- eval(groups)
X <- levels(groups)
dim(X) <- c(1,length(X))
myResult <- apply(X,
2,
function(i) apply(observation[groups == i,],
2,
fun, ...)
)
return(myResult)
}
} else {
stop("margin should be set to 1 or 2.")
}
}
--
A Master Carpenter has many tools and is expert with most of them.If you
only know how to use a hammer, every problem starts to look like a nail.
Stay away from that trap.
Richard B Johnson.
--
Christophe Pouzat
Laboratoire de Physiologie Cerebrale
CNRS UMR 8118
UFR biomedicale de l'Universite Paris V
45, rue des Saints Peres
75006 PARIS
France
tel: +33 (0)1 42 86 38 28
fax: +33 (0)1 42 86 38 30
web: www.biomedicale.univ-paris5.fr/physcerv/C_Pouzat.html
Why does simply
setMethod("apply",
signature(X = "myClass",
MARGIN = "numeric",
FUN = "function"),
function(X, MARGIN, FUN, ...) .apply.myClass(X, MARGIN, FUN, ...))
not do what you want? It works for me in your example, e.g.
> apply(myObj, 2, sum, groups=myObj at Data$label)
gives exactly the same answer as your complicated solution.
I do wonder if you have misunderstood what '...' does.
I also wonder why you chose to overload a basic R function as an S4
generic like this. If you think that thereby existing calls to apply()
will go via your S4 methods then I fear you have overlooked the effects of
namespaces.
A simpler example
setClass("myClass", representation(tt="numeric"))
setMethod("lapply", signature(X="myClass"), function(X, FUN,
...) FUN(X at tt))
myObj <- new("myClass", tt=1:10)> lapply(myObj, sum)
[1] 55> sapply(myObj, sum)
list()
since sapply is calling base::lapply, not the lapply S4 generic.
On Wed, 7 Dec 2005, Christophe Pouzat wrote:
> Hello everyone,
>
> I'm working on a package using S4 classes and methods and I ran into
the
> following "problem" when I tried to create an "apply"
method for objects
> of one of my new classes. I've found a way around the problem but I
> wonder if I did not paint myself into the corner. I'd like your opinion
> about that.
>
> So I have an object "myObj" of class "myClass". I
define a new function
> ".apply.myClass" which is a "myClass" specific version
of "apply". The
> trick is that I would like to have an additional formal argument in
> .apply.myClass compared to apply. More precisely we have:
>
> apply(X, MARGIN, FUN, ...)
>
> and I want:
>
> .apply.myClass(x, margin, fun, groups = NULL, ...)
>
> As long as I stay at the function level there is no problem. Life
> becomes harder when I want to define an "apply" method for
myClass
> objects, method which should call .apply.myClass.
> The formal argument "groups" in the myClass specific apply method
will
> have to be passed in the dots argument, together with the "FUN"
specific
> arguments. Then if the "groups" argument is provided it will have
to be
> extracted and the remaining dots argument(s), if any, will have to be
> passed as such to .apply.myClass. Here is the way I did it:
>
> ## Start by setting a generic apply method
> if (!isGeneric("apply"))
> setGeneric("apply", function(X, MARGIN, FUN, ...)
> standardGeneric("apply"))
>
> ## set apply method for myClass objects
> setMethod("apply",
> signature(X = "myClass",
> MARGIN = "numeric",
> FUN = "function"),
> function(X, MARGIN, FUN, ...) {
> .call <- match.call(.apply.myClass)
>
> if (is.null(.call$groups)) myGroups <- NULL
> else myGroups <- .call$groups
>
> argList <- list(obj = .call$obj,
> margin = .call$margin,
> fun = .call$fun,
> groups = myGroups
> )
> if(!all(names(.call)[-1] %in% names(formals(.apply.myClass)))) {
> ## Some dots arguments have been provided
> otherNames <- (names(.call)[-1])[!(names(.call)[-1] %in%
> names(formals(.apply.myClass)))]
> remainingDots <- lapply(otherNames, function(i) .call[[i]])
> names(remainingDots) <- otherNames
> argList <- c(argList,remainingDots)
> }
> do.call(.apply.myClass, args = argList)
> }
> )
>
> Does anyone have a quicker solution?
>
> Thanks in advance,
>
> Christophe.
>
>
> PS: If you want a full example with actual class and .apply.myClass
> definitions, here is one:
>
> ## define class myClass
> setClass("myClass", representation(Data = "data.frame",
timeRange > "numeric"))
>
> ## create myObj an instantiation of myClass
> myObj <- new("myClass",
> Data = data.frame(Time = sort(runif(10)),
> observation = I(matrix(rnorm(20),nrow=10,ncol=2)),
> label = factor(rep(1:2,5),levels = 1:2, labels = c("cat.
> 1", "cat. 2"))
> ),
> timeRange = c(0,1)
> )
>
> ## create function .apply.myClass for myClass objects
> .apply.myClass <- function(obj, ## object of class myClass
> margin, ## a numeric which should be 1 or 2
> fun, ## a function
> groups = NULL, ## should fun be applied in a
> group
> ## specific manner?
> ... ## additional arguments passed to fun
> ) {
>
> ## attach the data frame contained in obj
> attach(obj at Data)
> ## make sure to detach it at the end
> on.exit(detach(obj at Data))
> ## get the variable names
> variableNames <- names(obj at Data)
> ## check that one variable is named "observation"
> if (!("observation" %in% variableNames))
> stop(paste("The slot Data of",
> deparse(substitute(obj)),
> "does not contain an observation variable as it
should."
> )
> )
>
> if (margin == 1) {
> ## in that case we don't care of the group
> myResult <- apply(observation, 1, fun, ...)
> return(myResult)
> } else if (margin == 2) {
> if (is.null(groups)) {
> ## no groups defined
> myResult <- apply(observation, 2, fun, ...)
> return(myResult)
> } else {
> ## groups defined
> groups <- eval(groups)
> X <- levels(groups)
> dim(X) <- c(1,length(X))
> myResult <- apply(X,
> 2,
> function(i) apply(observation[groups == i,],
> 2,
> fun, ...)
> )
> return(myResult)
> }
> } else {
> stop("margin should be set to 1 or 2.")
> }
>
> }
>
> --
> A Master Carpenter has many tools and is expert with most of them.If you
> only know how to use a hammer, every problem starts to look like a nail.
> Stay away from that trap.
> Richard B Johnson.
> --
>
> Christophe Pouzat
> Laboratoire de Physiologie Cerebrale
> CNRS UMR 8118
> UFR biomedicale de l'Universite Paris V
> 45, rue des Saints Peres
> 75006 PARIS
> France
>
> tel: +33 (0)1 42 86 38 28
> fax: +33 (0)1 42 86 38 30
> web: www.biomedicale.univ-paris5.fr/physcerv/C_Pouzat.html
>
> ______________________________________________
> R-help at stat.math.ethz.ch mailing list
> https://stat.ethz.ch/mailman/listinfo/r-help
> PLEASE do read the posting guide!
http://www.R-project.org/posting-guide.html
>
--
Brian D. Ripley, ripley at stats.ox.ac.uk
Professor of Applied Statistics, http://www.stats.ox.ac.uk/~ripley/
University of Oxford, Tel: +44 1865 272861 (self)
1 South Parks Road, +44 1865 272866 (PA)
Oxford OX1 3TG, UK Fax: +44 1865 272595