version 1.0.0

DESCRIPTION

@@ -0,0 +1,48 @@
+Package: hmsr
+Title: Multipopulation Evolutionary Strategy HMS
+Version: 1.0.0
+Authors@R: c(
+    person(given = "Wojciech",
+           family = "Achtelik",
+           role = c("aut", "cre"),
+           email = "wachtelik@gmail.com"),
+    person(given = "Marcin",
+           family = "Kozubek",
+           role = "aut",
+           email = "mkozubek@protonmail.com"),
+    person(given = "Maciej",
+           family = "Smołka",
+           role = c("ths", "aut"),
+           email = "smolka@agh.edu.pl",
+           comment = c(ORCID = "0000-0002-3386-0555", "Java original")),
+    person(given = "AGH University of Kraków",
+           role = "cph"
+    ))
+Description: 
+  The HMS (Hierarchic Memetic Strategy) is a composite global optimization
+  strategy consisting of a multi-population evolutionary strategy and some
+  auxiliary methods. The HMS makes use of a dynamically-evolving data structure
+  that provides an organization among the component populations. It is a tree
+  with a fixed maximal height and variable internal node degree. Each component
+  population is governed by a particular evolutionary engine. This package
+  provides a simple R implementation with examples of using different genetic
+  algorithms as the population engines. References: J. Sawicki, M. Łoś,
+  M. Smołka, J. Alvarez-Aramberri (2022) <doi:10.1007/s11047-020-09836-w>.
+License: MIT + file LICENSE
+Encoding: UTF-8
+RoxygenNote: 7.1.2
+Imports: GA, msm, methods, uuid, graphics
+Suggests: testthat (>= 3.0.0), ecr, filelock, parallel, doParallel,
+        grDevices, smoof
+BugReports: https://github.com/WojtAcht/hms/issues
+URL: https://wojtacht.github.io/hms/
+NeedsCompilation: no
+Packaged: 2023-10-11 16:40:53 UTC; wojciechachtelik
+Author: Wojciech Achtelik [aut, cre],
+  Marcin Kozubek [aut],
+  Maciej Smołka [ths, aut] (<https://orcid.org/0000-0002-3386-0555>, Java
+    original),
+  AGH University of Kraków [cph]
+Maintainer: Wojciech Achtelik <wachtelik@gmail.com>
+Repository: CRAN
+Date/Publication: 2023-10-12 06:10:02 UTC

LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2023
+COPYRIGHT HOLDER: AGH University of Kraków

MD5

