R-alpha: tapply

[Thomas Lumley]

tapply() has been broken for a long time and is still wrong in 50-a3.  I
think the following version works. 

	-thomas

"tapply" <-function (x, INDEX, FUN, ...) 
{
        if (is.character(FUN)) 
                FUN <- get(FUN, mode = "function")
        if (mode(FUN) != "function") 
                stop(paste("\"", FUN, "\" is not a function"))
        if (!is.list(INDEX)) 
                INDEX <- list(INDEX)
        namelist <- vector("list", length(INDEX))
        extent <- integer(length(INDEX))
        nx <- length(x)
        group <- rep(1, nx)
        ngroup <- 1
        for (i in seq(INDEX)) {
                index <- as.factor(INDEX[[i]])
                if (length(index) != nx) 
                        stop("arguments must have same length")
                namelist[[i]] <- levels(index)
                extent[[i]] <- nlevels(index)
                group <- group + ngroup * (codes(index) - 1)
                ngroup <- ngroup * nlevels(index)
        }
        if (missing(FUN))  
                return(group)
	ansmat<-array(NA,dim=extent,dimnames=namelist)
        ans <- lapply(split(x, group), FUN, ...)
        if (all(unlist(lapply(ans, length)) == 1)) {
                ans <- unlist(ans, recursive = FALSE)
	      }
	else { mode(ansmat)<-"list"}
	ansmat[as.numeric(names(ans))]<-ans
	ans<-ansmat
        return(ans)
}


=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-devel-request@stat.math.ethz.ch
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-