pkg/R/multiRun.R

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