R/check_input_data.R

In rtemis: Schema-Driven Machine Learning and Visualization

# check_supervised.R
# ::rtemis::
# EDG rtemis.org

# Notes:
# Some algorithms do not work with variable names containing dots (SparkML)

# %% check_numeric_or_factor() ----
check_numeric_or_factor <- function(x) {
  # check all columns are either numeric or factor and report any that are not
  non_numeric_or_factor <- which(
    !vapply(x, function(col) is.numeric(col) || is.factor(col), logical(1L))
  )
  if (length(non_numeric_or_factor) > 0) {
    rtemis.core::abort(
      "Columns ",
      paste0(names(x)[non_numeric_or_factor], collapse = ", "),
      " are not numeric or factor.",
      class = c("rtemis_data_error", "rtemis_input_error")
    )
  }
}


# %% check_factor_levels.class_data.frame ----
method(check_factor_levels, class_data.frame) <- function(x, y, z) {
  if (!is.null(y) || !is.null(z)) {
    index_factor <- which(sapply(x, is.factor))
    x_levels <- lapply(x[, index_factor, drop = FALSE], levels)
    if (!is.null(y)) {
      y_levels <- lapply(y[, index_factor, drop = FALSE], levels)
      if (
        !all(sapply(seq_along(x_levels), function(i) {
          identical(x_levels[[i]], y_levels[[i]])
        }))
      ) {
        rtemis.core::abort(
          "Training and validation set factor levels do not match.",
          class = c("rtemis_level_mismatch", "rtemis_data_error")
        )
      }
    }
    if (!is.null(z)) {
      z_levels <- lapply(z[, index_factor, drop = FALSE], levels)
      if (
        !all(sapply(seq_along(x_levels), function(i) {
          identical(x_levels[[i]], z_levels[[i]])
        }))
      ) {
        rtemis.core::abort(
          "Training and test set factor levels do not match.",
          class = c("rtemis_level_mismatch", "rtemis_data_error")
        )
      }
    }
  }
  invisible()
} # /method(check_factor_levels, class_data.frame)

method(check_factor_levels, class_data.table) <- function(x, y, z) {
  if (!is.null(y) || !is.null(z)) {
    index_factor <- which(sapply(x, is.factor))
    x_levels <- lapply(x[, .SD, .SDcols = index_factor], levels)
    if (!is.null(y)) {
      y_levels <- lapply(y[, .SD, .SDcols = index_factor], levels)
      if (
        !all(sapply(seq_along(x_levels), function(i) {
          identical(x_levels[[i]], y_levels[[i]])
        }))
      ) {
        rtemis.core::abort(
          "Training and validation set factor levels do not match.",
          class = c("rtemis_level_mismatch", "rtemis_data_error")
        )
      }
    }
    if (!is.null(z)) {
      z_levels <- lapply(z[, .SD, .SDcols = index_factor], levels)
      if (
        !all(sapply(seq_along(x_levels), function(i) {
          identical(x_levels[[i]], z_levels[[i]])
        }))
      ) {
        rtemis.core::abort(
          "Training and test set factor levels do not match.",
          class = c("rtemis_level_mismatch", "rtemis_data_error")
        )
      }
    }
  }
  invisible()
} # /method(check_factor_levels, class_data.table)

#' Check data ahead of supervised learning
#'
#' @param x Data frame: Training set features and outcome in the last column.
#' @param dat_validation Data frame: Validation set features and outcome in the last column.
#' @param dat_test Data frame: Test set features and outcome in the last column.
#' @param allow_missing Logical: If TRUE, allow missing values in the data.
#' @param verbosity Integer: Verbosity level.
#'
#' @return NULL, invisibly. Stops execution if checks fail.
#'
#' @author EDG
#' @keywords internal
#' @noRd
#'
#' @examples
#' res <- resample(iris)
#' iris_train <- iris[res[[1]], ]
#' iris_test <- iris[-res[[1]], ]
#' check_supervised(iris_train, dat_test = iris_test)
check_supervised <- function(
  x,
  dat_validation = NULL,
  dat_test = NULL,
  allow_missing = TRUE,
  verbosity = 1L
) {
  # if (upsample && downsample) rtemis.core::abort("Only one of upsample and downsample can be TRUE")

  if (verbosity > 0L) {
    msgstart("Checking data is ready for training...")
  }

  # Check types ----
  check_inherits(x, "data.frame")
  if (!is.null(dat_validation)) {
    check_inherits(dat_validation, "data.frame")
  }
  if (!is.null(dat_test)) {
    check_inherits(dat_test, "data.frame")
  }

  # Check dimensions ----
  ncols <- NCOL(x)
  # Since one column must be outcome, need min of 2 columns
  if (ncols < 2) {
    rtemis.core::abort(
      "Data must contain at least 1 feature and 1 outcome column.",
      class = c("rtemis_dim_error", "rtemis_data_error")
    )
  }
  if (!is.null(dat_validation)) {
    if (NCOL(dat_validation) != ncols) {
      rtemis.core::abort(
        "Validation set must contain same number of columns as training set.",
        class = c("rtemis_dim_error", "rtemis_data_error")
      )
    }
  }
  if (!is.null(dat_test)) {
    if (NCOL(dat_test) != ncols) {
      rtemis.core::abort(
        "Test set must contain same number of columns as training set.",
        class = c("rtemis_dim_error", "rtemis_data_error")
      )
    }
  }

  # Check for non-numeric or factor features ----
  check_numeric_or_factor(features(x))

  # Missing values ----
  if (anyNA(outcome(x))) {
    rtemis.core::abort(
      "Training set outcome cannot contain any missing values.",
      class = c("rtemis_missing_data", "rtemis_data_error")
    )
  }
  if (!allow_missing && anyNA(x)) {
    rtemis.core::abort(
      "Data should not contain missing values.",
      class = c("rtemis_missing_data", "rtemis_data_error")
    )
  }

  # Outcome class ----
  outcome_class <- class(x[[ncols]])
  if (!inherits(x[[ncols]], c("integer", "numeric", "factor"))) {
    rtemis.core::abort(
      "Outcome must be integer, numeric, or factor; was ",
      outcome_class[[1L]],
      ".",
      class = c("rtemis_outcome_error", "rtemis_data_error")
    )
  }
  if (!is.null(dat_validation)) {
    if (!identical(class(dat_validation[[ncols]]), outcome_class)) {
      rtemis.core::abort(
        "Training and validation outcome must be of same class.",
        class = c("rtemis_outcome_error", "rtemis_data_error")
      )
    }
  }
  if (!is.null(dat_test)) {
    if (!identical(class(dat_test[[ncols]]), outcome_class)) {
      rtemis.core::abort(
        "Training and test outcome must be of same class.",
        class = c("rtemis_outcome_error", "rtemis_data_error")
      )
    }
  }

  # Factor levels ----
  # Check that factors across training, validation, and test contain the same levels.
  check_factor_levels(x = x, y = dat_validation, z = dat_test)

  if (verbosity > 0L) {
    msgdone()
  }
  invisible()
} # /rtemis::check_supervised