@@ -0,0 +1,59 @@
+de994a43d48dfa8a121dae5a7229e019 *DESCRIPTION
+73dc907b9f2d20015786a7f40e3c9ff3 *LICENSE
+8455034c510f6eb4a7d0138bdc8bf388 *NAMESPACE
+febc4f16aef430c1874b458acd854db4 *NEWS.md
+fc1df8ec568e0a5bffce61246e49fda6 *R/default_parameters.R
+3d6562ccf846ec332f11721c29b2e6c5 *R/deme.R
+49237c9da65f080f76e700ccb7c85f05 *R/ecr_metaepoch.R
+556b0932ee3aa8dae5ff370078f7cdfb *R/ga_metaepoch.R
+04f700b7adc45e51a1b2e09d0bd69344 *R/global_stopping_condition.R
+d0c0a927ff4ac81645b91cd8a34322ef *R/gradient_method.R
+3587cf7efd81dcd529bc04e5021cb2db *R/hms.R
+653eb1de3d052eeda34cc2faca9f0e6c *R/hms_class.R
+7435d1418df96e2d840ac44493329794 *R/local_stopping_condition.R
+090571a3a944b647cc3d6f1d1e9b2d9e *R/monitor.R
+5edb83f801232dd3cfc5dd231daa6434 *R/mutation.R
+a86b8004cd5dc57c2678dcdb2df301e5 *R/sprouting_condition.R
+244cb4d5e17add77244f1eacfd1a961d *R/start_message.R
+4e0d2b6b1da5e97ff3541668e52081ed *R/utils.R
+8cd69edc16de2228aa1b3fe3d986b0dc *README.md
+5573b430a89e65de4f8b18640bba9db4 *man/MetaepochSnapshot-class.Rd
+ceb14c5ca5d489b6cb1a951dc9b8e4ba *man/default_run_gradient_method.Rd
+d3f643304c16622d5d0e74b5e0617fbb *man/ecr_metaepoch.Rd
+1c38983c1863be7a5ab8387933aa09c4 *man/euclidean_distance.Rd
+d78757971a9f6c4cecc075724315de6a *man/ga_metaepoch.Rd
+3e315f621fdcea4268d7b4fe32153e0d *man/gsc_max_fitness_evaluations.Rd
+4052b81b322f1e7cb84ac6d5ee776cca *man/gsc_metaepochs_count.Rd
+f5478a22d7ea253094a691b2525a5da5 *man/gsc_trivial.Rd
+27c9b3e43c2aa7c9984127966e2e006d *man/hms-class.Rd
+58ad62131edc8bf189bf0b00d1aee2ae *man/hms.Rd
+ad4a98eba182ef6179a73d798c0b9eab *man/lsc_max_fitness_evaluations.Rd
+237286c6f7d1a63656fcf947cdd84d98 *man/lsc_metaepochs_without_active_child.Rd
+637721ae6013fe74d123d7365909ec49 *man/lsc_metaepochs_without_improvement.Rd
+dc0091ca7a569fd43d3e2f1dde3ee2de *man/lsc_trivial.Rd
+a72e82e3d247c449a596d5e0fbddaca8 *man/manhattan_distance.Rd
+fb57490450124369d2944abbc7b96d6f *man/plot-hms-method.Rd
+1b364ab4fcc19915420f023b2bc82289 *man/plotActiveDemes-hms-method.Rd
+bcf3c38a7f5f111e015222b72d7dc841 *man/plotActiveDemes.Rd
+41e9c235bc55b50515158222d05899c7 *man/plotPopulation-hms-method.Rd
+5ec1fae93051b436b3c87864d42ba713 *man/plotPopulation.Rd
+aa34b8921b673036af2617668dd328d3 *man/print-hms-method.Rd
+67bc6af4ef72040f38193c47e56dbf39 *man/printBlockedSprouts-hms-method.Rd
+49482fbcab7a1fb2db4c51b862bf1c70 *man/printBlockedSprouts.Rd
+daf8cf3efafa4e09e8edc04f0871cba4 *man/printTree-hms-method.Rd
+5ed9aca087974e2d51af6876967727bc *man/printTree.Rd
+1f9ff3f729689c9f4ffd0e18ec332d66 *man/rtnorm_mutation.Rd
+5a2ff369f9bccefb467c03bc8f789e9b *man/saveMetaepochsPopulations-hms-method.Rd
+0d381df3ee7417ad9f89859aaafad69a *man/saveMetaepochsPopulations.Rd
+b43e679550aefba7795ee68abc2664aa *man/sc_max_metric.Rd
+0e2688bf28f6b8b5f47f9acbc7615260 *man/show-hms-method.Rd
+773119a2e12336093e33a5adccd2da3a *man/summary-hms-method.Rd
+252721a9d7c533dcd82621cc2c002fba *tests/testthat.R
+0dfb36f74a641cea3a6261d7a7808366 *tests/testthat/test-conditions.R
+6c7ccdd715edda27ded51c4b7a3e1d2f *tests/testthat/test-default-parameters.R
+e2fa661300951d7b2f022236b390ad15 *tests/testthat/test-deme.R
+d1707ade2a47cf027c0bf2375f02ddb2 *tests/testthat/test-hms-class.R
+c090441b9f74dc7206f8c284018065f7 *tests/testthat/test-hms-validation.R
+23ae268be941b9f6bcc8d160740302ba *tests/testthat/test-hms.R
+cce5f003799884e00d4c5b640479831f *tests/testthat/test-monitor.R
+b245f96417f0faf8a243beff17a9dfbb *tests/testthat/test-utils.R

NAMESPACE

@@ -0,0 +1,33 @@
+# Generated by roxygen2: do not edit by hand
+
+importFrom(methods, show)
+export(ecr_metaepoch)
+export(euclidean_distance)
+export(ga_metaepoch)
+export(gsc_max_fitness_evaluations)
+export(gsc_metaepochs_count)
+export(gsc_trivial)
+export(hms)
+export(lsc_max_fitness_evaluations)
+export(lsc_metaepochs_without_active_child)
+export(lsc_metaepochs_without_improvement)
+export(lsc_trivial)
+export(manhattan_distance)
+export(plotActiveDemes)
+export(plotPopulation)
+export(printBlockedSprouts)
+export(printTree)
+export(rtnorm_mutation)
+export(saveMetaepochsPopulations)
+export(sc_max_metric)
+exportClasses(MetaepochSnapshot)
+exportClasses(hms)
+exportMethods(plot)
+exportMethods(plotActiveDemes)
+exportMethods(plotPopulation)
+exportMethods(print)
+exportMethods(printBlockedSprouts)
+exportMethods(printTree)
+exportMethods(saveMetaepochsPopulations)
+exportMethods(show)
+exportMethods(summary)

