Dots argument in apply method

apply(myObj, 2, sum, groups=myObj at Data$label)

lapply(myObj, sum)

sapply(myObj, sum)

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