Rutils/maybe-not-useful/fapply.r

In manfredo89/ED2io: Manages Input/Output for Ecosystem Demography 2 Model

#==========================================================================================#
#==========================================================================================#
#     This function is an attempt to make tapply faster.  This is very limited, and works  #
# only when FUN returns a scalar.                                                          #
#------------------------------------------------------------------------------------------#
fapply <<- function(X,INDEX,FUN,...){

   #----- Coerce INDEX to a list. ---------------------------------------------------------#
   if (! is.list(INDEX)) INDEX = as.list(c(INDEX))
   #---------------------------------------------------------------------------------------#


   #---- Get the output dimensions. -------------------------------------------------------#
   odim = sapply(X=INDEX,FUN=length)
   uind = lapply(X=lapply(X=lapply(X=INDEX,FUN=as.factor),FUN=unique),FUN=sort)
   ulen = sapply(X=uind,FUN=length)
   ugrd = as.matrix(expand.grid(uind))
   #---------------------------------------------------------------------------------------#




   #----- Initialise the list. ------------------------------------------------------------#
   out  = array(data=NA,dim=ulen,dimnames=uind)
   #---------------------------------------------------------------------------------------#



   #---------------------------------------------------------------------------------------#
   #    Find out which name to use for X.                                                  #
   #---------------------------------------------------------------------------------------#
   xlist     = split(x=X,f=INDEX)
   outlist   = sapply(X=xlist,FUN=FUN,simplify=TRUE,...)
   out[ugrd] = outlist
   rm(xlist,outlist)
   #---------------------------------------------------------------------------------------#
   return(out)
}#end fapply
fapply <<- cmpfun(fapply)
#==========================================================================================#
#==========================================================================================#