NEWS.md

@@ -0,0 +1,5 @@
+# hmsr 1.0.0
+
+# hmsr 0.0.0.9000
+
+* Added a `NEWS.md` file to track changes to the package.

R/default_parameters.R

@@ -0,0 +1,29 @@
+default_population_sizes <- function(tree_height) {
+  population_size <- 60
+  population_size_ratio <- 0.5
+  population_sizes <- c()
+  for (height in 1:tree_height) {
+    population_sizes <- c(population_sizes, population_size)
+    population_size <- round(population_size * population_size_ratio)
+  }
+  population_sizes
+}
+
+default_sigma <- function(lower, upper, tree_height) {
+  sigma_ratio <- 0.04
+  sigma_exponent <- 0.5
+  domain_length <- upper - lower
+  sigma <- list()
+  for (height in 1:tree_height) {
+    sigma <- c(sigma, list(domain_length * sigma_ratio))
+    sigma_ratio <- sigma_ratio * sigma_exponent
+  }
+  sigma
+}
+
+default_gradient_method_args <- list(
+  method = "L-BFGS-B",
+  poptim = 0.05,
+  pressel = 0.5,
+  control = list(fnscale = -1, maxit = 100)
+)

R/deme.R

@@ -0,0 +1,121 @@
+setClassUnion("numericOrNULL", members = c("numeric", "NULL"))
+setClassUnion("characterOrNULL", members = c("character", "NULL"))
+
+setClass("Deme", slots = c(
+  id = "character",
+  population = "matrix",
+  level = "numeric",
+  best_fitness = "numeric",
+  best_solution = "numeric",
+  best_solutions_per_metaepoch = "list",
+  best_fitnesses_per_metaepoch = "list",
+  sprout = "numericOrNULL",
+  parent_id = "characterOrNULL",
+  evaluations_count = "numeric",
+  is_active = "logical"
+))
+
+rnorm_population <- function(mean, lower, upper, population_size, tree_level, sigma) {
+  sd <- sigma[[tree_level]]
+  random_coordinate <- function(i) {
+    msm::rtnorm(
+      mean = mean[[i]],
+      sd = sd[[i]],
+      lower = lower[[i]],
+      upper = upper[[i]],
+      n = population_size - 1
+    )
+  }
+  population <- mapply(random_coordinate, seq_along(lower))
+  rbind(population, mean)
+}
+
+runif_population <- function(mean, lower, upper, population_size, tree_level, sigma) {
+  random_coordinate <- function(i) {
+    stats::runif(population_size,
+      min = lower[[i]],
+      max = upper[[i]]
+    )
+  }
+  mapply(random_coordinate, seq_along(lower))
+}
+
+default_create_population <- function(sigma) {
+  function(mean, lower, upper, population_size, tree_level) {
+    if (tree_level == 1) {
+      runif_population(mean, lower, upper, population_size, tree_level, sigma)
+    } else {
+      rnorm_population(mean, lower, upper, population_size, tree_level, sigma)
+    }
+  }
+}
+
+create_deme <- function(lower, upper, parent, population_size, create_population) {
+  new_deme_level <- ifelse(is.null(parent), 1, parent@level + 1)
+  new_sprout <- if (is.null(parent)) {
+    NULL
+  } else {
+    unlist(utils::tail(parent@best_solutions_per_metaepoch, n = 1))
+  }
+  new_population <- create_population(
+    mean = new_sprout,
+    lower = lower,
+    upper = upper,
+    population_size = population_size,
+    tree_level = new_deme_level
+  )
+  if (any(dim(new_population) != c(population_size, length(lower)))) {
+    stop("Created population is invalid - wrong dimensions.")
+  }
+  methods::new("Deme",
+    population = new_population,
+    level = new_deme_level,
+    sprout = new_sprout,
+    id = uuid::UUIDgenerate(),
+    parent_id = if (is.null(parent)) NULL else parent@id,
+    evaluations_count = 0,
+    is_active = TRUE
+  )
+}
+
+update_deme <- function(metaepoch_result, deme, minimize = FALSE) {
+  if (is.null(metaepoch_result$solution) |
+    is.null(metaepoch_result$value) |
+    is.null(metaepoch_result$population) |
+    !is.numeric(metaepoch_result$solution) |
+    !is.numeric(metaepoch_result$value) |
+    !is.numeric(metaepoch_result$population)) {
+    stop("The run_metaepoch function must return a list with following named parameters of type numeric: solution, value, population")
+  }
+  if (any(dim(metaepoch_result$population) != dim(deme@population))) {
+    stop("The run_metaepoch function must return population with matching dimensions.")
+  }
+  if (length(metaepoch_result$solution) != dim(deme@population)[[2]]) {
+    stop("The run_metaepoch function must return solution with matching dimensions.")
+  }
+  if (length(metaepoch_result$value) != 1) {
+    stop("The run_metaepoch function must return 1D value.")
+  }
+
+  potential_sprout <- metaepoch_result$solution
+  metaepoch_best <- metaepoch_result$value
+  deme@population <- metaepoch_result$population
+  deme@best_fitnesses_per_metaepoch <- c(deme@best_fitnesses_per_metaepoch, list(metaepoch_best))
+  deme@best_solutions_per_metaepoch <- c(deme@best_solutions_per_metaepoch, list(potential_sprout))
+  min_value <- ifelse(minimize, Inf, -Inf)
+  deme_best <- ifelse(length(deme@best_fitness) == 0, min_value, deme@best_fitness)
+  operator <- ifelse(minimize, `<`, `>`)
+  if (operator(metaepoch_best, deme_best)) {
+    deme@best_fitness <- metaepoch_best
+    deme@best_solution <- potential_sprout
+  }
+  deme
+}
+
+is_leaf <- function(deme, tree_height) {
+  length(deme@best_fitness) != 0 & deme@level == tree_height
+}
+
+is_root <- function(deme) {
+  deme@level == 1
+}

