diff --git a/Dockerfile b/Dockerfile index 3e2a086..cfff8bf 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,34 +1,34 @@ FROM rocker/shiny:4.3.1 RUN apt-get update && apt-get install -y \ - --no-install-recommends \ - git-core \ - libssl-dev \ - curl \ - libcurl4-gnutls-dev \ - libsodium-dev \ - libxml2-dev \ - libicu-dev \ - && apt-get clean \ - && rm -rf /var/lib/apt/lists/* + --no-install-recommends \ + git-core \ + libssl-dev \ + curl \ + libcurl4-gnutls-dev \ + libsodium-dev \ + libxml2-dev \ + libicu-dev \ + && apt-get clean \ + && rm -rf /var/lib/apt/lists/* ENV _R_SHLIB_STRIP_=true ENV SHINY_LOG_STDERR=1 RUN install2.r --error --skipinstalled \ - shiny \ - DT \ - shinydashboard \ - shinyWidgets \ - shinyjs \ - rootSolve \ - ggplot2 \ - patchwork \ - R6 \ - sensitivity \ - openxlsx \ - future \ - promises + shiny \ + DT \ + shinydashboard \ + shinyWidgets \ + shinyjs \ + rootSolve \ + ggplot2 \ + patchwork \ + R6 \ + sensitivity \ + openxlsx \ + future \ + promises COPY ./tsf/ /home/tsf diff --git a/Tests/IDA/Rplots.pdf b/Tests/IDA/Rplots.pdf index 3f796cc..cc51826 100644 Binary files a/Tests/IDA/Rplots.pdf and b/Tests/IDA/Rplots.pdf differ diff --git a/Tests/IDA/TestBatch.R b/Tests/IDA/TestBatch.R new file mode 100644 index 0000000..8d6fe88 --- /dev/null +++ b/Tests/IDA/TestBatch.R @@ -0,0 +1,29 @@ +setwd("/home/konrad/Documents/Thermosimfit/Tests/IDA") +library(tsf) + +# Test several opti calls in parallel +path <- "idaBatch.csv" +lowerBounds <- c( + kG = 1000, + I0 = 0, + IHD = 0, + ID = 0 +) +upperBounds <- c( + kG = 10^8, + I0 = 100, + IHD = 10^7, + ID = 10^7 +) +additionalParameters <- c( + host = 1e-6, + dye = 1e-6, + kHD = 3e6 +) + +tsf::batch( + "ida", + lowerBounds, upperBounds, + path, additionalParameters, + ngen = 20 +) diff --git a/tsf/DESCRIPTION b/tsf/DESCRIPTION index 6e1298a..a1460a6 100644 --- a/tsf/DESCRIPTION +++ b/tsf/DESCRIPTION @@ -27,7 +27,7 @@ Imports: plotly Suggests: knitr, rmarkdown, tinytest VignetteBuilder: knitr -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 Encoding: UTF-8 Roxygen: list(markdown = TRUE) URL: https://complat.github.io/Thermosimfit/ diff --git a/tsf/NAMESPACE b/tsf/NAMESPACE index be593ca..ca14fa3 100644 --- a/tsf/NAMESPACE +++ b/tsf/NAMESPACE @@ -1,7 +1,7 @@ # Generated by roxygen2: do not edit by hand -export(Communicator) export(ErrorClass) +export(batch) export(convertToNum) export(createPolynom) export(opti) @@ -10,15 +10,14 @@ export(runApp) export(sensitivity) import(DT) import(R6) -import(future) +import(callr) import(ggplot2) import(openxlsx) import(patchwork) -import(promises) +import(plotly, except=c(last_plot)) import(rootSolve) -import(sensitivity) +import(sensitivity, except=c(print.src)) import(shiny, except=c(dataTableOutput, renderDataTable, runExample)) import(shinyWidgets, except=c(alert)) -import(plotly, except=c(last_plot)) import(shinydashboard) import(shinyjs) diff --git a/tsf/R/Batch.R b/tsf/R/Batch.R index fbd6797..1bf39ad 100644 --- a/tsf/R/Batch.R +++ b/tsf/R/Batch.R @@ -100,72 +100,10 @@ seperate_batch_results <- function(list) { ) } -batch <- function(case, - lowerBounds, upperBounds, - path, - additionalParameters, - seed = NULL, npop = 40, ngen = 200, Topology = "random", - errorThreshold = -Inf, num_rep = 1) { - # import data - list_df <- importDataBatch(path) - if (!is.list(list_df)) { - return(ErrorClass$new("Could not import data")) - } - for (i in seq_along(list_df)) { - if (!is.data.frame(list_df[[i]])) { - return(list_df[[i]]) - } - } - # seed case - seed_original <- seed - seed_from <- 1:1e6 - # size calculations - num_data_sets <- length(list_df) - result <- vector("list", length = num_data_sets * num_rep) - seeds <- numeric(length = num_data_sets * num_rep) - counter <- 1 - - # run optimization - for (i in seq_len(num_data_sets)) { - if (is.null(seed)) { - seed <- sample(seed_from, 1) - } else { - seed <- seed_original - } - # seeds[counter] <- seed - result[[counter]] <- opti( - case = case, lowerBounds = lowerBounds, upperBounds = upperBounds, - list_df[[i]], additionalParameters, seed = seed, npop = npop, ngen = ngen, - Topology = Topology, errorThreshold = errorThreshold - ) - counter <- counter + 1 - if (num_rep > 1) { - for (j in seq_len(num_rep - 1)) { - seed <- sample(seed_from, 1) - # seeds[counter] <- seed - result[[counter]] <- opti( - case = case, lowerBounds = lowerBounds, upperBounds = upperBounds, - list_df[[i]], additionalParameters, seed = seed, npop = npop, ngen = ngen, - Topology = Topology, errorThreshold = errorThreshold - ) - counter <- counter + 1 - } - } - } - - list <- seperate_batch_results(result) - list( - list, - plotStates(list), - plotParams(list), - plotMetrices(list) - ) -} - call_several_opti <- function(case, lb, ub, - df_list, ap, seed_list, - npop, ngen, topo, - et, messages, env) { + df_list, ap, seed_list, + npop, ngen, topo, + et, messages, env) { env <- new.env() env$intermediate_results <- vector("list", length(df_list)) tryCatch( @@ -199,8 +137,10 @@ call_several_opti_in_bg <- function(case, lb, ub, df_list, ap, seed_list, npop, ngen, topo, et, messages) { env <- new.env() - env$intermediate_results <- lapply(seq_len(length((df_list))), - function(x) x) + env$intermediate_results <- lapply( + seq_len(length((df_list))), + function(x) x + ) for (i in seq_len(length(df_list))) { tryCatch( diff --git a/tsf/R/RunBatch.R b/tsf/R/RunBatch.R new file mode 100644 index 0000000..eea5806 --- /dev/null +++ b/tsf/R/RunBatch.R @@ -0,0 +1,134 @@ +#' Runs a batch of optimization tasks +#' +#' @export +#' @param case is a character argument which specifies the optimization case. +#' Either "dba_dye_const", "dba_host_const", "ida" or "gda" +#' @param lowerBounds is a numeric vector with the lower bounds for the optimization +#' @param upperBounds is a numeric vector with the upper bounds for the optimization +#' @param path is a character argument which specifies the path to the data +#' @param additionalParameters is a numeric vector with additional parameters +#' In case of *dba_dye_const* or *dba_host_const the order of the parameters is: *khd*, *I0*, *IHD* and *ID* +#' In case of *ida* and *ga* the order of the parameters is: *kg*, *I0*, *IHD* and *ID*. +#' @param seed is an optional integer argument defining the seed which is set directly for the optimization. In case the argument is not set the current time is used as seed. +#' @param npop is an optional integer argument defining the number of particles during optimization. The default value is set to 40. +#' @param ngen is an optional integer argument defining the number of generations of the particle swarm optimization. The default value is set to 200. +#' @param Topology is an optional character argument defining which topology should be used by the particle swarm algorithm. The options are "star" and "random". The default topology is the "random" topology. +#' @param errorThreshold is an optional numeric argument defining a sufficient small error which acts as a stop signal for the particle swarm algorithm. The default value is set to -Inf. +#' @param num_rep is an optional integer argument defining the number of replicates for each dataset +#' @param num_cores is an optional integer argument defining the maximum number of cores which should be used for the optimization +#' @examples +#' path <- paste0(system.file("examples", package = "tsf"), "/IDABatch.csv") +#' lowerBounds <- c( +#' kG = 1000, +#' I0 = 0, +#' IHD = 0, +#' ID = 0 +#' ) +#' upperBounds <- c( +#' kG = 10^8, +#' I0 = 100, +#' IHD = 10^7, +#' ID = 10^7 +#' ) +#' additionalParameters <- c( +#' host = 1e-6, +#' dye = 1e-6, +#' kHD = 3e6 +#' ) +#' tsf::batch( +#' "ida", +#' lowerBounds, upperBounds, +#' path, additionalParameters, +#' ngen = 20 +#' ) +batch <- function(case, + lowerBounds, upperBounds, + path, + additionalParameters, + seed = NA, npop = 40, ngen = 200, Topology = "random", + errorThreshold = -Inf, num_rep = 1, num_cores = 1) { + # import data + list_df <- importDataBatch(path) + if (!is.list(list_df)) { + return(ErrorClass$new("Could not import data")) + } + for (i in seq_along(list_df)) { + if (!is.data.frame(list_df[[i]])) { + return(ErrorClass$new("Found non data.frame entry")) + } + } + + # num cores calculation + size <- length(list_df) * num_rep + if (num_cores > size) { + num_cores <- size + } + + # seed case and generation of seeds + seed_case <- determine_seed_case(seed, num_rep) + seed_origin <- NULL + if (seed_case == 3) { + seed_origin <- seed + } + seeds <- numeric(size) + seeds_from <- 1:1e6 + for (i in seq_len(size)) { + if (seed_case == 1) { + seed <- sample(seeds_from, 1) + } else if (seed_case == 3) { + if (i %in% seq(1, size, num_rep)) { + seed <- seed_origin + } else { + seed <- sample(seeds_from, 1) + } + } else if (seed_case == 2) { + seed <- seed # TODO: check is this correct + } + seeds[i] <- seed + } + + # create message for each optimization + messages <- character(size) + counter_messages <- 1 + for (i in seq_len(length(list_df))) { + for (j in seq_len(num_rep)) { + messages[counter_messages] <- + paste0("Dataset = ", i, "; Replicate = ", j) + counter_messages <- counter_messages + 1 + } + } + + # 3. Fill task queue + dfs <- rep(list_df, each = num_rep) + tq <- TaskQueue$new( + case, + lowerBounds, upperBounds, dfs, + additionalParameters, seeds, + npop, ngen, Topology, errorThreshold, + messages, num_cores + ) + + # 4. assign tasks + tq$assign() + old_status <- "" + + while (TRUE) { + new_status <- tq$get_status(old_status) + cat(new_status) + cat("\n") + old_status <- new_status + if (!tq$queue_empty() && tq$check()) { + tq$assign() + } + if (tq$queue_empty()) break + Sys.sleep(1) + } + + list <- tq$seperate_results() + list( + list, + plotStates(list), + plotParams(list), + plotMetrices(list) + ) +} diff --git a/tsf/R/communicator.R b/tsf/R/communicator.R index deebd38..6efaa46 100644 --- a/tsf/R/communicator.R +++ b/tsf/R/communicator.R @@ -1,67 +1,31 @@ -#' Communicator class -#' @description a class for communicating via a temporary file -#' -#' @export -#' @import R6 Communicator <- R6::R6Class("Communicator", public = list( - #' @field file is a file which contains the current status file = NULL, - - #' @field result is a file in which data can be written or read information. result = NULL, - - #' @description - #' create a new Communicator Object initialize = function() { self$file <- tempfile() self$result <- tempfile() write("Ready", self$file) write("", self$result) }, - - #' @description - #' get the current status getStatus = function() { scan(self$file, what = "character", sep = "\n") }, - - #' @description - #' write a status to the status file - #' @param msg is the message which should be set in the file setStatus = function(msg) { write(msg, self$file) }, - - #' @description - #' write data to the result file - #' @param data is a string which should be written to the result file setData = function(data) { write(data, self$result) }, - - #' @description - #' get the current data from the result file getData = function() { scan(self$result, what = "character", sep = "\n") }, - - #' @description - #' set the status to "interrupt" interrupt = function() { self$setStatus("interrupt") }, - - #' @description - #' set the status to "ready" ready = function() { self$setStatus("ready") }, - - #' @description - #' write a status to the status file. - #' @param percComplete is the message which should be set in the file. - #' If percComplete is not passed than the message is set to "Running..." running = function(percComplete) { msg <- "Running..." if (!missing(percComplete)) { @@ -69,16 +33,9 @@ Communicator <- R6::R6Class("Communicator", } self$setStatus(msg) }, - - #' @description - #' Checks if the current status is "interrupt" isInterrupted = function() { self$getStatus() == "interrupt" }, - - #' @description - #' removes the temporary files. - #' \strong{This method has to be called at the end of the lifetime of the object!} destroy = function() { if (file.exists(self$file)) unlink(self$file) if (file.exists(self$result)) unlink(self$result) diff --git a/tsf/R/parameterSensitivity.R b/tsf/R/parameterSensitivity.R index d1323a6..bf53afe 100644 --- a/tsf/R/parameterSensitivity.R +++ b/tsf/R/parameterSensitivity.R @@ -45,7 +45,7 @@ sobolVariance <- function(lossFct, env, lb, ub, parameterNames, runAsShiny) { #' @export #' @import rootSolve #' @import ggplot2 -#' @import sensitivity +#' @rawNamespace import(sensitivity, except=c(print.src)) #' @param case is a character describing which system should be investigated. Either: #' "dba_host_const", "dba_dye_const", "ida" or "gda". #' @param parameters is a numeric vector containing already optimized parameter. diff --git a/tsf/R/pso.R b/tsf/R/pso.R index 632e795..034ad58 100644 --- a/tsf/R/pso.R +++ b/tsf/R/pso.R @@ -8,8 +8,6 @@ #' @import shinydashboard #' @import shinyjs #' @import openxlsx -#' @import future -#' @import promises #' @import DT #' @param env is something that is passed to the loss function in addition to the parameters which get optimized #' @param lb is a numeric vector defining the lower boundaries of the parameter @@ -132,21 +130,28 @@ pso <- function(env, lb, ub, loss, ngen, npop, error_threshold, global = FALSE, memory <- matrix(0, nrow = ngen * npop, ncol = npar) error_memory <- numeric(ngen * npop) - lb <- ifelse(lb == 0, 10^-15, lb) - ub <- ifelse(ub == 0, 10^-15, ub) - lb <- log(lb) - ub <- log(ub) - - for (i in seq(npop)) { - swarm[i, ] <- runif(npar, min = lb, max = ub) - swarm_errors[i] <- loss_fct(exp(swarm[i, ]), env) - swarm_bests[i] <- swarm_errors[i] - } + if (any(lb <= 0) || any(ub <= 0)) { + for (i in seq(npop)) { + swarm[i, ] <- runif(npar, min = lb, max = ub) + swarm_errors[i] <- loss_fct(swarm[i, ], env) + swarm_bests[i] <- swarm_errors[i] + } + } else { + lb <- ifelse(lb <= 0, 10^-15, lb) + ub <- ifelse(ub <= 0, 10^-15, ub) + lb <- log(lb) + ub <- log(ub) - swarm <- exp(swarm) - lb <- exp(lb) - ub <- exp(ub) + for (i in seq(npop)) { + swarm[i, ] <- runif(npar, min = lb, max = ub) + swarm_errors[i] <- loss_fct(exp(swarm[i, ]), env) + swarm_bests[i] <- swarm_errors[i] + } + swarm <- exp(swarm) + lb <- exp(lb) + ub <- exp(ub) + } global_best <- which.min(swarm_bests) global_best_vec <- swarm[global_best, ] global_best_error <- swarm_bests[global_best] @@ -220,12 +225,12 @@ pso <- function(env, lb, ub, loss, ngen, npop, error_threshold, global = FALSE, if (save_swarm) error_memory[((iter * npop) + i)] <- error if (!is.infinite(error) && !is.na(error) && - error < swarm_bests[i]) { + error < swarm_bests[i]) { swarm_bests[i] <- error swarm_best_params[i, ] <- swarm[i, ] } if (!is.infinite(error) && !is.na(error) && - error < global_best_error) { + error < global_best_error) { global_best <- i global_best_vec <- swarm[i, ] global_best_error <- error diff --git a/tsf/R/runApp.R b/tsf/R/runApp.R index d730317..9a58a51 100644 --- a/tsf/R/runApp.R +++ b/tsf/R/runApp.R @@ -5,12 +5,12 @@ #' @param port is a number defining the port to use. #' @rawNamespace import(shiny, except=c(dataTableOutput, renderDataTable, runExample)) #' @rawNamespace import(shinyWidgets, except=c(alert)) +#' @rawNamespace import(plotly, except=c(last_plot)) #' @import shinydashboard #' @import shinyjs #' @import openxlsx -#' @import future -#' @import promises #' @import DT +#' @import callr #' @examples #' \donttest{ #' tsf::runApp() diff --git a/tsf/inst/examples/IDABatch.csv b/tsf/inst/examples/IDABatch.csv new file mode 100644 index 0000000..cea56e8 --- /dev/null +++ b/tsf/inst/examples/IDABatch.csv @@ -0,0 +1,104 @@ +guest,signal +0,0.652593163 +1.00E-07,0.625830834 +2.00E-07,0.59760106 +3.00E-07,0.568336413 +4.00E-07,0.538605992 +5.00E-07,0.509076212 +6.00E-07,0.480442809 +7.00E-07,0.453345361 +8.00E-07,0.428286524 +9.00E-07,0.40558051 +1.00E-06,0.385344585 +1.10E-06,0.367529159 +1.20E-06,0.351968717 +1.30E-06,0.338434288 +1.40E-06,0.3266753 +1.50E-06,0.316447156 +1.60E-06,0.307526286 +1.70E-06,0.299716359 +1.80E-06,0.292849146 +1.90E-06,0.286782597 +2.00E-06,0.281397733 +2.10E-06,0.276595271 +2.20E-06,0.272292426 +2.30E-06,0.268420086 +2.40E-06,0.264920412 +2.50E-06,0.261744829 +2.60E-06,0.258852387 +2.70E-06,0.256208419 +2.80E-06,0.253783444 +2.90E-06,0.251552283 +3.00E-06,0.249493336 +3.10E-06,0.24758799 +3.20E-06,0.245820143 +3.30E-06,0.244175803 +3.40E-06,0.242642769 +3.50E-06,0.241210354 +3.60E-06,0.23986917 +3.70E-06,0.238610935 +3.80E-06,0.237428323 +3.90E-06,0.236314829 +4.00E-06,0.235264662 +4.10E-06,0.23427265 +4.20E-06,0.23333416 +4.30E-06,0.232445033 +4.40E-06,0.231601522 +4.50E-06,0.230800248 +4.60E-06,0.230038151 +4.70E-06,0.229312458 +4.80E-06,0.228620648 +4.90E-06,0.227960426 +6.00E-06,0.227329698 +guest,signal +0,0.652593163 +0.0000001,0.625830834 +0.0000002,0.59760106 +0.0000003,0.568336413 +0.0000004,0.538605992 +0.0000005,0.509076212 +0.0000006,0.480442809 +0.0000007,0.453345361 +0.0000008,0.428286524 +0.0000009,0.40558051 +0.000001,0.385344585 +0.0000011,0.367529159 +0.0000012,0.351968717 +0.0000013,0.338434288 +0.0000014,0.3266753 +0.0000015,0.316447156 +0.0000016,0.307526286 +0.0000017,0.299716359 +0.0000018,0.292849146 +0.0000019,0.286782597 +0.000002,0.281397733 +0.0000021,0.276595271 +0.0000022,0.272292426 +0.0000023,0.268420086 +0.0000024,0.264920412 +0.0000025,0.261744829 +0.0000026,0.258852387 +0.0000027,0.256208419 +0.0000028,0.253783444 +0.0000029,0.251552283 +0.000003,0.249493336 +0.0000031,0.24758799 +0.0000032,0.245820143 +0.0000033,0.244175803 +0.0000034,0.242642769 +0.0000035,0.241210354 +0.0000036,0.23986917 +0.0000037,0.238610935 +0.0000038,0.237428323 +0.0000039,0.236314829 +0.000004,0.235264662 +0.0000041,0.23427265 +0.0000042,0.23333416 +0.0000043,0.232445033 +0.0000044,0.231601522 +0.0000045,0.230800248 +0.0000046,0.230038151 +0.0000047,0.229312458 +0.0000048,0.228620648 +0.0000049,0.227960426 +0.000005,0.227329698 diff --git a/tsf/inst/tinytest/test_all.R b/tsf/inst/tinytest/test_all.R index ec4095b..6188082 100644 --- a/tsf/inst/tinytest/test_all.R +++ b/tsf/inst/tinytest/test_all.R @@ -1,5 +1,7 @@ library(tinytest) library(tsf) + +# Expect errors getError <- function(error) { error$message } @@ -10,28 +12,31 @@ f <- function(a, b, c) { } } b <- body(f)[[2]] -expect_equal( getError(tsf:::getAST(b)), paste0("Error: function ", "for" ," not allowed") ) +expect_equal(getError(tsf:::getAST(b)), paste0("Error: function ", "for", " not allowed")) path <- paste0(system.file("examples", package = "tsf"), "/IDA.txt") -expect_equal( is.data.frame(tsf:::importData(path)), TRUE) +expect_equal(is.data.frame(tsf:::importData(path)), TRUE) path <- paste0(system.file("examples", package = "tsf"), "/ImportFailsHere.txt") expect_equal(getError(tsf:::importData(path)), "Could not identify seperator in file") +# test pso rosenbrock <- function(parameter, env, Ignore) { value <- 0 for (i in 1:(length(parameter) - 1)) { - value <- value + - 100*(parameter[i + 1] - parameter[i]^2)^2 + + value <- value + + 100 * (parameter[i + 1] - parameter[i]^2)^2 + (1 - parameter[i])^2 } return(value) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(-10, 3), rep(10, 3), rosenbrock, 1000, 40, - 0.00001, TRUE, FALSE) -expect_equal( sum(res[[2]] - rep(1, 3)) < 1e-9, TRUE) +res <- tsf:::pso( + new.env(), rep(-10, 3), rep(10, 3), rosenbrock, 1000, 40, + 0.00001, TRUE, FALSE +) +expect_equal(sum(res[[2]] - rep(1, 3)) < 1e-9, TRUE) rastrigin <- function(x, env, Ignore) { A <- 10 @@ -40,75 +45,91 @@ rastrigin <- function(x, env, Ignore) { return(A * n + sum_val) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(-10, 3), rep(10, 3), rastrigin, 1000, 120, - 10^-14, TRUE, FALSE) -expect_equal( sum(res[[2]]) < 1e-9, TRUE) +res <- tsf:::pso( + new.env(), rep(-10, 3), rep(10, 3), rastrigin, 1000, 120, + 10^-14, TRUE, FALSE +) +expect_equal(sum(res[[2]]) < 1e-9, TRUE) sphere <- function(x, env, Ignore) { # x = (0, 0, ... 0) return(sum(x^2)) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(-10, 3), rep(10, 3), sphere, 1000, 120, - 10^-14, TRUE, FALSE) -expect_equal( sum(res[[2]]) < 1e-9, TRUE) +res <- tsf:::pso( + new.env(), rep(-10, 3), rep(10, 3), sphere, 1000, 120, + 10^-14, TRUE, FALSE +) +expect_equal(sum(res[[2]]) < 1e-9, TRUE) ackley <- function(x, env, Ignore) { # x = (0, 0, ... 0) n <- length(x) sum1 <- sum(x^2) sum2 <- sum(cos(2 * pi * x)) - return(-20 * exp(-0.2 * sqrt(sum1/n)) - exp(sum2/n) + 20 + exp(1)) + return(-20 * exp(-0.2 * sqrt(sum1 / n)) - exp(sum2 / n) + 20 + exp(1)) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(-10, 3), rep(10, 3), ackley, 6500, 120, - 10^-14, TRUE, FALSE) # here the random topology is worse than star but far better than for sphere, rastrigin or rosenbrock -expect_equal( sum(res[[2]]) < 1e-9, TRUE) +res <- tsf:::pso( + new.env(), rep(-10, 3), rep(10, 3), ackley, 6500, 120, + 10^-14, TRUE, FALSE +) # here the random topology is worse than star but far better than for sphere, rastrigin or rosenbrock +expect_equal(sum(res[[2]]) < 1e-9, TRUE) -michalewicz <- function(xx, env, Ignore) { +michalewicz <- function(xx, env, Ignore) { # 2D global min = -1.8013 at x(2.2, 1.57) - m = 10 + m <- 10 ii <- c(1:length(xx)) - sum <- sum(sin(xx) * (sin(ii*xx^2/pi))^(2*m)) + sum <- sum(sin(xx) * (sin(ii * xx^2 / pi))^(2 * m)) y <- -sum return(y) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(0, 2), rep(5, 2), michalewicz, 1200, 120, - -Inf, TRUE, FALSE) -expect_equal( sum(res[[2]] - c(2.2, 1.57)) < 1e-2 , TRUE) +res <- tsf:::pso( + new.env(), rep(0, 2), rep(5, 2), michalewicz, 1200, 120, + -Inf, TRUE, FALSE +) +expect_equal(sum(res[[2]] - c(2.2, 1.57)) < 1e-2, TRUE) set.seed(1234) -res <- tsf:::pso(new.env(), rep(0, 2), rep(5, 2), michalewicz, 1200, 120, - -Inf, FALSE, FALSE) -expect_equal( sum(res[[2]] - c(2.2, 1.57)) < 1e-2 , TRUE) +res <- tsf:::pso( + new.env(), rep(0, 2), rep(5, 2), michalewicz, 1200, 120, + -Inf, FALSE, FALSE +) +expect_equal(sum(res[[2]] - c(2.2, 1.57)) < 1e-2, TRUE) schwefel_222 <- function(x, env, Ignore) { # x = (0, 0, ... 0) return(max(abs(x))) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(-10, 2), rep(10, 2), schwefel_222, 2200, 80, - 1e-14, TRUE, FALSE) -expect_equal( sum(abs(res[[2]])) < 1e-12 , TRUE) +res <- tsf:::pso( + new.env(), rep(-10, 2), rep(10, 2), schwefel_222, 2200, 80, + 1e-14, TRUE, FALSE +) +expect_equal(sum(abs(res[[2]])) < 1e-12, TRUE) griewank <- function(x, env, Ignore) { # x = (0, 0, ... 0) n <- length(x) - sum1 <- sum(x^2)/4000 - prod1 <- prod(cos(x/sqrt(1:n))) + sum1 <- sum(x^2) / 4000 + prod1 <- prod(cos(x / sqrt(1:n))) return(sum1 - prod1 + 1) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(-10, 2), rep(10, 2), griewank, 2800, 120, - 1e-32, TRUE, FALSE) -expect_equal( sum(abs(res[[1]])) < 1e-12 , TRUE) -expect_equal( sum(abs(res[[2]])) < 1e-6 , TRUE) +res <- tsf:::pso( + new.env(), rep(-10, 2), rep(10, 2), griewank, 2800, 120, + 1e-32, TRUE, FALSE +) +expect_equal(sum(abs(res[[1]])) < 1e-12, TRUE) +expect_equal(sum(abs(res[[2]])) < 1e-6, TRUE) easom <- function(x, env, Ignore) { # global min -1 with x at pi, pi return(-cos(x[1]) * cos(x[2]) * exp(-((x[1] - pi)^2 + (x[2] - pi)^2))) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(-10, 2), rep(10, 2), easom, 2800, 120, - -1, TRUE, FALSE) -expect_equal( sum(res[[1]] + 1) < 1e-12 , TRUE) -expect_equal( sum(abs(res[[2]]) - c(pi, pi)) < 1e-6 , TRUE) +res <- tsf:::pso( + new.env(), rep(-10, 2), rep(10, 2), easom, 2800, 120, + -1, TRUE, FALSE +) +expect_equal(sum(res[[1]] + 1) < 1e-12, TRUE) +expect_equal(sum(abs(res[[2]]) - c(pi, pi)) < 1e-6, TRUE) egg_holder <- function(xx, env, Ignore) { # Global Minimum: f(x)≈−959.6407f(x)≈−959.6407 at x=(512,404.2319)x=(512,404.2319) @@ -120,17 +141,22 @@ egg_holder <- function(xx, env, Ignore) { return(y) } set.seed(1234) -res <- tsf:::pso(new.env(), rep(-512, 2), rep(512, 2), egg_holder, 2800, 120, - -959, FALSE, FALSE) -expect_equal( sum(res[[1]] + 1) < 1e-12 , TRUE) -expect_equal( sum(abs(res[[2]]) - c(512.404, 404.2319)) < 1e-6 , TRUE) +res <- tsf:::pso( + new.env(), rep(-512, 2), rep(512, 2), egg_holder, 2800, 120, + -959, FALSE, FALSE +) +expect_equal(sum(res[[1]] + 1) < 1e-12, TRUE) +expect_equal(sum(abs(res[[2]]) - c(512.404, 404.2319)) < 1e-6, TRUE) set.seed(1234) -res <- tsf:::pso(new.env(), rep(-512, 2), rep(512, 2), egg_holder, 2800, 120, - -959, TRUE, FALSE) -expect_equal( sum(res[[1]] + 1) < 1e-12 , TRUE) -expect_equal( sum(abs(res[[2]]) - c(512.404, 404.2319)) < 1e-6 , TRUE) +res <- tsf:::pso( + new.env(), rep(-512, 2), rep(512, 2), egg_holder, 2800, 120, + -959, TRUE, FALSE +) +expect_equal(sum(res[[1]] + 1) < 1e-12, TRUE) +expect_equal(sum(abs(res[[2]]) - c(512.404, 404.2319)) < 1e-6, TRUE) +# test sensitivity test_sensitivity_valid_input <- function() { path <- paste0(system.file("examples", package = "tsf"), "/IDA.txt") optimP <- data.frame(80699337.884, 0.000, 1251.928, 0.000) @@ -148,11 +174,12 @@ test_sensitivity_invalid_case <- function() { } test_sensitivity_invalid_case() +# test create polynom test_createPolynom_valid_input <- function() { f <- function() { - h + hd + -h0 = 0 - d + hd -d0 = 0 - hd / (h*d) -kd = 0 + h + hd + -h0 <- 0 + d + hd - d0 <- 0 + hd / (h * d) - kd <- 0 } elimVars <- c("h", "d") result <- createPolynom(f, elimVars) @@ -173,9 +200,9 @@ test_createPolynom_invalid_function() test_createPolynom_invalid_elimVars <- function() { f <- function() { - h + hd + -h0 = 0 - d + hd - d0 = 0 - hd / (h*d) - kd = 0 + h + hd + -h0 <- 0 + d + hd - d0 <- 0 + hd / (h * d) - kd <- 0 } elimVars <- "not_a_character_vector" result <- createPolynom(f, elimVars) @@ -185,8 +212,8 @@ test_createPolynom_invalid_elimVars() test_createPolynom_another_valid_input <- function() { f <- function() { # x = 0 and y = 2 - 3*y + 2*x - 6 = 0 - 5 * y - 2*x - 10 = 0 + 3 * y + 2 * x - 6 <- 0 + 5 * y - 2 * x - 10 <- 0 } elimVars <- c("y", "x") resultX <- createPolynom(f, elimVars) @@ -196,6 +223,7 @@ test_createPolynom_another_valid_input <- function() { } test_createPolynom_another_valid_input() +# test loss functions test_lossFctHG_valid_input <- function() { parameter <- c(0.5, 1, 2, 3) env <- new.env() @@ -233,6 +261,7 @@ test_lossFctGDA_valid_input <- function() { } test_lossFctGDA_valid_input() +# test opti test_hg <- function() { path <- paste0(system.file("examples", package = "tsf"), "/IDA.txt") df <- read.csv(path, header = FALSE, sep = "\t") @@ -246,10 +275,12 @@ test_hg <- function() { file <- tempfile(fileext = ".txt") write.csv(df, file, quote = FALSE, row.names = FALSE) set.seed(1234) - res <- tsf::opti("hg", c(1, 0, 0, 0), c(10^9, 1, rep(10^5, 2)), file, env$h0, - 40, 100) - expect_true(res[[4]]$r2 > 0.99) - expect_true( (res[[2]]$IHD - 1000) < 1) + res <- tsf::opti( + "dba_host_const", c(1, 0, 0, 0), c(10^9, 1, rep(10^5, 2)), file, env$h0, + 40, 100 + ) + expect_true(res[[4]]$R2 > 0.99) + expect_true((res[[2]][3] - 1000) < 1) } test_hg() @@ -268,19 +299,21 @@ test_ida <- function() { file <- tempfile(fileext = ".txt") write.csv(df, file, quote = FALSE, row.names = FALSE) set.seed(1234) - res <- tsf::opti("ida", c(1, 0, 0, 0), c(10^9, 1, rep(10^5, 2)), file, c(env$h0, env$d0, env$kd), - 40, 150) - expect_true(res[[4]]$r2 > 0.99) - expect_true( (res[[2]]$IHD - 1000) < 10) + res <- tsf::opti( + "ida", c(1, 0, 0, 0), c(10^9, 1, rep(10^5, 2)), file, c(env$h0, env$d0, env$kd), + 40, 150 + ) + expect_true(res[[4]]$R2 > 0.99) + expect_true((res[[2]][3] - 1000) < 10) } test_ida() test_gda <- function() { env <- new.env() env$h0 <- 1.65 - env$kd <- 1.7*10^7 + env$kd <- 1.7 * 10^7 env$ga0 <- 1.8 - parameter <- c(1857463, 0, 3456.443, 0) + parameter <- c(1857463, 0, 3456.443, 0) path <- paste0(system.file("examples", package = "tsf"), "/GDA.txt") df <- read.csv(path, header = TRUE, sep = ",") env$dye <- df[, 1] @@ -290,10 +323,43 @@ test_gda <- function() { file <- tempfile(fileext = ".txt") write.csv(df, file, quote = FALSE, row.names = FALSE) set.seed(1234) - res <- tsf::opti("gda", c(1, 0, 0, 0), c(10^9, 1, rep(10^6, 2)), file, - additionalParameters = c(env$h0, env$ga0, env$kd), - 40, 175) - expect_true(res[[4]]$r2 > 0.99) - expect_true( abs(res[[2]]$IHD - 3456) < 100) + res <- tsf::opti("gda", c(1, 0, 0, 0), c(10^9, 1, rep(10^6, 2)), file, + additionalParameters = c(env$h0, env$ga0, env$kd), + 40, 175 + ) + expect_true(res[[4]]$R2 > 0.99) + expect_true(abs(res[[2]][3] - 3456) < 100) } test_gda() + +# tests batch +test_batch <- function() { + path <- paste0(system.file("examples", package = "tsf"), "/IDABatch.csv") + lowerBounds <- c( + kG = 1000, + I0 = 0, + IHD = 0, + ID = 0 + ) + upperBounds <- c( + kG = 10^8, + I0 = 100, + IHD = 10^7, + ID = 10^7 + ) + additionalParameters <- c( + host = 1e-6, + dye = 1e-6, + kHD = 3e6 + ) + res <- tsf::batch( + "ida", + lowerBounds, upperBounds, + path, additionalParameters, + ngen = 20, + num_cores = 2 + ) + lapply(res[[1]], function(x) { + expect_true(x[[4]]$R2 > 0.99) + }) +} diff --git a/tsf/man/Communicator.Rd b/tsf/man/Communicator.Rd deleted file mode 100644 index 7347cd4..0000000 --- a/tsf/man/Communicator.Rd +++ /dev/null @@ -1,174 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/communicator.R -\name{Communicator} -\alias{Communicator} -\title{Communicator class} -\description{ -a class for communicating via a temporary file -} -\section{Public fields}{ -\if{html}{\out{
}} -\describe{ -\item{\code{file}}{is a file which contains the current status} - -\item{\code{result}}{is a file in which data can be written or read information.} -} -\if{html}{\out{
}} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-Communicator-new}{\code{Communicator$new()}} -\item \href{#method-Communicator-getStatus}{\code{Communicator$getStatus()}} -\item \href{#method-Communicator-setStatus}{\code{Communicator$setStatus()}} -\item \href{#method-Communicator-setData}{\code{Communicator$setData()}} -\item \href{#method-Communicator-getData}{\code{Communicator$getData()}} -\item \href{#method-Communicator-interrupt}{\code{Communicator$interrupt()}} -\item \href{#method-Communicator-ready}{\code{Communicator$ready()}} -\item \href{#method-Communicator-running}{\code{Communicator$running()}} -\item \href{#method-Communicator-isInterrupted}{\code{Communicator$isInterrupted()}} -\item \href{#method-Communicator-destroy}{\code{Communicator$destroy()}} -\item \href{#method-Communicator-clone}{\code{Communicator$clone()}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-new}{}}} -\subsection{Method \code{new()}}{ -create a new Communicator Object -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$new()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-getStatus}{}}} -\subsection{Method \code{getStatus()}}{ -get the current status -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$getStatus()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-setStatus}{}}} -\subsection{Method \code{setStatus()}}{ -write a status to the status file -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$setStatus(msg)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{msg}}{is the message which should be set in the file} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-setData}{}}} -\subsection{Method \code{setData()}}{ -write data to the result file -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$setData(data)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{data}}{is a string which should be written to the result file} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-getData}{}}} -\subsection{Method \code{getData()}}{ -get the current data from the result file -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$getData()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-interrupt}{}}} -\subsection{Method \code{interrupt()}}{ -set the status to "interrupt" -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$interrupt()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-ready}{}}} -\subsection{Method \code{ready()}}{ -set the status to "ready" -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$ready()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-running}{}}} -\subsection{Method \code{running()}}{ -write a status to the status file. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$running(percComplete)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{percComplete}}{is the message which should be set in the file. -If percComplete is not passed than the message is set to "Running..."} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-isInterrupted}{}}} -\subsection{Method \code{isInterrupted()}}{ -Checks if the current status is "interrupt" -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$isInterrupted()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-destroy}{}}} -\subsection{Method \code{destroy()}}{ -removes the temporary files. -\strong{This method has to be called at the end of the lifetime of the object!} -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$destroy()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Communicator-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Communicator$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/tsf/man/batch.Rd b/tsf/man/batch.Rd new file mode 100644 index 0000000..f4be24e --- /dev/null +++ b/tsf/man/batch.Rd @@ -0,0 +1,78 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/RunBatch.R +\name{batch} +\alias{batch} +\title{Runs a batch of optimization tasks} +\usage{ +batch( + case, + lowerBounds, + upperBounds, + path, + additionalParameters, + seed = NA, + npop = 40, + ngen = 200, + Topology = "random", + errorThreshold = -Inf, + num_rep = 1, + num_cores = 1 +) +} +\arguments{ +\item{case}{is a character argument which specifies the optimization case. +Either "dba_dye_const", "dba_host_const", "ida" or "gda"} + +\item{lowerBounds}{is a numeric vector with the lower bounds for the optimization} + +\item{upperBounds}{is a numeric vector with the upper bounds for the optimization} + +\item{path}{is a character argument which specifies the path to the data} + +\item{additionalParameters}{is a numeric vector with additional parameters +In case of \emph{dba_dye_const} or *dba_host_const the order of the parameters is: \emph{khd}, \emph{I0}, \emph{IHD} and \emph{ID} +In case of \emph{ida} and \emph{ga} the order of the parameters is: \emph{kg}, \emph{I0}, \emph{IHD} and \emph{ID}.} + +\item{seed}{is an optional integer argument defining the seed which is set directly for the optimization. In case the argument is not set the current time is used as seed.} + +\item{npop}{is an optional integer argument defining the number of particles during optimization. The default value is set to 40.} + +\item{ngen}{is an optional integer argument defining the number of generations of the particle swarm optimization. The default value is set to 200.} + +\item{Topology}{is an optional character argument defining which topology should be used by the particle swarm algorithm. The options are "star" and "random". The default topology is the "random" topology.} + +\item{errorThreshold}{is an optional numeric argument defining a sufficient small error which acts as a stop signal for the particle swarm algorithm. The default value is set to -Inf.} + +\item{num_rep}{is an optional integer argument defining the number of replicates for each dataset} + +\item{num_cores}{is an optional integer argument defining the maximum number of cores which should be used for the optimization} +} +\description{ +Runs a batch of optimization tasks +} +\examples{ +path <- paste0(system.file("examples", package = "tsf"), "/IDABatch.csv") +lowerBounds <- c( + kG = 1000, + I0 = 0, + IHD = 0, + ID = 0 +) +upperBounds <- c( + kG = 10^8, + I0 = 100, + IHD = 10^7, + ID = 10^7 +) +additionalParameters <- c( + host = 1e-6, + dye = 1e-6, + kHD = 3e6 +) +tsf::batch( + "ida", + lowerBounds, upperBounds, + path, additionalParameters, + ngen = 20 +) +} diff --git a/tsf/man/pso.Rd b/tsf/man/pso.Rd index e84581c..4465c1d 100644 --- a/tsf/man/pso.Rd +++ b/tsf/man/pso.Rd @@ -13,8 +13,8 @@ pso( npop, error_threshold, global = FALSE, - saveSwarm = FALSE, - runAsShiny = FALSE, + save_swarm = FALSE, + run_as_shiny = FALSE, add_message = "" ) } @@ -40,9 +40,9 @@ a neighberhood which contains K neighbours where K is between 0 and 3. From the drawn randomly. From the neighberhood the best particle is used for comparison. The neighberhood is calculated for each generation.} -\item{saveSwarm}{is a logical value defining whether the entire optimization should be saved.} +\item{save_swarm}{is a logical value defining whether the entire optimization should be saved.} -\item{runAsShiny}{is an internal parameter which is used when running the shiny app interface.} +\item{run_as_shiny}{is an internal parameter which is used when running the shiny app interface.} \item{add_message}{is an optional character argument which is printed during optimization} }