assert_inputs.R

#' Assert that an input is a vector/list with desired properties
#'
#' @param x A vector/list. The input to be analysed.
#' @param class A string. The class that this input should inherit from.
#' @param len An integer. The length of the vector. If `NULL`, length is not
#'   checked.
#' @param null_ok A logical. Whether the input could also be `NULL`.
#' @param var_name A string. The name of the variable in the informative
#'   message. If `NULL`, the name is guessed from the function call.
#' @param subset_of A character vector. If `x` is a character vector, specifies
#'   which values it can take. If `NULL`, values are not checked.
#' @param named A logical. Whether the input should be a named vector/list. If
#'   `FALSE` this check is not enforced (i.e. the input object can be named even
#'   if named is `FALSE`).
#' @param n_call A negative integer. The number of frames to go back to find the
#'   call to associate the error generated by the function with. Defaults to the
#'   parent frame (-1). This argument is only relevant to other assertion
#'   functions that build on top of this one.
#'
#' @return `TRUE` if the check is successful. Throws an error describing the
#'   issue with the input otherwise.
#'
#' @family input assertion
#'
#' @keywords internal
assert_vector <- function(x,
                          class,
                          len = NULL,
                          null_ok = FALSE,
                          var_name = NULL,
                          subset_of = NULL,
                          named = FALSE,
                          n_call = -1L) {

  # basic input checking

  if (!(is.character(class) && length(class) == 1)) {
    error_bad_class_argument()
  }

  if (!is.null(len) && !(is.integer(len) && length(len) == 1)) {
    error_bad_len_argument()
  }

  if (!(is.logical(null_ok) && length(null_ok) == 1)) {
    error_bad_null_ok_argument()
  }

  if (!is.null(var_name) && !(is.character(var_name) && length(var_name) == 1))
    error_bad_var_name_argument()

  if (!is.null(subset_of) && !is.character(subset_of)) {
    error_bad_subset_of_argument()
  }

  if (!(is.logical(named) && length(named) == 1)) {
    error_bad_named_argument()
  }

  if (!(is.integer(n_call) && length(n_call) == 1 && n_call < 0)) {
    error_bad_n_call_argument()
  }

  # construct input_name either from 'var_name' or from function call

  current_call <- sys.call(0)
  input_name <- as.character(current_call[[2]])

  if (!is.null(var_name)) input_name <- var_name

  # objects to create the gtfsio_error

  error_call <- sys.call(n_call)
  input_error_class <- paste0("bad_", input_name, "_argument")

  input_name <- paste0("'", input_name, "'")
  vector_name <- ifelse(
    class == "list",
    "a list.",
    paste0("a(n) ", class, " vector.")
  )

  # check against desired properties
  # the complicated logical condition below checks for the possibility of 'x'
  # being NULL if null_ok is TRUE.
  # also, it always consider NAs not ok, even when looking at logical vectors

  if ((!inherits(x, class) && null_ok && !is.null(x))
    || (!inherits(x, class) && !null_ok)
    || (is.logical(x) && any(is.na(x)))) {
    error_x_wrong_class(input_name, vector_name, input_error_class, error_call)
  }

  if (!is.null(len) && len != length(x)) {
    error_x_wrong_length(input_name, len, input_error_class, error_call)
  }

  if (!is.null(subset_of) && (is.character(x) && any(! x %in% subset_of))) {
    error_x_wrong_value(input_name, subset_of, input_error_class, error_call)
  }

  vector_name2 <- ifelse(class == "list", "list.", paste0(class, " vector."))
  if (named && is.null(names(x)) && !is.null(x)) {
    error_x_not_named(input_name, vector_name2, input_error_class, error_call)
  }

  non_empty_names <- names(x)[! names(x) %chin% ""]
  if (named && (!is.null(names(x)) && length(non_empty_names) != length(x))) {
    error_x_not_fully_named(input_name, input_error_class, error_call)
  }

  invisible(TRUE)

}



#' @rdname assert_vector
#' @family input assertion
#' @keywords internal
assert_list <- function(x, len = NULL, null_ok = FALSE, named = FALSE) {

  # input checks are all conducted inside assert_vector()

  call <- sys.call(0)
  var_name <- as.character(call[[2]])

  assert_vector(
    x,
    "list",
    len = len,
    null_ok = null_ok,
    var_name = var_name,
    named = named,
    n_call = -2L
  )

}



#' @rdname assert_vector
#' @family input assertion
#' @keywords internal
assert_class <- function(x, class, n_call = -1) {

  assert_vector(class, "character")

  # construct input_name from function call

  current_call <- sys.call(0)
  input_name <- as.character(current_call[[2]])

  # objects to create the gtfsio_error

  error_call <- sys.call(n_call)
  input_error_class <- paste0("bad_", input_name, "_argument")
  input_name <- paste0("'", input_name, "'")

  # check against desired properties

  if (!(all(inherits(x, class, which = TRUE)))) {
    error_x_wrong_inheritance(input_name, class, input_error_class, error_call)
  }

  invisible(TRUE)

}


# errors ------------------------------------------------------------------


#' @include gtfsio_error.R
error_bad_class_argument <- parent_function_error(
  "'class' must be a string.",
  subclass = "bad_class_argument"
)

error_bad_len_argument <- parent_function_error(
  "'length' must be an integer vector with length 1.",
  subclass = "bad_len_argument"
)

error_bad_null_ok_argument <- parent_function_error(
  "'null_ok' must be a logical vector with length 1.",
  subclass = "bad_null_ok_argument"
)

error_bad_var_name_argument <- parent_function_error(
  "'var_name' must be a string.",
  subclass = "bad_var_name_argument"
)

error_bad_subset_of_argument <- parent_function_error(
  "'subset_of' must be a character vector.",
  subclass = "bad_subset_of_argument"
)

error_bad_named_argument <- parent_function_error(
  "'named' must be a logical vector with length 1.",
  subclass = "bad_named_argument"
)

error_bad_n_call_argument <- parent_function_error(
  "'n_call' must be a negative integer.",
  subclass = "bad_n_call_argument"
)

error_x_wrong_class <- function(input_name,
                                vector_name,
                                input_error_class,
                                error_call) {
  gtfsio_error(
    paste0(input_name, " must be ", vector_name),
    input_error_class,
    error_call
  )
}

error_x_wrong_length <- function(input_name,
                                 len,
                                 input_error_class,
                                 error_call) {
  gtfsio_error(
    paste0(input_name, " must have length ", len, "."),
    input_error_class,
    error_call
  )
}

error_x_wrong_value <- function(input_name,
                                subset_of,
                                input_error_class,
                                error_call) {
  gtfsio_error(
    paste0(
      input_name,
      " must be a subset of [",
      paste(paste0("'", subset_of, "'"), collapse = ", "),
      "]."
    ),
    input_error_class,
    error_call
  )
}

error_x_not_named <- function(input_name,
                              vector_name2,
                              input_error_class,
                              error_call) {
  gtfsio_error(
    paste0(input_name, " must be a named ", vector_name2),
    input_error_class,
    error_call
  )
}

error_x_not_fully_named <- function(input_name, input_error_class, error_call) {
  gtfsio_error(
    paste0("Every element in ", input_name, " must be named."),
    input_error_class,
    error_call
  )
}

error_x_wrong_inheritance <- function(input_name,
                                      class,
                                      input_error_class,
                                      error_call) {
  gtfsio_error(
    paste0(
      input_name, " must inherit from the ",
      paste0("'", class, "'", collapse = ", "),
      " class."
    ),
    input_error_class,
    error_call
  )
}