R/helpers.R

check.equal = function(x, y) {
  isTRUE(all.equal(y, x, check.attributes = FALSE))
}

## Generates the i-th unit vector of length n
unit = function(i, n) {
  checkmate::checkInt(n, na.ok = FALSE, lower = 1L)
  checkmate::checkInt(i, na.ok = FALSE, lower = 1L, upper = n)
  unit.vector = c(rep(0, i-1), 1, rep(0, n-i))
  return(unit.vector)
}

repairCorrMat = function(corr.mat, lowest.eigen.value = 1e-8, info = TRUE) {
  chol.error = TRUE
  new.mat = corr.mat

  iter = 0
  chol.error = TRUE
  while (chol.error) {
    iter = iter + 1
    if (info)
      cat("repair correlation matrix - iteration ", iter, "\n")

    ## replace negative eigen values with small positive number
    new.eig = eigen(new.mat)
    new.eig2 = ifelse(new.eig$values <= 0, lowest.eigen.value, new.eig$values)

    ## create modified matrix, eqn 5 from Brissette et al 2007, inv = transp for eig vectors
    new.mat = new.eig$vectors %*% diag(new.eig2) %*% t(new.eig$vectors)

    ## normalize modified matrix, eqn 6 from Brissette et al 2007
    new.mat = new.mat/sqrt(diag(new.mat) %*% t(diag(new.mat)))

    ## try Cholesky decomposition
    chol.status = try(u <- chol(new.mat), silent = TRUE)
    chol.error = ifelse(class(chol.status) == "try-error", TRUE, FALSE)
    if (chol.error && iter >= 20)
      stop("Could not repair categorical correlation matrix.")
  }
  return(new.mat)
}

#' @title Check if Object is \code{\link[=makeCCKriging]{CCKriging}} Model
#'
#' @description Check if any object is a \code{\link[=makeCCKriging]{CCKriging}} model.
#'   If so, this function returns \code{TRUE}, else \code{FALSE}.
#'
#' @param object [any]
#'   The object that should be checked.
#' @return [\code{logical(1)}]
#' @export
isCCKriging = function(object) {
  return(inherits(object, "CCKriging"))
}

#' @title Get Categorical Inputs
#'
#' @description Given a \code{data.frame} or a \code{\link[=makeCCKriging]{CCKriging}} model,
#'   this function returns the categorical columns of this \code{data.frame} or the
#'   corresponding design points, respectively.
#'
#' @param object [\code{data.frame} or \code{\link[=makeCCKriging]{CCKriging}}]
#'
#' @return [\code{data.frame}]
#' @export
getCatInputs = function(object) {
  if (isCCKriging(object)) {
    x = object$x
  } else if (is.data.frame(object)) {
    x = object
  } else {
    stop("Categorical inputs can only be extracted from a data.frame or CCKriging model.")
  }
  cat.inds = sapply(x, is.factor)
  return(x[, cat.inds, drop = FALSE])
}

#' @title Get Continuous Inputs
#'
#' @description Given a \code{data.frame} or a \code{\link[=makeCCKriging]{CCKriging}} model,
#'   this function returns the continuous columns of this \code{data.frame} or the
#'   corresponding design points, respectively.
#'
#' @param object [\code{data.frame} or \code{\link[=makeCCKriging]{CCKriging}}]
#'
#' @return [\code{data.frame}]
#' @export
getContInputs = function(object) {
  if (isCCKriging(object)) {
    x = object$x
  } else if (is.data.frame(object)) {
    x = object
  } else {
    stop("Continuous inputs can only be extracted from a data.frame or CCKriging model.")
  }
  cont.inds = sapply(x, is.numeric)
  return(x[, cont.inds, drop = FALSE])
}

#' @title Check Suitability of Parameter Vector for a Given CCKriging Model
#'
#' @description Check if a parameter vector has the correct length and admissible values for a
#'   certain \code{\link[=makeCCKriging]{CCKriging}} model.
#'
#' @param cc [\code{\link[=makeCCKriging]{CCKriging}}]\cr
#'   The model for which the parameter vector should be checked.
#' @param par [\code{numeric}]\cr
#'   The parameter vector to be checked.
#'
#' @return If the check was succesful, the parameter vector is returned invisibly. Else, an
#'   exception is raised.
checkPar = function(cc, par) {
  checkmate::assertClass(cc, "CCKriging")
  q = ncol(getContInputs(cc))
  m = ncol(getCatInputs(cc))
  n.levels = sapply(getCatInputs(cc), nlevels)
  s = prod(n.levels)
  if (cc$config$cat.interaction) {
    par.length = switch(cc$config$cat.type,
      "EC" = q + 1L,
      "MC" = q + s,
      "UC" = q + (s^2 - s)/2,
      "TMC" = q + s  # FIXME: add GMC (and other methods)
    )
  } else {
    par.length = switch(cc$config$cat.type,
      "EC" = q + m,
      "MC" = q + sum(n.levels),
      "UC" = q + sum((n.levels^2 - n.levels)/2),
      "TMC" = q + sum(n.levels)
    )
  }

  checkmate::assertNumeric(par, any.missing = FALSE, len = par.length, null.ok = TRUE)
  return(invisible(par))
}

## get number of parameters needed for a specific config object and a categorical input variable
getNumberOfPars = function(v, config) {
  s = nlevels(v[[1]])
  cat.type = config$cat.type
  return(switch(cat.type,
    "EC" = 1L,
    "MC" = s,
    "UC" = (s^2 - s)/2,
    "TMC" = s,
    "GMC" = nlevels(as.factor(config$cat.par$perm))
  ))
}
dominikkirchhoff/CCKriging documentation built on May 19, 2019, 4:05 p.m.