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