[R] Dots argument in apply method

From: Christophe Pouzat <christophe.pouzat_at_univ-paris5.fr>
Date: Wed 07 Dec 2005 - 23:37:34 EST


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@Data)
  ## make sure to detach it at the end
  on.exit(detach(obj@Data))
  ## get the variable names
  variableNames <- names(obj@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@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
Received on Wed Dec 07 23:49:46 2005

This archive was generated by hypermail 2.1.8 : Fri 03 Mar 2006 - 03:41:30 EST