API tools faq
paste
Advertisement
mjaniec

DEoptim parallel constrain

mjaniec
Jul 13th, 2015
840
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
R 9.35 KB | None | 0 0
raw download clone embed print report
  1. # A simple modification of DEoptim (and DEoptim.control) to limit the number of cores used in the paralell mode.
  2. # In DEoptim.control you may set a new variable 'limitCores'.
  3. # When 'limitCores' is set below 1, a certain portion of available cores will be used.
  4. # 'limitCores' set to a number (say: 2,4,10) will make DEoptim use a specified number of cores.
  5. # The goal is to constrain the DEoptim CPU consumption.
  6.  
  7. DEoptim2 <- function (fn, lower, upper, control = DEoptim.control(), ...,
  8.     fnMap = NULL)
  9. {
  10.     if (length(lower) != length(upper))
  11.         stop("'lower' and 'upper' are not of same length")
  12.     if (!is.vector(lower))
  13.         lower <- as.vector(lower)
  14.     if (!is.vector(upper))
  15.         upper <- as.vector(upper)
  16.     if (any(lower > upper))
  17.         stop("'lower' > 'upper'")
  18.     if (any(lower == "Inf"))
  19.         warning("you set a component of 'lower' to 'Inf'. May imply 'NaN' results",
  20.             immediate. = TRUE)
  21.     if (any(lower == "-Inf"))
  22.         warning("you set a component of 'lower' to '-Inf'. May imply 'NaN' results",
  23.             immediate. = TRUE)
  24.     if (any(upper == "Inf"))
  25.         warning("you set a component of 'upper' to 'Inf'. May imply 'NaN' results",
  26.             immediate. = TRUE)
  27.     if (any(upper == "-Inf"))
  28.         warning("you set a component of 'upper' to '-Inf'. May imply 'NaN' results",
  29.             immediate. = TRUE)
  30.     if (!is.null(names(lower)))
  31.         nam <- names(lower)
  32.     else if (!is.null(names(upper)) & is.null(names(lower)))
  33.         nam <- names(upper)
  34.     else nam <- paste("par", 1:length(lower), sep = "")
  35.     ctrl <- do.call(DEoptim.control, as.list(control))
  36.     ctrl$npar <- length(lower)
  37.     if (is.na(ctrl$NP))
  38.         ctrl$NP <- 10 * length(lower)
  39.     if (ctrl$NP < 4) {
  40.         warning("'NP' < 4; set to default value 10*length(lower)\n",
  41.             immediate. = TRUE)
  42.         ctrl$NP <- 10 * length(lower)
  43.     }
  44.     if (ctrl$NP < 10 * length(lower))
  45.         warning("For many problems it is best to set 'NP' (in 'control') to be at least ten times the length of the parameter vector. \n",
  46.             immediate. = TRUE)
  47.     if (!is.null(ctrl$initialpop)) {
  48.         ctrl$specinitialpop <- TRUE
  49.         if (!identical(as.numeric(dim(ctrl$initialpop)), as.numeric(c(ctrl$NP,
  50.             ctrl$npar))))
  51.             stop("Initial population is not a matrix with dim. NP x length(upper).")
  52.     }
  53.     else {
  54.         ctrl$specinitialpop <- FALSE
  55.         ctrl$initialpop <- 0
  56.     }
  57.     ctrl$trace <- as.numeric(ctrl$trace)
  58.     ctrl$specinitialpop <- as.numeric(ctrl$specinitialpop)
  59.     ctrl$initialpop <- as.numeric(ctrl$initialpop)
  60.     if (ctrl$parallelType == 2) {
  61.         if (!foreach::getDoParRegistered()) {
  62.             foreach::registerDoSEQ()
  63.         }
  64.         args <- ctrl$foreachArgs
  65.         fnPop <- function(params, ...) {
  66.             my_chunksize <- ceiling(NROW(params)/foreach::getDoParWorkers())
  67.             my_iter <- iterators::iter(params, by = "row", chunksize = my_chunksize)
  68.             args$i <- my_iter
  69.             args$.combine <- c
  70.             if (!is.null(args$.export))
  71.                 args$.export = c(args$.export, "fn")
  72.             else args$.export = "fn"
  73.             if (is.null(args$.errorhandling))
  74.                 args$.errorhandling = c("stop", "remove", "pass")
  75.             if (is.null(args$.verbose))
  76.                 args$.verbose = FALSE
  77.             if (is.null(args$.inorder))
  78.                 args$.inorder = TRUE
  79.             if (is.null(args$.multicombine))
  80.                 args$.multicombine = FALSE
  81.             foreach::"%dopar%"(do.call(foreach::foreach, args),
  82.                 apply(i, 1, fn, ...))
  83.         }
  84.     }
  85.     else if (ctrl$parallelType == 1) {
  86.        
  87.         if (!is.na(ctrl$limitCores)) {
  88.        
  89.             if (ctrl$limitCores<1) useCores <- round(parallel::detectCores()*ctrl$limitCores) else useCores <- ctrl$limitCores
  90.        
  91.             cl <- parallel::makeCluster(parallel::detectCores())
  92.        
  93.         } else {
  94.    
  95.             cl <- parallel::makeCluster(parallel::detectCores())
  96.        
  97.         }
  98.         packFn <- function(packages) {
  99.             for (i in packages) library(i, character.only = TRUE)
  100.         }
  101.         parallel::clusterCall(cl, packFn, ctrl$packages)
  102.         parallel::clusterExport(cl, ctrl$parVar)
  103.         fnPop <- function(params, ...) {
  104.             parallel::parApply(cl = cl, params, 1, fn, ...)
  105.         }
  106.     }
  107.     else {
  108.         fnPop <- function(params, ...) {
  109.             apply(params, 1, fn, ...)
  110.         }
  111.     }
  112.     if (is.null(fnMap)) {
  113.         fnMapC <- function(params, ...) params
  114.     }
  115.     else {
  116.         fnMapC <- function(params, ...) {
  117.             mappedPop <- t(apply(params, 1, fnMap))
  118.             if (all(dim(mappedPop) != dim(params)))
  119.                 stop("mapping function did not return an object with ",
  120.                   "dim NP x length(upper).")
  121.             dups <- duplicated(mappedPop)
  122.             np <- NCOL(mappedPop)
  123.             tries <- 0
  124.             while (tries < 5 && any(dups)) {
  125.                 nd <- sum(dups)
  126.                 newPop <- matrix(runif(nd * np), ncol = np)
  127.                 newPop <- rep(lower, each = nd) + newPop * rep(upper -
  128.                   lower, each = nd)
  129.                 mappedPop[dups, ] <- t(apply(newPop, 1, fnMap))
  130.                 dups <- duplicated(mappedPop)
  131.                 tries <- tries + 1
  132.             }
  133.             if (tries == 5)
  134.                 warning("Could not remove ", sum(dups), " duplicates from the mapped ",
  135.                   "population in 5 tries. Evaluating population with duplicates.",
  136.                   call. = FALSE, immediate. = TRUE)
  137.             storage.mode(mappedPop) <- "double"
  138.             mappedPop
  139.         }
  140.     }
  141.     outC <- .Call("DEoptimC", lower, upper, fnPop, ctrl, new.env(),
  142.         fnMapC, PACKAGE = "DEoptim")
  143.     if (ctrl$parallelType == 1)
  144.         parallel::stopCluster(cl)
  145.     if (length(outC$storepop) > 0) {
  146.         nstorepop <- floor((outC$iter - ctrl$storepopfrom)/ctrl$storepopfreq)
  147.         storepop <- list()
  148.         cnt <- 1
  149.         for (i in 1:nstorepop) {
  150.             idx <- cnt:((cnt - 1) + (ctrl$NP * ctrl$npar))
  151.             storepop[[i]] <- matrix(outC$storepop[idx], nrow = ctrl$NP,
  152.                 ncol = ctrl$npar, byrow = TRUE)
  153.             cnt <- cnt + (ctrl$NP * ctrl$npar)
  154.             dimnames(storepop[[i]]) <- list(1:ctrl$NP, nam)
  155.         }
  156.     }
  157.     else {
  158.         storepop = NULL
  159.     }
  160.     names(outC$bestmem) <- nam
  161.     iter <- max(1, as.numeric(outC$iter))
  162.     names(lower) <- names(upper) <- nam
  163.     bestmemit <- matrix(outC$bestmemit[1:(iter * ctrl$npar)],
  164.         nrow = iter, ncol = ctrl$npar, byrow = TRUE)
  165.     dimnames(bestmemit) <- list(1:iter, nam)
  166.     storepop <- as.list(storepop)
  167.     outR <- list(optim = list(bestmem = outC$bestmem, bestval = outC$bestval,
  168.         nfeval = outC$nfeval, iter = outC$iter), member = list(lower = lower,
  169.         upper = upper, bestmemit = bestmemit, bestvalit = outC$bestvalit,
  170.         pop = t(outC$pop), storepop = storepop))
  171.     attr(outR, "class") <- "DEoptim"
  172.     return(outR)
  173. }
  174.  
  175. DEoptim.control <- function (VTR = -Inf, strategy = 2, bs = FALSE, NP = NA, itermax = 200,
  176.     CR = 0.5, F = 0.8, trace = TRUE, initialpop = NULL, storepopfrom = itermax +
  177.         1, storepopfreq = 1, p = 0.2, c = 0, reltol, steptol,
  178.     parallelType = 0, limitCores=NA, packages = c(), parVar = c(), foreachArgs = list())
  179. {
  180.     if (itermax <= 0) {
  181.         warning("'itermax' <= 0; set to default value 200\n",
  182.             immediate. = TRUE)
  183.         itermax <- 200
  184.     }
  185.     if (F < 0 | F > 2) {
  186.         warning("'F' not in [0,2]; set to default value 0.8\n",
  187.             immediate. = TRUE)
  188.         F <- 0.8
  189.     }
  190.     if (CR < 0 | CR > 1) {
  191.         warning("'CR' not in [0,1]; set to default value 0.5\n",
  192.             immediate. = TRUE)
  193.         CR <- 0.5
  194.     }
  195.     if (strategy < 1 | strategy > 6) {
  196.         warning("'strategy' not in {1,...,6}; set to default value 2\n",
  197.             immediate. = TRUE)
  198.         strategy <- 2
  199.     }
  200.     bs <- (bs > 0)
  201.     if (trace < 0) {
  202.         warning("'trace' cannot be negative; set to 'TRUE'")
  203.         trace <- TRUE
  204.     }
  205.     storepopfreq <- floor(storepopfreq)
  206.     if (storepopfreq > itermax)
  207.         storepopfreq <- 1
  208.     if (p <= 0 || p > 1) {
  209.         warning("'p' not in (0,1]; set to default value 0.2\n",
  210.             immediate. = TRUE)
  211.         p <- 0.2
  212.     }
  213.     if (c < 0 || c > 1) {
  214.         warning("'c' not in [0,1]; set to default value 0\n",
  215.             immediate. = TRUE)
  216.         c <- 0
  217.     }
  218.     if (missing(reltol)) {
  219.         reltol <- sqrt(.Machine$double.eps)
  220.     }
  221.     if (missing(steptol)) {
  222.         steptol <- itermax
  223.     }
  224.     if (!(is.null(initialpop))) {
  225.         if (is.na(NP))
  226.             if (is.matrix(initialpop))
  227.                 NP <- dim(initialpop)[1]
  228.             else stop("initialpop must be a matrix")
  229.         else if (NP != dim(initialpop)[1]) {
  230.             warning("Resetting NP to the number of rows in initialpop")
  231.             NP <- dim(initialpop)[1]
  232.         }
  233.     }
  234.     list(VTR = VTR, strategy = strategy, NP = NP, itermax = itermax,
  235.         CR = CR, F = F, bs = bs, trace = trace, initialpop = initialpop,
  236.         storepopfrom = storepopfrom, storepopfreq = storepopfreq,
  237.         p = p, c = c, reltol = reltol, steptol = steptol, parallelType = parallelType, limitCores=limitCores,
  238.         packages = packages, parVar = parVar, foreachArgs = foreachArgs)
  239. }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!