[R] Dots argument in apply method

[Christophe Pouzat]

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