Writexlsx params

DESCRIPTION

@@ -56,8 +56,10 @@ Collate:
     'class_definitions.R'
     'StyleClass.R'
     'WorkbookClass.R'
+    'asserts.R'
     'baseXML.R'
     'borderFunctions.R'
+    'build_workbook.R'
     'chartsheet_class.R'
     'conditional_formatting.R'
     'data-fontSizeLookupTables.R'

NAMESPACE

@@ -15,6 +15,7 @@ export(addCreator)
 export(addFilter)
 export(addStyle)
 export(addWorksheet)
+export(buildWorkbook)
 export(cloneWorksheet)
 export(conditionalFormat)
 export(conditionalFormatting)

NEWS.md

@@ -8,12 +8,22 @@
 
 ## New features
 
-* `write.xlsx()` can now handle `colWidths` passed as either a single element or a `list()`
+* adds `buildWorkbook()` to generate a `Workbook` object from a (named) list or a data.frame ([#192](https://github.com/ycphs/openxlsx/issues/192), [#187](https://github.com/ycphs/openxlsx/issues/187))
+  * this is now recommended rather than the `write.xlsx(x, file) ; wb <- read.xlsx(file)` functionality before
+  * `write.xlsx()` is now a wrapper for `wb <- buildWorkbook(x); saveWorkbook(x, file)`
+  * parameter checking from `write.xlsx()` >> `buildWorkbook()` are now held off until passed to `writeData()`, `writeDataTable()`, etc
+  * `row.names` is now deprecated for `writeData()` and `writeDataTable()`; please use `rowNames` instead
+* `read.xlsx()` now checks for the file extension `.xlsx`; previously it would throw an error when the file was `.xls` or `.xlm` files
+* memory allocation improvements
+* global options added for `minWidth` and `maxWidth`
+* `write.xlsx()` >> `buildWorkbook()` can now handle `colWidths` passed as either a single element or a `list()`
 * Added ability to change positioning of summary columns and rows.
   * These can be set with the `summaryCol` and `summaryRow` arguments in `pageSetup()`.
-* activeSheet allows to set and get the active (displayed) sheet of a worbook.
+* activeSheet allows to set and get the active (displayed) sheet of a workbook.
 * Adds new global options for workbook formatting ([#165](https://github.com/ycphs/openxlsx/issues/165); see `?op.openxlsx`)
 
+
+
 # openxlsx 4.2.3
 
 ## New Features

R/WorkbookClass.R

@@ -1111,8 +1111,6 @@ Workbook$methods(
   }
 )
 
-
-
 Workbook$methods(
   validateSheet = function(sheetName) {
     if (!is.numeric(sheetName)) {
@@ -1123,23 +1121,22 @@ Workbook$methods(
 
     if (is.numeric(sheetName)) {
       if (sheetName > length(sheet_names)) {
-        stop(sprintf("This Workbook only has %s sheets.", length(sheet_names)),
-          call. =
-            FALSE
+        stop("This Workbook only has ", length(sheet_names),
+          " sheets, ", sheetName, " is not valid",
+          call. = FALSE
         )
       }
-
       return(sheetName)
     } else if (!sheetName %in% replaceXMLEntities(sheet_names)) {
-      stop(sprintf("Sheet '%s' does not exist.", replaceXMLEntities(sheetName)), call. = FALSE)
+      stop(sprintf("Sheet '%s' does not exist.", replaceXMLEntities(sheetName)),
+        call. = FALSE)
     }
 
-    return(which(replaceXMLEntities(sheet_names) == sheetName))
+    which(replaceXMLEntities(sheet_names) == sheetName)
   }
 )
 
 
-
 Workbook$methods(
   getSheetName = function(sheetIndex) {
     if (any(length(sheet_names) < sheetIndex)) {
@@ -1150,8 +1147,6 @@ Workbook$methods(
   }
 )
 
-
-
 Workbook$methods(
   buildTable = function(sheet,
                         colNames,
@@ -2107,7 +2102,7 @@ Workbook$methods(
 
           ## Check if any tables were deleted - remove these from rels
           if (length(tables) > 0) {
-            table_inds <- which(grepl("tables/table[0-9].xml", ws_rels))
+            table_inds <- grep("tables/table[0-9].xml", ws_rels)
 
             if (length(table_inds) > 0) {
               ids <-
@@ -2309,8 +2304,7 @@ Workbook$methods(
     }
 
     ## Need to remove reference from workbook.xml.rels to pivotCache
-    removeRels <-
-      worksheets_rels[[sheet]][grepl("pivotTables", worksheets_rels[[sheet]])]
+    removeRels <- grep("pivotTables", worksheets_rels[[sheet]], value = TRUE)
     if (length(removeRels) > 0) {
       ## sheet rels links to a pivotTable file, the corresponding pivotTable_rels file links to the cacheDefn which is listing in workbook.xml.rels
       ## remove reference to this file from the workbook.xml.rels
@@ -2326,7 +2320,7 @@ Workbook$methods(
           collapse = "|"
         )
 
-      fileNo <- which(grepl(toRemove, pivotTables.xml.rels))
+      fileNo <- grep(toRemove, pivotTables.xml.rels)
       toRemove <-
         stri_join(
           sprintf("(pivotCacheDefinition%s\\.xml)", fileNo),
@@ -3151,33 +3145,20 @@ Workbook$methods(
     }
 
     ## get index of each child element for ordering
-    sheetInds <-
-      which(grepl(
-        "(worksheets|chartsheets)/sheet[0-9]+\\.xml",
-        workbook.xml.rels
-      ))
-    stylesInd <- which(grepl("styles\\.xml", workbook.xml.rels))
-    themeInd <-
-      which(grepl("theme/theme[0-9]+.xml", workbook.xml.rels))
-    connectionsInd <-
-      which(grepl("connections.xml", workbook.xml.rels))
-    extRefInds <-
-      which(grepl("externalLinks/externalLink[0-9]+.xml", workbook.xml.rels))
-    sharedStringsInd <-
-      which(grepl("sharedStrings.xml", workbook.xml.rels))
-    tableInds <- which(grepl("table[0-9]+.xml", workbook.xml.rels))
-    personInds <- which(grepl("person.xml", workbook.xml.rels))
+    sheetInds <- grep("(worksheets|chartsheets)/sheet[0-9]+\\.xml", workbook.xml.rels)
+    stylesInd <- grep("styles\\.xml", workbook.xml.rels)
+    themeInd <- grep("theme/theme[0-9]+.xml", workbook.xml.rels)
+    connectionsInd <- grep("connections.xml", workbook.xml.rels)
+    extRefInds <- grep("externalLinks/externalLink[0-9]+.xml", workbook.xml.rels)
+    sharedStringsInd <- grep("sharedStrings.xml", workbook.xml.rels)
+    tableInds <- grep("table[0-9]+.xml", workbook.xml.rels)
+    personInds <- grep("person.xml", workbook.xml.rels)
 
 
     ## Reordering of workbook.xml.rels
     ## don't want to re-assign rIds for pivot tables or slicer caches
-    pivotNode <-
-      workbook.xml.rels[grepl(
-        "pivotCache/pivotCacheDefinition[0-9].xml",
-        workbook.xml.rels
-      )]
-    slicerNode <-
-      workbook.xml.rels[which(grepl("slicerCache[0-9]+.xml", workbook.xml.rels))]
+    pivotNode <- grep("pivotCache/pivotCacheDefinition[0-9].xml", workbook.xml.rels, value = TRUE)
+    slicerNode <- grep("slicerCache[0-9]+.xml", workbook.xml.rels, value = TRUE)
 
     ## Reorder children of workbook.xml.rels
     workbook.xml.rels <<-

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)

R/build_workbook.R

@@ -0,0 +1,101 @@
+#' Build Workbook
+#' 
+#' Build a workbook from a data.frame or named list
+#' 
+#' @details 
+#' This function can be used as shortcut to create a workbook object from a 
+#'   data.frame or named list.  If names are available in the list they will be
+#'   used as the worksheet names.  The parameters in \code{...} are collected
+#'   and passed to \code{\link{writeData}} or \code{\link{writeDataTable}} to
+#'   initially create the Workbook objects then appropriate parameters are 
+#'   passed to \code{\link{setColWidths}}.
+#' 
+#' @param x A data.frame or a (named) list of objects that can be handled by
+#'   \code{\link{writeData}} or \code{\link{writeDataTable}} to write to file
+#' @param asTable If \code{TRUE} will use \code{\link{writeDataTable}} rather
+#'   than \code{\link{writeData}} to write \code{x} to the file (default: 
+#'   \code{FALSE})
+#' @param ... Additional arguments passed to \code{\link{writeData}}, 
+#'   \code{\link{writeDataTable}}, \code{\link{setColWidths}}
+#' @author Jordan Mark Barbone
+#' @returns A Workbook object
+#' 
+#' @examples
+#' x <- data.frame(a = 1, b = 2)
+#' wb <- buildWorkbook(x)
+#' 
+#' y <- list(a = x, b = x, c = x)
+#' buildWorkbook(y, asTable = TRUE)
+#' buildWorkbook(y, asTable = TRUE, tableStyle = "TableStyleLight8")
+#' 
+#' @seealso \code{\link{write.xlsx}}
+#' 
+#' @export
+
+buildWorkbook <- function(x, asTable = FALSE, ...) {
+  if (!is.logical(asTable)) {
+    stop("asTable must be a logical.")
+  }
+
+  params <- list(...)
+  isList <- inherits(x, "list")
+
+  if (isList) {
+    params$sheetName <- params$sheetName %||% names(x) %||% paste0("Sheet ", seq_along(x))
+  }
+
+  ## create new Workbook object
+  wb <- do_call_params(createWorkbook, params)
+
+  ## If a list is supplied write to individual worksheets using names if available
+  if (isList) {
+    do_call_params(addWorksheet, params, wb = list(wb), .map = TRUE)
+  } else {
+    params$sheetName <- params$sheetName %||% "Sheet 1"
+    do_call_params(addWorksheet, params, wb = wb)
+  }
+
+  params$sheet <- params$sheet %||% params$sheetName
+
+  # write Data
+  if (asTable) {
+    do_call_params(writeDataTable, params, x = x, wb = list(wb), .map = TRUE)
+  } else {
+    do_call_params(writeData, params, x = x, wb = wb, .map = TRUE)
+  }
+
+  do_setColWidths(wb, x, params, isList)
+  do_call_params(freezePane, params, wb = list(wb), .map = TRUE)
+  wb
+}
+
+
+do_setColWidths <- function(wb, x, params, isList) {
+  if (!isList) {
+    x <- list(x)
+  }
+
+  params$startCol <- params$startCol %||% 1
+  params$startCol <- rep_len(list(params$startCol), length.out = length(x))
+  params$colWidths <- params$colWidths %||% ""
+  params$colWidths <- rep_len(as.list(params$colWidths), length.out = length(x))
+
+  for (i in seq_along(wb$worksheets)) {
+    if (identical(params$colWidths[[i]], "auto")) {
+      setColWidths(
+        wb,
+        sheet = i,
+        cols = seq_along(x[[i]]) + params$startCol[[i]] - 1L, 
+        widths = "auto"
+      )
+    } else if (!identical(params$colWidths[[i]], "")) {
+      setColWidths(
+        wb,
+        sheet = i,
+        cols = seq_along(x[[i]]) + params$startCol[[i]] - 1L,
+        widths = params$colWidths[[i]]
+      )
+    }
+  }
+  wb
+}

R/helperFunctions.R

@@ -536,7 +536,7 @@ get_named_regions_from_string <- function(dn) {
   dn <- gsub("</workbook>", "", dn, fixed = TRUE)
 
   dn <- unique(unlist(strsplit(dn, split = "</definedName>", fixed = TRUE)))
-  dn <- dn[grepl("<definedName", dn, fixed = TRUE)]
+  dn <- grep("<definedName", dn, fixed = TRUE, value = TRUE)
 
   dn_names <- regmatches(dn, regexpr('(?<=name=")[^"]+', dn, perl = TRUE))
 
@@ -563,7 +563,7 @@ get_named_regions_from_string <- function(dn) {
 
 nodeAttributes <- function(x) {
   x <- paste0("<", unlist(strsplit(x, split = "<")))
-  x <- x[grepl("<bgColor|<fgColor", x)]
+  x <- grep("<bgColor|<fgColor", x, value = TRUE)
 
   if (length(x) == 0) {
     return("")