X-Git-Url: https://git.auder.net/?p=morpheus.git;a=blobdiff_plain;f=pkg%2FR%2FmultiRun.R;h=59e24835fd5fbf4e1439f655bdbe47b6b1bac401;hp=8b70d6d2adb184b8cde0e7667378a1396498aefc;hb=ab35f6102896a49e86e853262c0650faa2931638;hpb=d294ece1cf943b74d96b26cc28b08c00cb191264

diff --git a/pkg/R/multiRun.R b/pkg/R/multiRun.R
index 8b70d6d..59e2483 100644
--- a/pkg/R/multiRun.R
+++ b/pkg/R/multiRun.R
@@ -1,13 +1,16 @@
 #' multiRun
 #'
-#' Estimate N times some parameters, outputs of some list of functions. This method is
-#' thus very generic, allowing typically bootstrap or Monte-Carlo estimations of matrices
-#' μ or β. Passing a list of functions opens the possibility to compare them on a fair
-#' basis (exact same inputs). It's even possible to compare methods on some deterministic
-#' design of experiments.
+#' Estimate N times some parameters, outputs of some list of functions.
+#' This method is thus very generic, allowing typically bootstrap or
+#' Monte-Carlo estimations of matrices μ or β.
+#' Passing a list of functions opens the possibility to compare them on a fair
+#' basis (exact same inputs). It's even possible to compare methods on some
+#' deterministic design of experiments.
+#'
+#' @name multiRun
 #'
 #' @param fargs List of arguments for the estimation functions
-#' @param estimParams List of nf function(s) to apply on fargs - shared signature
+#' @param estimParams List of nf function(s) to apply on fargs
 #' @param prepareArgs Prepare arguments for the functions inside estimParams
 #' @param N Number of runs
 #' @param ncores Number of cores for parallel runs (<=1: sequential)
@@ -20,23 +23,23 @@
 #' \donttest{
 #' β <- matrix(c(1,-2,3,1),ncol=2)
 #'
-#' # Bootstrap + computeMu, morpheus VS flexmix ; assumes fargs first 3 elts X,Y,K
+#' # Bootstrap + computeMu, morpheus VS flexmix
 #' io <- generateSampleIO(n=1000, p=1/2, β=β, b=c(0,0), "logit")
 #' μ <- normalize(β)
-#' res <- multiRun(list(X=io$X,Y=io$Y,optargs=list(K=2,jd_nvects=0)), list(
+#' res <- multiRun(list(X=io$X,Y=io$Y,K=2), list(
 #'   # morpheus
 #'   function(fargs) {
 #'     library(morpheus)
 #'     ind <- fargs$ind
-#'     computeMu(fargs$X[ind,],fargs$Y[ind],fargs$optargs)
+#'     computeMu(fargs$X[ind,], fargs$Y[ind], list(K=fargs$K))
 #'   },
 #'   # flexmix
 #'   function(fargs) {
 #'     library(flexmix)
 #'     ind <- fargs$ind
-#'     K <- fargs$optargs$K
-#'     dat = as.data.frame( cbind(fargs$Y[ind],fargs$X[ind,]) )
-#'     out = refit( flexmix( cbind(V1, 1 - V1) ~ 0+., data=dat, k=K,
+#'     K <- fargs$K
+#'     dat <- as.data.frame( cbind(fargs$Y[ind],fargs$X[ind,]) )
+#'     out <- refit( flexmix( cbind(V1, 1 - V1) ~ 0+., data=dat, k=K,
 #'       model=FLXMRglm(family="binomial") ) )
 #'     normalize( matrix(out@@coef[1:(ncol(fargs$X)*K)], ncol=K) )
 #'   } ),
@@ -50,80 +53,82 @@
 #' for (i in 1:2)
 #'   res[[i]] <- alignMatrices(res[[i]], ref=μ, ls_mode="exact")
 #'
-#' # Monte-Carlo + optimParams from X,Y, morpheus VS flexmix ; first args n,p,β,b
-#' res <- multiRun(list(n=1000,p=1/2,β=β,b=c(0,0),optargs=list(link="logit")),list(
+#' # Monte-Carlo + optimParams from X,Y, morpheus VS flexmix
+#' res <- multiRun(list(n=1000,p=1/2,β=β,b=c(0,0),link="logit"), list(
 #'   # morpheus
 #'   function(fargs) {
 #'     library(morpheus)
-#'     K <- fargs$optargs$K
-#'     μ <- computeMu(fargs$X, fargs$Y, fargs$optargs)
-#'     optimParams(fargs$K,fargs$link,fargs$optargs)$run(list(β=μ))$β
+#'     K <- fargs$K
+#'     μ <- computeMu(fargs$X, fargs$Y, list(K=fargs$K))
+#'     o <- optimParams(fargs$X, fargs$Y, fargs$K, fargs$link, fargs$M)
+#'     o$run(list(β=μ))$β
 #'   },
 #'   # flexmix
 #'   function(fargs) {
 #'     library(flexmix)
-#'     K <- fargs$optargs$K
+#'     K <- fargs$K
 #'     dat <- as.data.frame( cbind(fargs$Y,fargs$X) )
