R/assertions.R

In atorus-research/Tplyr: A Traceability Focused Grammar of Clinical Data Summary

#' Custom assertions
#'
#' @description
#' These assertions abstract away common checks required throughout package development. Furthermore, the provide detailed and
#' explicit messages to the user that direct them to the source of the error without having to search through the trace back
#' to find culprit function call.
#'
#' @param x Object to be inspected
#' @param should_be The expected class of the object
#'
#' @details
#' When generating the error, these assertions capture the input arguments name, and capture the the calling functions name
#' from the call stack. This information is then reported within the error message generated by \code{rlang::abort} and the trace back
#' is triggered so the user has the necessary information to review
#'
#' @family Custom Assertions
#' @rdname custom_assertions
#'
#' @examples
#' \dontrun{
#' fun1 <- function(my_param) {
#'   assert_has_class(my_param, 'character')
#' }
#'
#' fun1(1)
#' #>  Error: Argument `my_param` in function `fun1` must be character. Instead a class of
#' #>  "numeric" was passed.
#'
#' fun2 <- function(my_param) {
#'   assert_inherits_class(my_param, 'numeric')
#' }
#'
#' fun2(tibble::tibble(a=c(1,2,3)))
#' #>  Error: Argument `my_param` in function `fun2` does not inherit numeric.
#' #>  Classes: tbl_df, tbl, data.frame
#' }
#' @noRd
assert_has_class <- function(x, should_be) {
  # Get the name of the parameter being checked
  param <- enexpr(x)

  # Is the argument the class that it should be?
  if (class(x) != should_be){
    abort(paste0('Argument `', param, '` must be ',
                 should_be, '. Instead a class of "', class(x),
                 '" was passed.'))
  }
}

#' Assert that an argument inherits certain class
#'
#' @param x Object to be inspected
#' @param should_have Expected class that object should inherit
#'
#' @noRd
assert_inherits_class <- function(x, should_have) {
  # Get the name of the parameter being checked
  param <- enexpr(x)

  # Is the argument the class that it should be?
  if (!inherits(x, should_have)){
    # Abort and show error
    abort(paste0('Argument `', param,
                 '` does not inherit "', should_have,
                 '". Classes: ', paste(class(x), collapse=", ")))
  }
}

#' Assert that variables not passed as strings are present in target dataset
#'
#' @param quo_list A variable that can be a string, variable, or combination of
#'   those using dplyr::vars
#' @param vnames Variable names of the target dataset to check against
#' @param envir Environment containing the dataset \code{target} from which names will be checked against
#' @param allow_character Whether or not character strings are allows in an entry
#'
#' @return Returns nothing, raises errors when assertions aren't met
#' @noRd
assert_quo_var_present <- function(quo_list, vnames=NULL, envir=NULL, allow_character=TRUE) {

  # Get the parameter name that was entered
  param <- enexpr(quo_list)

  if (allow_character) {
    allow <- c('name', 'character')
    allow_str <- "`. Submit either a string, a variable name, or multiple variable names using `dplyr::vars`."
  } else {
    allow <- "name"
    allow_str <- "`. Submit either a variable name or multiple variable names using `dplyr::vars`."
  }

  # Global definition warning
  target <- NULL
  # If the vnames weren't supplied then grab
  if (is.null(vnames)) {
    assert_that(!is.null(envir), msg='In `assert_quo_var_present` if `vnames` is not provided then envir must be specified')
    vnames <- evalq(names(target), envir=envir)
  }

  # Make sure that quo_list variables not submitted as characters exist in the target dataframe
  if (length(quo_list) > 0 && !quo_is_null(quo_list[[1]])) {
    # Make sure the variables provided to `quo_list` are of the correct type
    msg = paste0("Invalid input to `", param, allow_str)
    are_quosures <- all(map_lgl(quo_list, is_quosure))
    assert_that(are_quosures, msg = msg)

    # Check each element of the `quo_list` list
    for (v in quo_list) {

      if (inherits(quo_get_expr(v), "name")) {
        vname <- as_name(quo_get_expr(v))
        assert_that(vname %in% vnames,
                    msg = paste0("`", param, "` variable `",vname, "` does not exist in target dataset"))
      }

      # While looping, making sure calls weren't submitted
      if (!class(quo_get_expr(v)) %in% allow) {
        abort(msg)
      }
    }
  }
}

#' Assert that an argument is passed using vars as appropriate
#'
#' @param quo_list A variable that can be a string, variable, or combination of
#'   those using dplyr::vars
#' @param allow_character Whether or not character strings are allows in an entry
#'
#' @return Unpacked quosure.
#' @noRd
unpack_vars <- function(quo_list, allow_character=TRUE) {

  # Return quo_list if it's empty
  if (is_empty(quo_list)) return(quo_list)

  # Get the parameter name that was entered
  param <- enexpr(quo_list)

  if (allow_character) {
    allow_str <- "`. Submit either a string, a variable name, or multiple variable names using `dplyr::vars`."
  } else {
    allow_str <- "`. Submit either a variable name or multiple variable names using `dplyr::vars`."
  }

  # Unpack the `quo_list` group to ensure that the type is `list_of<quosures>`
  # It had to be a 1 item list, so check if that element is a `call`
  # The only valid use of a `call` is to provide multiple variables using `vars`
  c <- quo_get_expr(quo_list[[1]])
  if (is.call(c)) {
    # If it's a call, we need to pull it out a level
    quo_list <- tryCatch({
      # If it's in here, the call has to be to dplyr::vars
      if (call_name(c) != "vars") abort("Multiple variables should be using dplyr::vars")

      # Evaluate the quosure sort_vars getting the expression
      eval(c, envir=caller_env())
    },
    # If a 1 item list of variable was provided, it'll fail
    error = function(err) {
      abort(message = paste0("Invalid input to `", param, allow_str))
    })
  } else {
    if (is.null(c)) return(vars())
  }
  quo_list
}

#' Check if a quosure is null or contains a logical value
#'
#' @param quo_var A quosure object to check
#'
#' @noRd
is_logical_or_call <- function(quo_var) {
  is_logical(quo_get_expr(quo_var)) || is_call(quo_get_expr(quo_var))
}

#' @param object Object to check if its a layer
#'
#' @noRd
assert_is_layer <- function(object) {
 assert_inherits_class(object, "tplyr_layer")
}

#' Return the class of the expression inside a quosure
#'
#' @param q A quosure
#'
#' @return The class of quosure \code{q}
#'
#' @examples
#' library(rlang)
#'
#' q <- quo(a)
#' quo_class(q)
#'
#' q <- quo("Hello!")
#' quo_class(q)
#'
#' q <- quo(x + y)
#' quo_class(q)
#' @noRd
quo_class <- function(q) {
  assert_that(is_quosure(q), msg = "Object `q` is not a quosure")
  class(quo_get_expr(q))
}