a "factorial apply" function

xapply.R

#' apply a function to a factorial combination of elements of lists
#' returns (if \code{FLATTEN=TRUE}) a flat list (with length equal to the product of the
#' lengths of the input lists) of results, along with a \code{grid} attribute containing
#' a data frame giving the values used for each element in the list
#' @param FUN function to apply
#' @param ... list of vectors to apply to
#' @param FLATTEN
#' @param MoreArgs additional arguments to pass to \code{FUN}
#' @param GlobalVars list of names of variables in global environment needed for parallel runs
#' @param .progress progress bar?
#' @param checkpoint  ?stub
#' @param verbose
#' @param sanitize.call clean up call element of computed objects?
#' @examples
#' L1 <- list(data.frame(x=1:10,y=1:10),
#'               data.frame(x=runif(10),y=runif(10)),
#'               data.frame(x=rnorm(10),y=rnorm(10)))
#'    L2 <- list(y~1,y~x,y~poly(x,2))          
#'    z <- xapply(lm,L2,L1)
#'    z <- xapply(lm,L2,L1,verbose=TRUE)
#'    z <- xapply(lm,L2,L1,parallel=TRUE)
#'    sapply(z,coef)
#'    if (require(tcltk)) {
#'       z <- xapply(lm,L2,L1,.progress="tk")
#' }

## FIXME/TODO:
##  - wrap in try()? warn on inherits("error")?
##  - Summarize() method?
##  - progress printing doesn't work right in parallel eval 
xapply <- function(FUN,...,
                   FLATTEN=TRUE,
                   MoreArgs=NULL,
                   GlobalVars=NULL,
                   Packages=NULL,
                   parallel=FALSE,
                   ncores=2,
                   .progress="none",
                   verbose=FALSE,
                   checkpoint=FALSE,
                   sanitize.call=FALSE) {
    if (parallel) {
        require(parallel)
        ## print/cat to stdout on Linux ... doesn't work on Windows?
        ## https://stackoverflow.com/questions/16717461/how-can-i-print-or-cat-when-using-parallel 
        cl <- makeCluster(getOption("cl.cores", ncores),outfile="")
        on.exit(stopCluster(cl))
    }
    L <- list(...)
    if (isTRUE(checkpoint) || is.character(checkpoint))
        stop("checkpointing is a stub")
    namefun <- function(x,maxchar=20) {
        if (!is.null(names(x))) return(names(x))
        if (is.atomic(x) && !any(duplicated(n <- as.character(x)))) return(n)
        nn <- sapply(x,deparse)
        if (all(nchar(nn)<maxchar)) return(nn)
        return(paste0("V",seq_along(x)))
    }
    namelist <- lapply(L,namefun)
    grid <- do.call(expand.grid,c(namelist,list(stringsAsFactors=FALSE)))
    grid <- data.frame(ind=1:nrow(grid),grid,stringsAsFactors=FALSE)
    inds <- do.call(expand.grid,lapply(L,seq_along)) ## Marek's suggestion
    maxind <- nrow(inds)
    pbStyle <- 1
    do.progress <- (.progress!="none")
    if (do.progress || verbose) {  ## wrap/decorate primary function
        if (do.progress) {
            ## minor hack to allow plyr-like progress bars
            if (.progress=="text") {
                .progress <- "txt"
                pbStyle <- 3
            }
            pbfun <- get(paste(.progress,"ProgressBar",sep=""))
            setpbfun <- get(paste("set",.simpleCap(.progress),"ProgressBar",sep=""))
            pbArgs <- list()
            if (.progress=="txt") pbArgs$style <- pbStyle
            pb <- do.call(pbfun,pbArgs)
            on.exit(close(pb))

        }
        FUN0 <- FUN
        ## don't have an explicit loop, so need to increment counter in environment
        i <- 1
        FUN <- function(...) {
            if (do.progress) setpbfun(pb,value=i/maxind)
            if (verbose) cat(paste(grid[i,],collapse=","),"\n")
            ret <- FUN0(...)
            i <<- i+1
            return(ret)
        }
    }
    ## FIXME: apply names(L) to argsList ?
    if (!FLATTEN) stop("only FLATTEN=TRUE is implemented so far")
    ## construct list of arg lists (+ additional arguments)
    argsList <- lapply(1:nrow(inds), function(i) c(Map(function(x,j) x[[j]],L,as.list(inds[i,])),
                                                   MoreArgs))
    if (parallel) {
        clusterExport(cl,varlist=c("FUN0","FUN","fit_verbose"),env=environment(FUN))
        if (!is.null(Packages)) {
            for (pkg in Packages) {
                clusterCall(cl,library,pkg,character.only=TRUE)
            }
        }
        if (!is.null(GlobalVars)) clusterExport(cl,varlist=GlobalVars)
        retlist <- parLapply(cl=cl, X=argsList, fun=function(x) do.call(FUN,x))
    } else {
        retlist <- lapply(argsList, do.call, what=FUN)
    }
    attr(retlist,"grid") <- grid
    return(retlist)
}