# %% check_case_weights ----
#' Check case weights before anything divides by their mean
#'
#' Weighted Grams, Cholesky factorizations and weighted means all assume the
#' same four things, and every one of them fails silently or unhelpfully when
#' they do not hold: a length matching the data, finite values, nothing
#' negative, and a mean above zero.
#'
#' Called once from [train] so every algorithm is covered, and again from the
#' `train_()` methods whose numerics depend on it, since `train_()` is a public
#' entry point of its own.
#'
#' @param weights Optional Numeric vector: Case weights.
#' @param n Integer: Number of training cases.
#'
#' @return `weights`, invisibly. Throws if any assumption is violated.
#'
#' @author EDG
#' @keywords internal
#' @noRd
check_case_weights <- function(weights, n) {
  if (is.null(weights)) {
    return(invisible(weights))
  }
  if (!is.numeric(weights)) {
    rtemis.core::abort(
      "Case weights must be numeric, not ",
      class(weights)[[1L]],
      ".",
      class = c("rtemis_type_error", "rtemis_input_error")
    )
  }
  if (length(weights) != n) {
    rtemis.core::abort(
      "Case weights must have one value per training case: expected length ",
      n,
      ", got ",
      length(weights),
      ".",
      class = c("rtemis_length_error", "rtemis_input_error")
    )
  }
  if (!all(is.finite(weights))) {
    rtemis.core::abort(
      "Case weights must all be finite; ",
      sum(!is.finite(weights)),
      " are not.",
      class = c("rtemis_value_error", "rtemis_input_error")
    )
  }
  if (any(weights < 0)) {
    rtemis.core::abort(
      "Case weights must be non-negative; ",
      sum(weights < 0),
      " are negative.",
      class = c("rtemis_value_error", "rtemis_input_error")
    )
  }
  if (mean(weights) <= 0) {
    rtemis.core::abort(
      "Case weights must have a positive mean; every weight is zero.",
      class = c("rtemis_value_error", "rtemis_input_error")
    )
  }
  invisible(weights)
} # /rtemis::check_case_weights


# %% check_unsupervised_data ----
#' Check data ahead of unsupervised learning
#'
#' @param x Data frame: Features for unsupervised learning.
#' @param allow_missing Logical: If TRUE, allow missing values in the data.
#'
#' @return NULL, invisibly. Stops execution if checks fail.
#'
#' @author EDG
#' @keywords internal
#' @noRd
#'
#' @examples
#' check_unsupervised_data(iris[, -5])
check_unsupervised_data <- function(x, allow_missing = FALSE, verbosity = 1L) {
  if (verbosity > 0L) {
    msgstart("Checking unsupervised data...")
  }
  if (NCOL(x) < 2) {
    rtemis.core::abort(
      "Data must contain at least 2 columns.",
      class = c("rtemis_dim_error", "rtemis_data_error")
    )
  }
  if (any(sapply(x, function(x) !is.numeric(x)))) {
    rtemis.core::abort(
      "All columns must be numeric.",
      class = "rtemis_data_error"
    )
  }
  if (!allow_missing && anyNA(x)) {
    rtemis.core::abort(
      "Data should not contain missing values.",
      class = c("rtemis_missing_data", "rtemis_data_error")
    )
  }
  if (verbosity > 0L) {
    msgdone()
  }
  invisible()
} # /rtemis::check_unsupervised_data