Commit | Line | Data |
---|---|---|
cbd88fe5 BA |
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 | } |