| 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 | #' \dontrun{ |
| 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 | } |