1. function (fn, lower, upper, control = DEoptim.control(), ...,
2.     fnMap = NULL)
3. {
4.     if (length(lower) != length(upper))
5.         stop("'lower' and 'upper' are not of same length")
6.     if (!is.vector(lower))
7.         lower <- as.vector(lower)
8.     if (!is.vector(upper))
9.         upper <- as.vector(upper)
10.     if (any(lower > upper))
11.         stop("'lower' > 'upper'")
12.     if (any(lower == "Inf"))
13.         warning("you set a component of 'lower' to 'Inf'. May imply 'NaN' results",
14.             immediate. = TRUE)
15.     if (any(lower == "-Inf"))
16.         warning("you set a component of 'lower' to '-Inf'. May imply 'NaN' results",
17.             immediate. = TRUE)
18.     if (any(upper == "Inf"))
19.         warning("you set a component of 'upper' to 'Inf'. May imply 'NaN' results",
20.             immediate. = TRUE)
21.     if (any(upper == "-Inf"))
22.         warning("you set a component of 'upper' to '-Inf'. May imply 'NaN' results",
23.             immediate. = TRUE)
24.     if (!is.null(names(lower)))
25.         nam <- names(lower)
26.     else if (!is.null(names(upper)) & is.null(names(lower)))
27.         nam <- names(upper)
28.     else nam <- paste("par", 1:length(lower), sep = "")
29.     ctrl <- do.call(DEoptim.control, as.list(control))
30.     ctrl$npar <- length(lower)
31.     if (is.na(ctrl$NP))
32.         ctrl$NP <- 10 * length(lower)
33.     if (ctrl$NP < 4) {
34.         warning("'NP' < 4; set to default value 10*length(lower)\n",
35.             immediate. = TRUE)
36.         ctrl$NP <- 10 * length(lower)
37.     }
38.     if (ctrl$NP < 10 * length(lower))
39.         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",
40.             immediate. = TRUE)
41.     if (!is.null(ctrl$initialpop)) {
42.         ctrl$specinitialpop <- TRUE
43.         if (!identical(as.numeric(dim(ctrl$initialpop)), as.numeric(c(ctrl$NP,
44.             ctrl$npar))))
45.             stop("Initial population is not a matrix with dim. NP x length(upper).")
46.     }
47.     else {
48.         ctrl$specinitialpop <- FALSE
49.         ctrl$initialpop <- 0
50.     }
51.     ctrl$trace <- as.numeric(ctrl$trace)
52.     ctrl$specinitialpop <- as.numeric(ctrl$specinitialpop)
53.     ctrl$initialpop <- as.numeric(ctrl$initialpop)
54.     if (!is.null(ctrl$cluster)) {
55.         if (!inherits(ctrl$cluster, "cluster"))
56.             stop("cluster is not a 'cluster' class object")
57.         parallel::clusterExport(cl, ctrl$parVar)
58.         fnPop <- function(params, ...) {
59.             parallel::parApply(cl = ctrl$cluster, params, 1,
60.                 fn, ...)
61.         }
62.     }
63.     else if (ctrl$parallelType == 2) {
64.         if (!foreach::getDoParRegistered()) {
65.             foreach::registerDoSEQ()
66.         }
67.         args <- ctrl$foreachArgs
68.         fnPop <- function(params, ...) {
69.             my_chunksize <- ceiling(NROW(params)/foreach::getDoParWorkers())
70.             my_iter <- iterators::iter(params, by = "row", chunksize = my_chunksize)
71.             args$i <- my_iter
72.             args$.combine <- c
73.             if (!is.null(args$.export))
74.                 args$.export = c(args$.export, "fn")
75.             else args$.export = "fn"
76.             if (is.null(args$.errorhandling))
77.                 args$.errorhandling = c("stop", "remove", "pass")
78.             if (is.null(args$.verbose))
79.                 args$.verbose = FALSE
80.             if (is.null(args$.inorder))
81.                 args$.inorder = TRUE
82.             if (is.null(args$.multicombine))
83.                 args$.multicombine = FALSE
84.             foreach::"%dopar%"(do.call(foreach::foreach, args),
85.                 apply(i, 1, fn, ...))
86.         }
87.     }
88.     else if (ctrl$parallelType == 1) {
89.         cl <- parallel::makeCluster(parallel::detectCores())
90.         packFn <- function(packages) {
91.             for (i in packages) library(i, character.only = TRUE)
92.         }
93.         parallel::clusterCall(cl, packFn, ctrl$packages)
94.         parallel::clusterExport(cl, ctrl$parVar)
95.         fnPop <- function(params, ...) {
96.             parallel::parApply(cl = cl, params, 1, fn, ...)
97.         }
98.     }
99.     else {
100.         fnPop <- function(params, ...) {
101.             apply(params, 1, fn, ...)
102.         }
103.     }
104.     if (is.null(fnMap)) {
105.         fnMapC <- function(params, ...) params
106.     }
107.     else {
108.         fnMapC <- function(params, ...) {
109.             mappedPop <- t(apply(params, 1, fnMap))
110.             if (all(dim(mappedPop) != dim(params)))
111.                 stop("mapping function did not return an object with ",
112.                   "dim NP x length(upper).")
113.             dups <- duplicated(mappedPop)
114.             np <- NCOL(mappedPop)
115.             tries <- 0
116.             while (tries < 5 && any(dups)) {
117.                 nd <- sum(dups)
118.                 newPop <- matrix(runif(nd * np), ncol = np)
119.                 newPop <- rep(lower, each = nd) + newPop * rep(upper -
120.                   lower, each = nd)
121.                 mappedPop[dups, ] <- t(apply(newPop, 1, fnMap))
122.                 dups <- duplicated(mappedPop)
123.                 tries <- tries + 1
124.             }
125.             if (tries == 5)
126.                 warning("Could not remove ", sum(dups), " duplicates from the mapped ",
127.                   "population in 5 tries. Evaluating population with duplicates.",
128.                   call. = FALSE, immediate. = TRUE)
129.             storage.mode(mappedPop) <- "double"
130.             mappedPop
131.         }
132.     }
133.     outC <- .Call("DEoptimC", lower, upper, fnPop, ctrl, new.env(),
134.         fnMapC, PACKAGE = "DEoptim")
135.     if (ctrl$parallelType == 1)
136.         parallel::stopCluster(cl)
137.     if (length(outC$storepop) > 0) {
138.         nstorepop <- floor((outC$iter - ctrl$storepopfrom)/ctrl$storepopfreq)
139.         storepop <- list()
140.         cnt <- 1
141.         for (i in 1:nstorepop) {
142.             idx <- cnt:((cnt - 1) + (ctrl$NP * ctrl$npar))
143.             storepop[[i]] <- matrix(outC$storepop[idx], nrow = ctrl$NP,
144.                 ncol = ctrl$npar, byrow = TRUE)
145.             cnt <- cnt + (ctrl$NP * ctrl$npar)
146.             dimnames(storepop[[i]]) <- list(1:ctrl$NP, nam)
147.         }
148.     }
149.     else {
150.         storepop = NULL
151.     }
152.     names(outC$bestmem) <- nam
153.     iter <- max(1, as.numeric(outC$iter))
154.     names(lower) <- names(upper) <- nam
155.     bestmemit <- matrix(outC$bestmemit[1:(iter * ctrl$npar)],
156.         nrow = iter, ncol = ctrl$npar, byrow = TRUE)
157.     dimnames(bestmemit) <- list(1:iter, nam)
158.     storepop <- as.list(storepop)
159.     outR <- list(optim = list(bestmem = outC$bestmem, bestval = outC$bestval,
160.         nfeval = outC$nfeval, iter = outC$iter), member = list(lower = lower,
161.         upper = upper, bestmemit = bestmemit, bestvalit = outC$bestvalit,
162.         pop = t(outC$pop), storepop = storepop))
163.     attr(outR, "class") <- "DEoptim"
164.     return(outR)
165. }
166. <bytecode: 0x000000001fc258b8>
167. <environment: namespace:DEoptim>