Skip to content

Commit

Permalink
Standardizing internal error check syntax and transitioning some mess…
Browse files Browse the repository at this point in the history
…ages into true warnings
  • Loading branch information
njlyon0 committed Apr 28, 2024
1 parent 8c4abcd commit f8cb876
Show file tree
Hide file tree
Showing 17 changed files with 96 additions and 82 deletions.
2 changes: 1 addition & 1 deletion R/array_melt.R
Original file line number Diff line number Diff line change
Expand Up @@ -35,7 +35,7 @@ array_melt <- function(array = NULL){

# Error out if `array` is null or isn't an array
if(is.null(array) | methods::is(object = array, class2 = "array") != TRUE)
stop("`array` must be provided and must be an array")
stop("'array' must be provided and must be an array")

df <- array %>%
# Flatten array to a list (margin = 3 because each z should be in a separate list element)
Expand Down
15 changes: 8 additions & 7 deletions R/crop_tri.R
Original file line number Diff line number Diff line change
Expand Up @@ -20,20 +20,21 @@
crop_tri <- function(data = NULL, drop_tri = "upper", drop_diag = FALSE){

# Error out for missing data
if(is.null(data)) stop("`data` must be provided")
if(is.null(data) == TRUE)
stop("'data' must be provided")

# Error out if data aren't symmetric
if(nrow(data) != ncol(data))
stop("`data` must be have same number of rows as columns (i.e., must be symmetric")
stop("'data' must be have same number of rows as columns (i.e., must be symmetric)")

# Error out if triangle argument isn't supported
if(!drop_tri %in% c("upper", "lower"))
stop("`drop_tri` must be one of 'upper' or 'lower'")
if(drop_tri %in% c("upper", "lower") != TRUE)
stop("'drop_tri' must be one of 'upper' or 'lower'")

# Coerce `drop_diag` to logical if it isn't
if(methods::is(object = drop_diag, class2 = "logical") != TRUE){
drop_diag <- FALSE
message("`drop_diag` must be logical. Defaulting to FALSE") }
if(is.logical(drop_diag) != TRUE){
warning("'drop_diag' must be logical. Defaulting to FALSE")
drop_diag <- FALSE }

# Duplicate data
crop_data <- data
Expand Down
4 changes: 2 additions & 2 deletions R/date_check.R
Original file line number Diff line number Diff line change
Expand Up @@ -39,10 +39,10 @@ date_check <- function(data = NULL, col = NULL) {
col_opt <- col[j]

# Remove NA entries
notNA <- base::subset(df, !base::is.na(df[, col_opt]))
not_na <- base::subset(df, !base::is.na(df[, col_opt]))

# Identify rows that would be lost if `as.Date()` is used
bad_df <- base::subset(notNA, is.na(base::as.Date(notNA[, col_opt])))
bad_df <- base::subset(not_na, is.na(base::as.Date(not_na[, col_opt])))

# Get a vector of just the unique 'bad' entries
bad_vec <- base::unique(bad_df[, col_opt])
Expand Down
69 changes: 40 additions & 29 deletions R/date_format_guess.R
Original file line number Diff line number Diff line change
Expand Up @@ -42,54 +42,65 @@ date_format_guess <- function(data = NULL, date_col = NULL,
new_dates <- simp_dates <- simp_dates2 <- NULL
num_L <- num_R <- year <- format_guess <- NULL

# Error out if `data` isn't defined
if(is.null(data)) stop("`data` must be defined")

# Error out if `date_col` is undefined...
if(is.null(date_col)) stop("`date_col` must be defined")
# Error out if 'data' isn't defined
if(is.null(data))
stop("'data' must be defined")

# Error out if 'date_col' is undefined...
if(is.null(date_col))
stop("'date_col' must be defined")

# ...Or isn't a character...
if(is.character(date_col) != TRUE)
stop("`date_col` must be a character")
# ...Or isn't a column in `data`...
stop("'date_col' must be a character")

# ...Or isn't a column in 'data'...
if(!date_col %in% names(data))
stop("`date_col` must be a column name in `data`")
stop("'date_col' must be a column name in 'data'")

# ...Or the column isn't a character/factor column
if(date_col %in% names(data) & is.character(data[[date_col]]) != TRUE)
stop("`date_col` must refer to a character column in the `data` object")
stop("'date_col' must refer to a character column in the 'data' object")

# Warn when `groups` isn't a logical and re-set it to `FALSE`
if(methods::is(groups, "logical") != TRUE){
message("`groups` must be a logical. Re-setting to `FALSE`")
# Warn when 'groups' isn't a logical and re-set it to 'FALSE'
if(is.logical(groups) != TRUE){
warning("'groups' must be a logical. Re-setting to 'FALSE'")
groups <- FALSE }

# Error out if `groups = TRUE` but `group_col` is undefined...
# Error out if 'groups = TRUE' but 'group_col' is undefined...
if(groups == TRUE & is.null(group_col))
stop("`group_col` must be defined if `groups == TRUE`")
# Error out if `groups = TRUE` and `group_col` *is* defined BUT...
stop("'group_col' must be defined if 'groups == TRUE'")

# Error out if 'groups = TRUE' and 'group_col' *is* defined BUT...
if(groups == TRUE & !is.null(group_col)){
# ...Includes more than one column...
if(length(group_col) > 1)
stop("`group_col` only supports a single grouping column. Consider collapsing several columns to achieve this if necessary")
stop("'group_col' only supports a single grouping column. Consider collapsing several columns to achieve this if necessary")

# ...Isn't a character...
if(is.character(group_col) != TRUE)
stop("`group_col` must be a character")
stop("'group_col' must be a character")

#...Or isn't in the dataframe...
if(!group_col %in% names(data))
stop("`group_col` must be a column name in `data`")
stop("'group_col' must be a column name in 'data'")

# ...Or the column isn't a character/factor column
if(group_col %in% names(data) & is.character(data[[group_col]]) != TRUE)
stop("`group_col` must refer to a character column") }
stop("'group_col' must refer to a character column") }

# Warn when `quiet` isn't a logical and re-set it to `FALSE`
# Warn when 'quiet' isn't a logical and re-set it to 'FALSE'
if(is.logical(quiet) != TRUE){
message("`quiet` must be a logical. Defaulting to `FALSE`")
warning("'quiet' must be a logical. Defaulting to 'FALSE'")
quiet <- FALSE }

# Error out if `return is unspecified`...
if(is.null(return)) stop("`return` must be defined")
# Error out if 'return is unspecified'...
if(is.null(return) == TRUE)
stop("'return' must be defined")

# ...Or isn't either "dataframe" or "vector"
if(!return %in% c("dataframe", "vector"))
stop("`return` must be one of either 'dataframe' or 'vector'")
stop("'return' must be one of either 'dataframe' or 'vector'")

# Do some initial standardization & extraction
guess_v1 <- data %>%
Expand All @@ -110,7 +121,7 @@ date_format_guess <- function(data = NULL, date_col = NULL,
# Make both numbers truly numeric
dplyr::mutate(num_L = as.numeric(num_L), num_R = as.numeric(num_R))

# `groups == TRUE` ----
# 'groups == TRUE' ----
# Count frequencies and use that to help our inference
if(groups == TRUE) {

Expand Down Expand Up @@ -153,12 +164,12 @@ date_format_guess <- function(data = NULL, date_col = NULL,
"/" %in% gsub(pattern = "0|1|2|3|4|5|6|7|8|9", replacement = "",
x = year_partial) ~ paste0("year/", guess_partial) ) ) }

# `groups == FALSE` ----
# 'groups == FALSE' ----
if(groups == FALSE){

# Warn the user that lacking groups makes the function worse
if(quiet != TRUE){
message("Defining `groups` is strongly recommended! If none exist, consider adding a single artificial group shared by all rows then re-run this function") }
message("Defining 'groups' is strongly recommended! If none exist, consider adding a single artificial group shared by all rows then re-run this function") }

# We can't do the frequency counting thing so we'll just make empty columns
guess_v2 <- guess_v1 %>%
Expand Down Expand Up @@ -196,11 +207,11 @@ date_format_guess <- function(data = NULL, date_col = NULL,
# Make it a dataframe
as.data.frame()

# If `return = "dataframe"`, return that object
# If 'return = "dataframe"', return that object
if(return == "dataframe"){
if(quiet != TRUE){ message("Returning dataframe of data format guesses") }
return(guess_actual) }
# If `return = "vector"`, return *that* object
# If 'return = "vector"', return *that* object
if(return == "vector"){
if(quiet != TRUE){ message("Returning vector of data format guesses") }
return(guess_actual$format_guess) }
Expand Down
10 changes: 5 additions & 5 deletions R/diff_check.R
Original file line number Diff line number Diff line change
Expand Up @@ -31,17 +31,17 @@ diff_check <- function(old = NULL, new = NULL,
stop("Both arguments must be specified")

# Error out if either is not a vector
if(!is.vector(old) | !is.vector(new))
if(is.vector(old) != TRUE | is.vector(new) != TRUE)
stop("Both arguments must be vectors")

# Coerce `sort` to TRUE if not a logical
if(!is.logical(sort)){
message("`sort` must be either TRUE or FALSE. Coercing to TRUE")
if(is.logical(sort) != TRUE){
warning("'sort' must be either TRUE or FALSE. Defaulting to TRUE")
sort <- TRUE }

# Coerce `return` to FALSE if not a logical
if(!is.logical(return)){
message("`return` must be either TRUE or FALSE. Coercing to FALSE")
if(is.logical(return) != TRUE){
warning("'return' must be either TRUE or FALSE. Defaulting to FALSE")
return <- FALSE }

# Identify what is lost (i.e., in old but not new)
Expand Down
2 changes: 1 addition & 1 deletion R/force_num.R
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ force_num <- function(x = NULL){

# Error out for no argument specification
if(is.null(x))
stop("`x` argument must be defined")
stop("'x' argument must be defined")

# Coerce to numeric
y <- suppressWarnings(expr = as.numeric(x = x))
Expand Down
4 changes: 2 additions & 2 deletions R/github_ls.R
Original file line number Diff line number Diff line change
Expand Up @@ -17,14 +17,14 @@ github_ls_single <- function(repo = NULL, folder = NULL){

# Error out for missing repo URL
if(is.null(repo) == TRUE)
stop("`repo` must be the URL for a GitHub repository (including 'github.com')")
stop("'repo' must be the URL for a GitHub repository (including 'github.com')")

# Break URL into its component parts
url_bits <- stringr::str_split_1(string = repo, pattern = "/")

# Error out if "github.com" isn't in the URL
if(!"github.com" %in% url_bits)
stop("`repo` must be the URL for a GitHub repository (including 'github.com')")
stop("'repo' must be the URL for a GitHub repository (including 'github.com')")

# Drop unwanted parts of that
repo_id <- setdiff(x = url_bits, y = c("https:", "", "www.", "github.com"))
Expand Down
6 changes: 5 additions & 1 deletion R/name_vec.R
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,11 @@
#' # Create a named vector
#' name_vec(content = 1:10, name = paste0("text_", 1:10))
#'
name_vec <- function(content, name){
name_vec <- function(content = NULL, name = NULL){

# Error out either is not provided
if(is.null(content) == TRUE | is.null(name) == TRUE)
stop("Both arguments must be specified")

# Error out if content & name are not the same length
if(length(x = content) != length(x = name))
Expand Down
10 changes: 5 additions & 5 deletions R/nms_ord.R
Original file line number Diff line number Diff line change
Expand Up @@ -55,27 +55,27 @@ nms_ord <- function(mod = NULL, groupcol = NULL, title = NA,

# Error out if the model is the wrong class
if(base::unique(base::class(mod) %in% c("metaMDS", "monoMDS")) != TRUE)
stop("Model must be returned by `vegan::metaMDS`")
stop("Model must be returned by 'vegan::metaMDS'")

# Error out for inappropriate shapes / lines
if(!is.numeric(shapes) | base::max(shapes) > 25 | base::min(shapes < 0))
stop("`shapes` must be numeric value as defined in `?pch`")
stop("'shapes' must be numeric value as defined in '?pch'")

# Warn and coerce to default for inappropriate point size
if(!is.numeric(pt_size)) {
message("`pt_size` must be numeric. Coercing to 1.5")
warning("'pt_size' must be numeric. Coercing to 1.5")
pt_size <- 1.5 }

# Do the same for transparency
if(!is.numeric(pt_alpha)) {
message("`pt_alpha` must be numeric. Coercing to 1")
warning("'pt_alpha' must be numeric. Coercing to 1")
pt_alpha <- 1 }

# Warning message when attempting to plot too many groups
if (base::length(base::unique(groupcol)) > base::min(base::length(colors),
base::length(shapes),
base::length(lines))) {
message('Insufficient aesthetic values provided. 10 colors/shapes/lines are built into the function but you have supplied ', base::length(base::unique(groupcol)), ' groups. Please modify `colors`, `lines`, or `shapes` as needed to provide one value per category in your group column.')
warning("Insufficient aesthetic values provided. 10 colors/shapes/lines are built into the function but you have supplied ", base::length(base::unique(groupcol)), " groups. Please modify 'colors', 'lines', or 'shapes' as needed to provide one value per category in your group column.")
} else {

# Before actually creating the plot we need to make sure colors/shapes/lines are correctly formatted
Expand Down
8 changes: 3 additions & 5 deletions R/num_check.R
Original file line number Diff line number Diff line change
Expand Up @@ -37,13 +37,11 @@ num_check <- function(data = NULL, col = NULL) {
col_opt <- col[k]

# Remove NA entries
notNA <- base::subset(df, !base::is.na(df[, col_opt]))
not_na <- base::subset(df, !base::is.na(df[, col_opt]))

# Identify rows that would be lost if `as.numeric()` is used
bad_df <- base::subset(notNA,
base::is.na(
base::suppressWarnings(
base::as.numeric(notNA[, col_opt]))))
bad_df <- base::subset(not_na,
base::is.na(supportR::force_num(x = not_na[, col_opt])))

# Get a vector of just the unique 'bad' entries
bad_vec <- base::unique(bad_df[, col_opt])
Expand Down
10 changes: 5 additions & 5 deletions R/pcoa_ord.R
Original file line number Diff line number Diff line change
Expand Up @@ -55,27 +55,27 @@ pcoa_ord <- function(mod = NULL, groupcol = NULL, title = NA,

# Error out if the model is the wrong class
if(base::class(mod) != "pcoa")
stop("Model must be returned by `ape::pcoa`")
stop("Model must be returned by 'ape::pcoa'")

# Error out for inappropriate shapes / lines
if(!is.numeric(shapes) | base::max(shapes) > 25 | base::min(shapes < 0))
stop("`shapes` must be numeric value as defined in `?pch`")
stop("'shapes' must be numeric value as defined in '?pch'")

# Warn and coerce to default for inappropriate point size
if(!is.numeric(pt_size)) {
message("`pt_size` must be numeric. Coercing to 1.5")
warning("'pt_size' must be numeric. Coercing to 1.5")
pt_size <- 1.5 }

# Do the same for transparency
if(!is.numeric(pt_alpha)) {
message("`pt_alpha` must be numeric. Coercing to 1")
warning("'pt_alpha' must be numeric. Coercing to 1")
pt_alpha <- 1 }

# Warning message when attempting to plot too many groups
if (base::length(base::unique(groupcol)) > base::min(base::length(colors),
base::length(shapes),
base::length(lines))) {
message('Insufficient aesthetic values provided. 10 colors/shapes/lines are built into the function but you have supplied ', length(unique(groupcol)), ' groups. Please modify `colors`, `lines`, or `shapes` as needed to provide one value per category in your group column.')
warning("Insufficient aesthetic values provided. 10 colors/shapes/lines are built into the function but you have supplied ", length(unique(groupcol)), " groups. Please modify 'colors', 'lines', or 'shapes' as needed to provide one value per category in your group column.")
} else {

# Before actually creating the plot we need to make sure colors/shapes/lines are correctly formatted
Expand Down
11 changes: 6 additions & 5 deletions R/rmd_export.R
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@
#' @description This function allows you to knit a specified R Markdown file locally and export it to the Google Drive folder for which you provided a link. NOTE that if you have not used `googledrive::drive_auth` this will prompt you to authorize a Google account in a new browser tab. If you do not check the box in that screen before continuing you will not be able to use this function until you clear your browser cache and re-authenticate. I recommend invoking `drive_auth` beforehand to reduce the chances of this error
#'
#' @param rmd (character) name and path to R markdown file to knit
#' @param out_path (character) path to the knit file's destination (defaults to path returned by `getwd`)
#' @param out_path (character) path to the knit file's destination (defaults to path returned by `getwd()`)
#' @param out_name (character) desired name for knit file (with or without file suffix)
#' @param out_type (character) either "html" or "pdf" depending on what YAML entry you have in the `output: ` field of your R Markdown file
#' @param drive_link (character) full URL of drive folder to upload the knit document
Expand All @@ -28,11 +28,11 @@ rmd_export <- function(rmd = NULL, out_path = getwd(), out_name = NULL, out_type

# Error out for unspecified R markdown file to knit
if(base::is.null(rmd))
stop("Name of .Rmd file to knit must be provided to `rmd`")
stop("Name of .Rmd file to knit must be provided to 'rmd'")

# Error out for unspecified export name
if(base::is.null(out_name))
stop("Name to export knit file locally must be provided to `out_name`")
stop("Name to export knit file locally must be provided to 'out_name'")

# Error out if any argument is not a character
if(!base::is.character(rmd) |
Expand All @@ -42,10 +42,11 @@ rmd_export <- function(rmd = NULL, out_path = getwd(), out_name = NULL, out_type

# Error out for invalid export types
if(!out_type %in% c("html", "pdf"))
stop("Invalid `out_type` specification. Please supply either 'html' or 'pdf'")
stop("Invalid 'out_type' specification. Please supply either 'html' or 'pdf'")

# If the input name does not include .Rmd, add it
if(stringr::str_detect(rmd, pattern = ".Rmd") != "TRUE"){ rmd <- base::paste0(rmd, ".Rmd") }
if(stringr::str_detect(rmd, pattern = ".Rmd") != "TRUE"){
rmd <- base::paste0(rmd, ".Rmd") }

# Render provided input
rmarkdown::render(input = rmd, output_dir = out_path, output_file = out_name)
Expand Down
5 changes: 2 additions & 3 deletions R/safe_rename.R
Original file line number Diff line number Diff line change
Expand Up @@ -29,13 +29,12 @@ safe_rename <- function(data = NULL, bad_names = NULL, good_names = NULL){
stop("Must provide same number of replacement column names as names to be replaced")

# Error out if good names are not characters
if(is.character(bad_names) != TRUE |
is.character(good_names) != TRUE)
if(is.character(bad_names) != TRUE | is.character(good_names) != TRUE)
stop("Column names (bad and good) must be provided as characters")

# Error out if not all "bad_names" are found in the data
if(all(bad_names %in% names(data)) != TRUE)
stop("Not all `bad_names` found in data")
stop("Not all elements of 'bad_names' found in data")

# Duplicate data
renamed_data <- data
Expand Down
Loading

0 comments on commit f8cb876

Please sign in to comment.