-#'     out <- refit( flexmix( cbind(V1, 1 - V1) ~ 0+., data=dat, k=K,
+#'     out <- refit( flexmix( cbind(V1, 1 - V1) ~ ., data=dat, k=K,
 #'       model=FLXMRglm(family="binomial") ) )
-#'     sapply( seq_len(K), function(i) as.double( out@@components[[1]][[i]][,1] ) )
+#'     sapply( seq_len(K), function(i)
+#'       as.double( out@@components[[1]][[i]][2:(1+ncol(fargs$X)),1] ) )
 #'   } ),
 #'   prepareArgs = function(fargs,index) {
 #'     library(morpheus)
-#'     io = generateSampleIO(fargs$n, fargs$p, fargs$β, fargs$b, fargs$optargs$link)
-#'     fargs$X = io$X
-#'     fargs$Y = io$Y
-#'     fargs$K = ncol(fargs$β)
-#'     fargs$link = fargs$optargs$link
-#'     fargs$optargs$M = computeMoments(io$X,io$Y)
+#'     io <- generateSampleIO(fargs$n, fargs$p, fargs$β, fargs$b, fargs$link)
+#'     fargs$X <- io$X
+#'     fargs$Y <- io$Y
+#'     fargs$K <- ncol(fargs$β)
+#'     fargs$link <- fargs$link
+#'     fargs$M <- computeMoments(io$X,io$Y)
 #'     fargs
 #'   }, N=10, ncores=3)
 #' for (i in 1:2)
 #'   res[[i]] <- alignMatrices(res[[i]], ref=β, ls_mode="exact")}
 #' @export
 multiRun <- function(fargs, estimParams,
-	prepareArgs = function(x,i) x, N=10, ncores=3, agg=lapply, verbose=FALSE)
+  prepareArgs = function(x,i) x, N=10, ncores=3, agg=lapply, verbose=FALSE)
 {
-	if (!is.list(fargs))
-		stop("fargs: list")
-	# No checks on fargs: supposedly done in estimParams[[i]]()
-	if (!is.list(estimParams))
-		estimParams = list(estimParams)
-	# Verify that the provided parameters estimations are indeed functions
-	lapply(seq_along(estimParams), function(i) {
-		if (!is.function(estimParams[[i]]))
-			stop("estimParams: list of function(fargs)")
-	})
-	if (!is.numeric(N) || N < 1)
-		stop("N: positive integer")
+  if (!is.list(fargs))
+    stop("fargs: list")
+  # No checks on fargs: supposedly done in estimParams[[i]]()
+  if (!is.list(estimParams))
+    estimParams = list(estimParams)
+  # Verify that the provided parameters estimations are indeed functions
+  lapply(seq_along(estimParams), function(i) {
+    if (!is.function(estimParams[[i]]))
+      stop("estimParams: list of function(fargs)")
+  })
+  if (!is.numeric(N) || N < 1)
+    stop("N: positive integer")
 
-	estimParamAtIndex <- function(index)
-	{
-		fargs <- prepareArgs(fargs, index)
-		if (verbose)
-			cat("Run ",index,"\n")
-		lapply(seq_along(estimParams), function(i) {
-			if (verbose)
-				cat("   Method ",i,"\n")
-			out <- estimParams[[i]](fargs)
-			if (is.list(out))
-				do.call(rbind, out)
-			else
-				out
-		})
-	}
+  estimParamAtIndex <- function(index)
+  {
+    fargs <- prepareArgs(fargs, index)
+    if (verbose)
+      cat("Run ",index,"\n")
+    lapply(seq_along(estimParams), function(i) {
+      if (verbose)
+        cat("   Method ",i,"\n")
+      out <- estimParams[[i]](fargs)
+      if (is.list(out))
+        do.call(rbind, out)
+      else
+        out
+    })
+  }
 
-	if (ncores > 1)
-	{
-		cl = parallel::makeCluster(ncores, outfile="")
-		parallel::clusterExport(cl, c("fargs","verbose"), environment())
-		list_res = parallel::clusterApplyLB(cl, 1:N, estimParamAtIndex)
-		parallel::stopCluster(cl)
-	}
-	else
-		list_res = lapply(1:N, estimParamAtIndex)
+  if (ncores > 1)
+  {
+    cl <- parallel::makeCluster(ncores, outfile="")
+    parallel::clusterExport(cl, c("fargs","verbose"), environment())
+    list_res <- parallel::clusterApplyLB(cl, 1:N, estimParamAtIndex)
+    parallel::stopCluster(cl)
+  }
+  else
+    list_res <- lapply(1:N, estimParamAtIndex)
 
-	# De-interlace results: output one list per function
-	nf <- length(estimParams)
-	lapply( seq_len(nf), function(i) lapply(seq_len(N), function(j) list_res[[j]][[i]]) )
+  # De-interlace results: output one list per function
+  nf <- length(estimParams)
+  lapply( seq_len(nf), function(i) lapply(seq_len(N), function(j) list_res[[j]][[i]]) )
 }