R/ecr_metaepoch.R

@@ -0,0 +1,53 @@
+#' Function that runs one ecr metaepoch. Wrapper function for ecr::ecr.
+#'
+#' @param config_ecr - list of ecr::ecr params
+#'
+#' @return list with named fields: solution, population, value. See
+#' \code{\link{ga_metaepoch}} for more details.
+#'
+#' @export
+#'
+#' @examples
+#' tree_height <- 3
+#' empty_config_ecr <- lapply(1:tree_height, function(x) {
+#'   list()
+#' })
+#' ecr_metaepoch(empty_config_ecr)
+ecr_metaepoch <- function(config_ecr) { # nocov start
+  function(fitness, suggestions, lower, upper, tree_level, minimize) {
+    config <- config_ecr[[tree_level]]
+    legal_passed_param_names <- Filter(function(name) {
+      name %in% methods::formalArgs(ecr::ecr)
+    }, names(config))
+    population_size <- nrow(suggestions)
+    iterations_count <- 5
+    params <- list(
+      "mu" = population_size,
+      "mutator" = ecr::setup(ecr::mutGauss, lower = lower, upper = upper),
+      "lambda" = 1L
+    )
+    for (param_name in legal_passed_param_names) {
+      params[param_name] <- config[param_name]
+    }
+    params$fitness.fun <- fitness
+    params$n.objectives <- 1L
+    params$minimize <- minimize
+    params$lower <- lower
+    params$upper <- upper
+    params$n.dim <- length(lower)
+    params$initial.solutions <- matrix_to_list(suggestions)
+    params$representation <- "float"
+    params$monitor <- FALSE
+    params$terminators <- list(ecr::stopOnIters(max.iter = iterations_count * population_size))
+    result <- do.call(ecr::ecr, params)
+    population <- list_to_matrix(result$last.population, length(lower))
+    list("solution" = result$best.x[[1]], "population" = population, "value" = result$best.y[[1]])
+  }
+}
+
+default_ecr_metaepoch <- function(tree_height) {
+  empty_config_ecr <- lapply(1:tree_height, function(x) {
+    list()
+  })
+  ecr_metaepoch(empty_config_ecr)
+} # nocov end