Joshua Ulrich's pivot() function for R

pivot.R

## Joshua Ulrich's pivot function
## This code is alpha and is in development. 
## please test all results to ensure accuracy 

pivot <- function(x, rows, cols, FUN=NULL) {
   clean <- function(xx, dd) {
     cd <- merge(dd,xx,by=0,all=TRUE)
     rownames(cd) <- cd$Row.names
     cd$Row.names <- NULL
     return(cd)
   }

   cellFun <- function(xx) {
     splitVars <- lapply(cols, function(cVar) paste(cVar,xx[,cVar],sep="_"))
     splitFactors <- interaction( splitVars, sep="__" )
     cellSplit <- split(xx, splitFactors, drop=TRUE)
     out <- do.call(rbind, lapply( cellSplit, FUN ))
     return(out)
   }

   splitFactors <- function(Vars, Data) {
     sv <- lapply(Vars, function(var) paste(var,Data[,var],sep="_"))
     sf <- interaction(sv, sep="__")
   }

   dd <- data.frame(row.names=levels(splitFactors(cols, x)))

   bar <- split(x, splitFactors(rows, x), drop=TRUE)
   bar <- lapply(bar, cellFun)
   bar <- lapply(bar, clean, dd=dd)
   bar <- lapply(bar, t)  # put multi-column values from user's function into rows
   for(nam in names(bar)) rownames(bar[[nam]]) <- paste(nam,rownames(bar[[nam]]),sep="_")
   bar <- do.call(rbind, bar)
   return(bar)
}

# The obligatory example:
myFun <- function(x) c(Wind=mean(x$Wind,na.rm=TRUE))
pivot(airquality, "Day", "Month", FUN=myFun)