adds asserts and updates class/inherit checks

ycphs · May 28, 2021 · 86070be · 86070be
1 parent 782372d
commit 86070be
Show file tree

Hide file tree

Showing 6 changed files with 119 additions and 69 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -211,30 +211,26 @@ 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")
   borderStyle <- validateBorderStyle(borderStyle)[[1]]
 
   ## 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
@@ -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