pkg/R/multiRun.R

   1 #' multiRun
   2 #'
   3 #' Estimate N times some parameters, outputs of some list of functions. This method is
   4 #' thus very generic, allowing typically bootstrap or Monte-Carlo estimations of matrices
   5 #' μ or β. Passing a list of functions opens the possibility to compare them on a fair
   6 #' basis (exact same inputs). It's even possible to compare methods on some deterministic
   7 #' design of experiments.
   8 #'
   9 #' @param fargs List of arguments for the estimation functions
  10 #' @param estimParams List of nf function(s) to apply on fargs - shared signature
  11 #' @param prepareArgs Prepare arguments for the functions inside estimParams
  12 #' @param N Number of runs
  13 #' @param ncores Number of cores for parallel runs (<=1: sequential)
  14 #' @param verbose TRUE to indicate runs + methods numbers
  15 #'
  16 #' @return A list of nf aggregates of N results (matrices).
  17 #'
  18 #' @examples
  19 #' \dontrun{
  20 #' β <- matrix(c(1,-2,3,1),ncol=2)
  21 #'
  22 #' # Bootstrap + computeMu, morpheus VS flexmix ; assumes fargs first 3 elts X,Y,K
  23 #' io <- generateSampleIO(n=1000, p=1/2, β=β, b=c(0,0), "logit")
  24 #' μ <- normalize(β)
  25 #' res <- multiRun(list(X=io$X,Y=io$Y,optargs=list(K=2,jd_nvects=0)), list(
  26 #'   # morpheus
  27 #'   function(fargs) {
  28 #'     library(morpheus)
  29 #'     ind <- fargs$ind
  30 #'     computeMu(fargs$X[ind,],fargs$Y[ind],fargs$optargs)
  31 #'   },
  32 #'   # flexmix
  33 #'   function(fargs) {
  34 #'     library(flexmix)
  35 #'     ind <- fargs$ind
  36 #'     K <- fargs$optargs$K
  37 #'     dat = as.data.frame( cbind(fargs$Y[ind],fargs$X[ind,]) )
  38 #'     out = refit( flexmix( cbind(V1, 1 - V1) ~ 0+., data=dat, k=K,
  39 #'       model=FLXMRglm(family="binomial") ) )
  40 #'     normalize( matrix(out@@coef[1:(ncol(fargs$X)*K)], ncol=K) )
  41 #'   } ),
  42 #'   prepareArgs = function(fargs) {
  43 #'     fargs$ind <- sample(1:nrow(fargs$X),replace=TRUE)
  44 #'     fargs
  45 #'   }, N=10, ncores=3)
  46 #' for (i in 1:2)
  47 #'   res[[i]] <- alignMatrices(res[[i]], ref=μ, ls_mode="exact")
  48 #'
  49 #' # Monte-Carlo + optimParams from X,Y, morpheus VS flexmix ; first args n,p,β,b
  50 #' res <- multiRun(list(n=1000,p=1/2,β=β,b=c(0,0),optargs=list(link="logit")),list(
  51 #'   # morpheus
  52 #'   function(fargs) {
  53 #'     library(morpheus)
  54 #'     K <- fargs$optargs$K
  55 #'     μ <- computeMu(fargs$X, fargs$Y, fargs$optargs)
  56 #'     V <- list( p=rep(1/K,K-1), β=μ, b=c(0,0) )
  57 #'     optimParams(V,fargs$optargs)$β
  58 #'   },
  59 #'   # flexmix
  60 #'   function(fargs) {
  61 #'     library(flexmix)
  62 #'     K <- fargs$optargs$K
  63 #'     dat <- as.data.frame( cbind(fargs$Y,fargs$X) )
  64 #'     out <- refit( flexmix( cbind(V1, 1 - V1) ~ 0+., data=dat, k=K,
  65 #'       model=FLXMRglm(family="binomial") ) )
  66 #'     sapply( seq_len(K), function(i) as.double( out@@components[[1]][[i]][,1] ) )
  67 #'   } ),
  68 #'   prepareArgs = function(fargs) {
  69 #'     library(morpheus)
  70 #'     io = generateSampleIO(fargs$n, fargs$p, fargs$β, fargs$b, fargs$optargs$link)
  71 #'     fargs$X = io$X
  72 #'     fargs$Y = io$Y
  73 #'     fargs$optargs$K = ncol(fargs$β)
  74 #'     fargs$optargs$M = computeMoments(io$X,io$Y)
  75 #'     fargs
  76 #'   }, N=10, ncores=3)
  77 #' for (i in 1:2)
  78 #'   res[[i]] <- alignMatrices(res[[i]], ref=β, ls_mode="exact")}
  79 #' @export
  80 multiRun <- function(fargs, estimParams,
  81     prepareArgs = function(x) x, N=10, ncores=3, agg=lapply, verbose=FALSE)
  82 {
  83     if (!is.list(fargs))
  84         stop("fargs: list")
  85     # No checks on fargs: supposedly done in estimParams[[i]]()
  86     if (!is.list(estimParams))
  87         estimParams = list(estimParams)
  88     # Verify that the provided parameters estimations are indeed functions
  89     lapply(seq_along(estimParams), function(i) {
  90         if (!is.function(estimParams[[i]]))
  91             stop("estimParams: list of function(fargs)")
  92     })
  93     if (!is.numeric(N) || N < 1)
  94         stop("N: positive integer")
  95
  96     estimParamAtIndex <- function(index)
  97     {
  98         fargs <- prepareArgs(fargs)
  99         if (verbose)
 100             cat("Run ",index,"\n")
 101         lapply(seq_along(estimParams), function(i) {
 102             if (verbose)
 103                 cat("   Method ",i,"\n")
 104             out <- estimParams[[i]](fargs)
 105             if (is.list(out))
 106                 do.call(rbind, out)
 107             else
 108                 out
 109         })
 110     }
 111
 112     if (ncores > 1)
 113     {
 114         cl = parallel::makeCluster(ncores, outfile="")
 115         parallel::clusterExport(cl, c("fargs","verbose"), environment())
 116         list_res = parallel::clusterApplyLB(cl, 1:N, estimParamAtIndex)
 117         parallel::stopCluster(cl)
 118     }
 119     else
 120         list_res = lapply(1:N, estimParamAtIndex)
 121
 122     # De-interlace results: output one list per function
 123     nf <- length(estimParams)
 124     lapply( seq_len(nf), function(i) lapply(seq_len(N), function(j) list_res[[j]][[i]]) )
 125 }