R/util.R

In jlmelville/mizer: Unconstrained Numerical Optimization Algorithms

# partial function application
partial <- function(f, ...) {
  args <- list(...)
  function(...) {
    do.call(f, c(args, list(...)))
  }
}

# Square of the Euclidean norm of a vector
sqnorm2 <- function(v) {
  dot(v)
}

# l1 norm of a vector
norm1 <- function(v) {
  sum(abs(v))
}

# l2 (Euclidean) norm of a vector
norm2 <- function(v) {
  sqrt(dot(v))
}

# Infinity norm of a vector
norm_inf <- function(v) {
  max(abs(v))
}

# normalize a vector to length 1
normalize <- function(v) {
  l <- norm2(v)
  if (l < .Machine$double.eps) {
    v
  }
  else {
    v / norm2(v)
  }
}

# dot product of a and b
dot <- function(a, b = a) {
  sum(a * b)
}

clamp <- function(x, min_val = .Machine$double.eps, max_val = NULL) {
  x[x < min_val] <- min_val
  if (!is.null(max_val)) {
    x[x > max_val] <- max_val
  }
  x
}

sclamp <- function(x, min, max) {
  base::min(base::max(x, min), max)
}

vec_formatC <- function(v) {
  paste(Map(function(x) {
    formatC(x)
  }, v), collapse = ", ")
}

# convert a list to a strng
format_list <- function(ll) {
  Reduce(
    function(acc, elem) {
      paste0(
        acc,
        ifelse(nchar(acc) == 0, "", " "),
        elem,
        " = ",
        ifelse(length(ll[[elem]]) == 1,
          formatC(ll[[elem]]), vec_formatC(ll[[elem]])
        )
      )
    },
    names(ll), ""
  )
}

# returns TRUE if x is in the range (left, right). By default, this is
# an open range, i.e. x == left and x == right is in the range.
# lopen if FALSE then range is [left, right) i.e. x = left is not in the range
# ropen if FALSE then range is (left, right] i.e. x = right is not in the range
is_in_range <- function(x, left, right, lopen = TRUE, ropen = TRUE) {
  `%lop%` <- ifelse(lopen, `<=`, `<`)
  `%rop%` <- ifelse(ropen, `<=`, `<`)

  left %lop% x && x %rop% right
}

# Checks if nullable x is finite
is_finite_numeric <- function(x) {
  is.numeric(x) && is.finite(x)
}

# Logging Hooks -----------------------------------------------------------


require_log_vals <- function(opt, stage, par, fg, iter) {
  message(
    iter, " ", substr(stage$type, 1, 2),
    " par = ", vec_formatC(par),
    " p = ", vec_formatC(stage$direction$value),
    " a = ", formatC(stage$step_size$value),
    " ap = ", vec_formatC(stage$result),
    " f = ", formatC(fg$fn(par))
  )
  list(opt = opt)
}
attr(require_log_vals, "name") <- "log_vals"
attr(require_log_vals, "event") <- "after stage"

require_keep_stage_fs <- function(opt, stage, par, fg, iter) {
  if (is.null(opt$all_fs)) {
    opt$all_fs <- c()
  }
  f <- fg$fn(par)
  opt$all_fs <- c(opt$all_fs, f)
  list(opt = opt)
}
attr(require_keep_stage_fs, "name") <- "require_keep_stage_fs"
attr(require_keep_stage_fs, "event") <- "after stage"