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)
	ans <- lapply(split(x, group), FUN, ...) 
	if(all(unlist(lapply(ans,length))==1))
		ans <- unlist(ans, recursive=FALSE)
	if(length(INDEX) == 1) {
		names(ans) <- namelist[[1]]
	}
	else {
		dim(ans) <- extent
		dimnames(ans) <- namelist
	}
	return(ans)
}
