R/CCKriging_Class.R

In dominikkirchhoff/CCKriging: Kriging for Mixed Continuous and Categorical Input Variables

#' @title Make Object of Class \code{CCKriging}
#'
#' @description A \code{CCKriging} object is a fitted Kriging model of a mixed continuous
#'   and categorical input.
#'
#' @param x [\code{data.frame}]\cr
#'   Mixed space input points.
#' @param y [\code{numeric}]\cr
#'   Continuous outputs.
#' @param config [\code{CCConfig}]\cr
#'   Configuration object. See \code{\link{makeCCConfig}}.
#' @param par [\code{numeric}]\cr
#'   Optimal parameter setting. Might be \code{NULL}, which means the model has not been fitted yet.
#' @param cat.lut [\code{data.frame}]\cr
#'   A lookup table, if at least two categorical variables are transformed into a single one.
#'   Only for internal use.
#'
#' @return [\code{CCKriging}]
#' @export
makeCCKriging = function(x, y, config, par = NULL, cat.lut = NULL) {
  checkmate::assertDataFrame(x)
  q = length(getContInputs(x))
  m = length(getCatInputs(x))
  if (ncol(x) > q + m) {
    stop("Each column of x must be a numeric vector or a factor.")
  }
  n.row = nrow(x)
  checkmate::assertNumeric(y, len = n.row, any.missing = FALSE)
  checkmate::assertClass(config, classes = "CCConfig")
  checkmate::assertDataFrame(cat.lut, any.missing = FALSE, null.ok = TRUE)

  ## generate S3 object
  cc = list(
    x = x,
    y = y,
    config = config,
    par = NULL,  # par is assigned below
    cat.lut = cat.lut
  )
  class(cc) = "CCKriging"

  cc$par = par  # par is checked via assignment

  return(cc)
}

#' @export
print.CCKriging = function(x, ...) {
  cat.inds = which(sapply(x$x, is.factor))
  cont.inds = setdiff(1:ncol(x$x), cat.inds)
  cat.mat = getCatCorrMatrix(x, config = x$config, design.corr = FALSE, ...)
  BBmisc::catf('\n--- CCKriging Model ---')
  cat.string = switch(x$config$cat.type,
    "EC"  = "EC  - Exchangeable Correlation",
    "MC"  = "MC  - Multiplicative Correlation",
    "UC"  = "UC  - Hypersphere-based Unrestrictive Correlation",
    "GK"  = "GK  - Gower Kriging",
    "CD"  = "CD  - Categorical Distances",
    "TMC" = "TMC - Toeplitz Matrix Multiplication-based Correlation",
    "GMC" = "GMC - General Matrix Multiplication-based Correlation")
  BBmisc::catf('  CATEGORICAL :: %s ', cat.string)
  BBmisc::catf('  CONTINUOUS  :: %s', x$config$cont.type)
  BBmisc::catf('\nCategorical Correlation Matrix:')
  print(cat.mat)
}

#' @export
plot.CCKriging = function(x, ...) {
  cat.inds = which(sapply(x$x, is.factor))
  cont.inds = setdiff(1:ncol(x$x), cat.inds)
  cat.mat = getCatCorrMatrix(x, design.corr = FALSE, ...)

  my.palette = colorRampPalette(c("#ef8a62", "#f7f7f7", "#67a9cf"))(n = 299)
  gplots::heatmap.2(cat.mat, col = my.palette, main = x$cat.type, density.info = "none",
    dendrogram = "none", trace = "none", Colv = NA, Rowv = NA, symbreaks = TRUE)
}

## FIXME: undone
`$<-.CCKriging` = function(cc, element, value) {
  checkmate::assertCharacter(element, len = 1L, any.missing = FALSE)
  if (element == "par") {
    cc[["par"]] = checkPar(cc, value)
  } else {  # ...
    cc[[element]] = value
  }
  return(cc)
}