From 86070beda7d12defa1c0fba622c2f58312d1256c Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Fri, 28 May 2021 09:01:32 -0400 Subject: [PATCH] adds asserts and updates class/inherit checks --- DESCRIPTION | 1 + R/asserts.R | 80 ++++++++++++++++++++++++++++++++++++++++++++++ R/readWorkbook.R | 39 ++++++---------------- R/utils.R | 8 ++--- R/writeData.R | 22 ++++++------- R/writeDataTable.R | 38 ++++++++++------------ 6 files changed, 119 insertions(+), 69 deletions(-) create mode 100644 R/asserts.R diff --git a/DESCRIPTION b/DESCRIPTION index 6c0a672c..99182b53 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,6 +56,7 @@ Collate: 'class_definitions.R' 'StyleClass.R' 'WorkbookClass.R' + 'asserts.R' 'baseXML.R' 'borderFunctions.R' 'build_workbook.R' diff --git a/R/asserts.R b/R/asserts.R new file mode 100644 index 00000000..d5c88cc1 --- /dev/null +++ b/R/asserts.R @@ -0,0 +1,80 @@ +# Assertions for parameter validates +# These should be used at the beginning of functions to stop execution early + +assert_class <- function(x, class, or_null = FALSE) { + sx <- as.character(substitute(x)) + ok <- inherits(x, class) + + if (or_null) { + ok <- ok | is.null(x) + class <- c(class, "null") + } + + if (!ok) { + msg <- sprintf("%s must be of class %s", sx, paste(class, collapse = " or ")) + stop(msg, call. = FALSE) + } +} + +assert_length <- function(x, n) { + stopifnot(is.integer(n)) + if (length(x) != n) { + msg <- sprintf("%s must be of length %iL", substitute(x), n) + stop(msg, call. = FALSE) + } +} + +assert_true_false1 <- function(x) { + if (!is_true_false(x)) { + stop(substitute(x), " must be TRUE or FALSE", call. = FALSE) + } +} + +assert_true_false <- function(x) { + ok <- is.logical(x) & !is.na(x) + if (!ok) { + stop(substitute(x), " must be a logical vector with NAs", call. = FALSE) + } +} + +assert_character1 <- function(x, scalar = FALSE) { + ok <- is.character(x) && length(x) == 1L + + if (scalar) { + ok <- ok & nchar(x) == 1L + } + + if (!ok) { + stop(substitute(x), " must be a character vector of length 1L", call. = FALSE) + } +} + +assert_unique <- function(x, case_sensitive = TRUE) { + msg <- paste0(substitute(x), " must be a unique vector") + + if (!case_sensitive) { + x <- tolower(x) + msg <- paste0(msg, " (case sensitive)") + } + + if (anyDuplicated(x) != 0L) { + stop(msg, call. = FALSE) + } +} + +# validates --------------------------------------------------------------- + +validate_StyleName <- function(x) { + m <- valid_StyleNames[match(tolower(x), valid_StyleNames_low)] + if (anyNA(m)) { + stop( + "Invalid table style: ", + paste0(sprintf("'%s'", x[is.na(m)]), collapse = ", "), + call. = FALSE + ) + } + m +} + +valid_StyleNames <- c("none", paste0("TableStyleLight", 1:21), paste0("TableStyleMedium", 1:28), paste0("TableStyleDark", 1:11)) +valid_StyleNames_low <- tolower(valid_StyleNames) diff --git a/R/readWorkbook.R b/R/readWorkbook.R index 74301647..2bb9c394 100644 --- a/R/readWorkbook.R +++ b/R/readWorkbook.R @@ -116,37 +116,18 @@ read.xlsx.default <- function(xlsxFile, sheetselected <- FALSE } - if (grepl("\\.xls$|\\.xlm$", xlsxFile)) { - stop("openxlsx can not read .xls or .xlm files!") + if (!grepl("\\.xlsx$", xlsxFile)) { + stop("openxlsx can only read .xlsx files", call. = FALSE) } - if (!is.logical(colNames)) { - stop("colNames must be TRUE/FALSE.") - } - - if (!is.logical(rowNames)) { - stop("rowNames must be TRUE/FALSE.") - } - - if (!is.logical(detectDates)) { - stop("detectDates must be TRUE/FALSE.") - } - - if (!is.logical(skipEmptyRows)) { - stop("skipEmptyRows must be TRUE/FALSE.") - } - - if (!is.logical(check.names)) { - stop("check.names must be TRUE/FALSE.") - } - - if (!is.character(sep.names) | nchar(sep.names) != 1) { - stop("sep.names must be a character and only one.") - } - - if (length(sheet) > 1) { - stop("sheet must be of length 1.") - } + assert_true_false1(colNames) + assert_true_false1(rowNames) + assert_true_false1(detectDates) + assert_true_false1(skipEmptyRows) + assert_true_false1(check.names) + assert_character1(sep.names, scalar = TRUE) + assert_length(sheet, 1L) + assert_length(startRow, 1L) if (is.null(rows)) { rows <- NA diff --git a/R/utils.R b/R/utils.R index 896715ea..aeba9e94 100644 --- a/R/utils.R +++ b/R/utils.R @@ -15,15 +15,11 @@ `%||%` <- function(x, y) if (is.null(x)) y else x is_not_class <- function(x, class) { - if (is.null(x)) { - FALSE - } else { - !inherits(x, class) - } + !(inherits(x, class) | is.null(x)) } is_true_false <- function(x) { - is.logical(x) && length(x) == 1L && is.na(x) + is.logical(x) && length(x) == 1L && !is.na(x) } do_call_params <- function(fun, params, ..., .map = FALSE) { diff --git a/R/writeData.R b/R/writeData.R index bed0b95a..1e061eb3 100644 --- a/R/writeData.R +++ b/R/writeData.R @@ -211,16 +211,12 @@ writeData <- function( } startRow <- as.integer(startRow) - - if (!"Workbook" %in% class(wb)) stop("First argument must be a Workbook.") - - if (!is.logical(colNames)) stop("colNames must be a logical.") - if (!is.logical(rowNames)) stop("rowNames must be a logical.") - - if (is_not_class(headerStyle, "Style")) { - stop("headerStyle must be a style object or NULL.") - } - if (!is.character(sep) || length(sep) != 1) stop("sep must be a character vector of length 1") + + assert_class(wb, "Workbook") + assert_true_false(colNames) + assert_true_false(rowNames) + assert_character1(sep) + assert_class(headerStyle, "Style", or_null = TRUE) ## borderColours validation borderColour <- validateColour(borderColour, "Invalid border colour") @@ -228,13 +224,13 @@ writeData <- function( ## special case - vector of hyperlinks hlinkNames <- NULL - if ("hyperlink" %in% class(x)) { + if (inherits(x, "hyperlink")) { hlinkNames <- names(x) colNames <- FALSE } ## special case - formula - if ("formula" %in% class(x)) { + if (inherits(x, "formula")) { x <- data.frame("X" = x, stringsAsFactors = FALSE) class(x[[1]]) <- ifelse(array, "array_formula", "formula") colNames <- FALSE @@ -335,7 +331,7 @@ writeData <- function( ) ## header style - if ("Style" %in% class(headerStyle) & colNames) { + if (inherits(headerStyle, "Style") & colNames) { addStyle( wb = wb, sheet = sheet, style = headerStyle, rows = startRow, diff --git a/R/writeDataTable.R b/R/writeDataTable.R index b125384f..dfeaab85 100644 --- a/R/writeDataTable.R +++ b/R/writeDataTable.R @@ -158,7 +158,6 @@ writeDataTable <- function( bandedCols = openxlsx_getOp("bandedCols", FALSE), row.names ) { - op <- get_set_options() on.exit(options(op), add = TRUE) @@ -176,6 +175,7 @@ writeDataTable <- function( lastColumn <- lastColumn %||% FALSE bandedRows <- bandedRows %||% TRUE bandedCols <- bandedCols %||% FALSE + withFilter <- withFilter %||% TRUE if (!is.null(xy)) { if (length(xy) != 2) { @@ -185,11 +185,19 @@ writeDataTable <- function( startRow <- xy[[2]] } - # recode NULLs to match default - # If not set, change to default - withFilter <- withFilter %||% TRUE + # Assert parameters + assert_class(wb, "Workbook") + assert_class(x, "data.frame") + assert_true_false(colNames) + assert_true_false(rowNames) + assert_class(headerStyle, "Style", or_null = TRUE) + assert_true_false(withFilter) + assert_character1(sep) + assert_true_false(firstColumn) + assert_true_false(lastColumn) + assert_true_false(bandedRows) + assert_true_false(bandedCols) - ## Input validating if (!"Workbook" %in% class(wb)) stop("First argument must be a Workbook.") if (!"data.frame" %in% class(x)) stop("x must be a data.frame.") if (!is.logical(colNames)) stop("colNames must be a logical.") @@ -223,21 +231,11 @@ writeDataTable <- function( } ## If 0 rows append a blank row - - validNames <- c("none", paste0("TableStyleLight", 1:21), paste0("TableStyleMedium", 1:28), paste0("TableStyleDark", 1:11)) - if (!tolower(tableStyle) %in% tolower(validNames)) { - stop("Invalid table style.") - } else { - tableStyle <- validNames[grepl(paste0("^", tableStyle, "$"), validNames, ignore.case = TRUE)] - } - - tableStyle <- na.omit(tableStyle) - if (length(tableStyle) == 0) { - stop("Unknown table style.") - } + + tableStyle <- validate_StyleName(tableStyle) ## header style - if ("Style" %in% class(headerStyle)) { + if (inherits(headerStyle, "Style")) { addStyle( wb = wb, sheet = sheet, style = headerStyle, rows = startRow, @@ -250,9 +248,7 @@ writeDataTable <- function( if (colNames) { colNames <- colnames(x) - if (any(duplicated(tolower(colNames)))) { - stop("Column names of x must be case-insensitive unique.") - } + assert_unique(colNames, case_sensitive = FALSE) ## zero char names are invalid char0 <- nchar(colNames) == 0