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))
))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.