diff --git a/DESCRIPTION b/DESCRIPTION index 909fb7d5..99182b53 100644 --- a/DESCRIPTION +++ b/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' diff --git a/NAMESPACE b/NAMESPACE index 57d4e1b0..4d0d6530 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,6 +15,7 @@ export(addCreator) export(addFilter) export(addStyle) export(addWorksheet) +export(buildWorkbook) export(cloneWorksheet) export(conditionalFormat) export(conditionalFormatting) diff --git a/NEWS.md b/NEWS.md index f958bc7f..59b48230 100644 --- a/NEWS.md +++ b/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 diff --git a/R/WorkbookClass.R b/R/WorkbookClass.R index f37901b7..62a4b53d 100644 --- a/R/WorkbookClass.R +++ b/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 <<- 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/build_workbook.R b/R/build_workbook.R new file mode 100644 index 00000000..4dd7a923 --- /dev/null +++ b/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 +} diff --git a/R/helperFunctions.R b/R/helperFunctions.R index 6915b88c..46101bc7 100644 --- a/R/helperFunctions.R +++ b/R/helperFunctions.R @@ -536,7 +536,7 @@ get_named_regions_from_string <- function(dn) { dn <- gsub("", "", dn, fixed = TRUE) dn <- unique(unlist(strsplit(dn, split = "", fixed = TRUE))) - dn <- dn[grepl(" 0) { workbookRelsXML <- paste(readUTF8(workbookRelsXML), collapse = "") workbookRelsXML <- getChildlessNode(xml = workbookRelsXML, tag = "Relationship") - worksheet_rId_mapping <- workbookRelsXML[grepl("worksheets/sheet", workbookRelsXML, fixed = TRUE)] + worksheet_rId_mapping <- grep("worksheets/sheet", workbookRelsXML, fixed = TRUE, value = TRUE) } ## chartSheetRIds <- NULL if (length(chartSheetsXML) > 0) { - workbookRelsXML <- workbookRelsXML[grepl("chartsheets/sheet", workbookRelsXML, fixed = TRUE)] + workbookRelsXML <- grep("chartsheets/sheet", workbookRelsXML, fixed = TRUE, value = TRUE) chartSheetRIds <- unlist(getId(workbookRelsXML)) chartsheet_rId_mapping <- unlist(regmatches(workbookRelsXML, gregexpr("sheet[0-9]+\\.xml", workbookRelsXML, perl = TRUE, ignore.case = TRUE))) @@ -132,7 +141,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { sheetNo <- as.integer(regmatches(chartSheetsXML, regexpr("(?<=sheet)[0-9]+(?=\\.xml)", chartSheetsXML, perl = TRUE))) chartSheetsXML <- chartSheetsXML[order(sheetNo)] - chartSheetsRelsXML <- xmlFiles[grepl("xl/chartsheets/_rels", xmlFiles, perl = TRUE)] + chartSheetsRelsXML <- grep("xl/chartsheets/_rels", xmlFiles, perl = TRUE, value = TRUE) sheetNo2 <- as.integer(regmatches(chartSheetsRelsXML, regexpr("(?<=sheet)[0-9]+(?=\\.xml\\.rels)", chartSheetsRelsXML, perl = TRUE))) chartSheetsRelsXML <- chartSheetsRelsXML[order(sheetNo2)] @@ -696,7 +705,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { ## Not every sheet has a drawing.xml - drawXMLrelationship <- lapply(xml, function(x) x[grepl("drawings/drawing", x)]) + drawXMLrelationship <- lapply(xml, function(x) grep("drawings/drawing", x, value = TRUE)) hasDrawing <- sapply(drawXMLrelationship, length) > 0 ## which sheets have a drawing if (length(drawingRelsXML) > 0) { @@ -750,7 +759,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { if (length(vmlDrawingXML) > 0) { wb$Content_Types <- c(wb$Content_Types, '') - drawXMLrelationship <- lapply(xml, function(x) x[grepl("drawings/vmlDrawing", x)]) + drawXMLrelationship <- lapply(xml, function(x) grep("drawings/vmlDrawing", x, value = TRUE)) hasDrawing <- sapply(drawXMLrelationship, length) > 0 ## which sheets have a drawing ## loop over all worksheets and assign drawing to sheet @@ -788,10 +797,10 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { ## vmlDrawing and comments if (length(commentsXML) > 0) { - drawXMLrelationship <- lapply(xml, function(x) x[grepl("drawings/vmlDrawing[0-9]+\\.vml", x)]) + drawXMLrelationship <- lapply(xml, function(x) grep("drawings/vmlDrawing[0-9]+\\.vml", x, value = TRUE)) hasDrawing <- sapply(drawXMLrelationship, length) > 0 ## which sheets have a drawing - commentXMLrelationship <- lapply(xml, function(x) x[grepl("comments[0-9]+\\.xml", x)]) + commentXMLrelationship <- lapply(xml, function(x) grep("comments[0-9]+\\.xml", x, value = TRUE)) hasComment <- sapply(commentXMLrelationship, length) > 0 ## which sheets have a comment for (i in seq_along(xml)) { @@ -805,14 +814,14 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { txt <- removeHeadTag(txt) cd <- unique(getNodes(xml = txt, tagIn = "") ## now loada comment target <- unlist(lapply(commentXMLrelationship[[i]], function(x) regmatches(x, gregexpr('(?<=Target=").*?"', x, perl = TRUE))[[1]])) target <- basename(gsub('"$', "", target)) - txt <- paste(readUTF8(commentsXML[grepl(target, commentsXML)]), collapse = "\n") + txt <- paste(readUTF8(grep(target, commentsXML, value = TRUE)), collapse = "\n") txt <- removeHeadTag(txt) authors <- getNodes(xml = txt, tagIn = "") @@ -850,7 +859,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { ## Threaded comments if (length(threadCommentsXML) > 0) { - threadCommentsXMLrelationship <- lapply(xml, function(x) x[grepl("threadedComment[0-9]+\\.xml", x)]) + threadCommentsXMLrelationship <- lapply(xml, function(x) grep("threadedComment[0-9]+\\.xml", x, value = TRUE)) hasThreadComments<- sapply(threadCommentsXMLrelationship, length) > 0 if(any(hasThreadComments)) { for (i in seq_along(xml)) { @@ -858,7 +867,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { target <- unlist(lapply(threadCommentsXMLrelationship[[i]], function(x) regmatches(x, gregexpr('(?<=Target=").*?"', x, perl = TRUE))[[1]])) target <- basename(gsub('"$', "", target)) - wb$threadComments[[i]] <- threadCommentsXML[grepl(target, threadCommentsXML)] + wb$threadComments[[i]] <- grep(target, threadCommentsXML, value = TRUE) } } @@ -884,7 +893,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { ## rels image - drawXMLrelationship <- lapply(xml, function(x) x[grepl("relationships/image", x)]) + drawXMLrelationship <- lapply(xml, function(x) grep("relationships/image", x, value = TRUE)) hasDrawing <- sapply(drawXMLrelationship, length) > 0 ## which sheets have a drawing if (any(hasDrawing)) { for (i in seq_along(xml)) { @@ -900,7 +909,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { } ## rels image - drawXMLrelationship <- lapply(xml, function(x) x[grepl("relationships/package", x)]) + drawXMLrelationship <- lapply(xml, function(x) grep("relationships/package", x, value = TRUE)) hasDrawing <- sapply(drawXMLrelationship, length) > 0 ## which sheets have a drawing if (any(hasDrawing)) { for (i in seq_along(xml)) { @@ -934,7 +943,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { # sheetWithPivot <- which(sapply(pivotTableJ, length) > 0) variable not used pivotRels <- lapply(xml, function(x) { - y <- x[grepl("pivotTable", x)] + y <- grep("pivotTable", x, value = TRUE) y[order(nchar(y), y)] }) hasPivot <- sapply(pivotRels, length) > 0 @@ -958,7 +967,7 @@ loadWorkbook <- function(file, xlsxFile = NULL, isUnzipped = FALSE) { if (length(inds) > 0) { toRemove <- paste(sprintf("(pivotCacheDefinition%s\\.xml)", inds), collapse = "|") - fileNo <- which(grepl(toRemove, wb$pivotTables.xml.rels)) + fileNo <- grep(toRemove, wb$pivotTables.xml.rels) toRemove <- paste(sprintf("(pivotCacheDefinition%s\\.xml)", fileNo), collapse = "|") ## remove reference to file from workbook.xml.res diff --git a/R/openxlsx.R b/R/openxlsx.R index f243d3d6..d0478d9f 100644 --- a/R/openxlsx.R +++ b/R/openxlsx.R @@ -100,6 +100,8 @@ op.openxlsx <- list( openxlsx.keepNA = FALSE, openxlsx.lastColumn = NULL, openxlsx.na.string = NULL, + openxlsx.maxWidth = 250, + openxlsx.minWidth = 3, openxlsx.numFmt = "GENERAL", openxlsx.oddFooter = NULL, openxlsx.oddHeader = NULL, diff --git a/R/readWorkbook.R b/R/readWorkbook.R index d0bb1b24..baebee4d 100644 --- a/R/readWorkbook.R +++ b/R/readWorkbook.R @@ -69,43 +69,47 @@ #' } #' #' @export -read.xlsx <- function(xlsxFile, - sheet, - startRow = 1, - colNames = TRUE, - rowNames = FALSE, - detectDates = FALSE, - skipEmptyRows = TRUE, - skipEmptyCols = TRUE, - rows = NULL, - cols = NULL, - check.names = FALSE, - sep.names = ".", - namedRegion = NULL, - na.strings = "NA", - fillMergedCells = FALSE) { +read.xlsx <- function( + xlsxFile, + sheet, + startRow = 1, + colNames = TRUE, + rowNames = FALSE, + detectDates = FALSE, + skipEmptyRows = TRUE, + skipEmptyCols = TRUE, + rows = NULL, + cols = NULL, + check.names = FALSE, + sep.names = ".", + namedRegion = NULL, + na.strings = "NA", + fillMergedCells = FALSE +) { UseMethod("read.xlsx", xlsxFile) } #' @export -read.xlsx.default <- function(xlsxFile, - sheet, - startRow = 1, - colNames = TRUE, - rowNames = FALSE, - detectDates = FALSE, - skipEmptyRows = TRUE, - skipEmptyCols = TRUE, - rows = NULL, - cols = NULL, - check.names = FALSE, - sep.names = ".", - namedRegion = NULL, - na.strings = "NA", - fillMergedCells = FALSE) { +read.xlsx.default <- function( + xlsxFile, + sheet, + startRow = 1, + colNames = TRUE, + rowNames = FALSE, + detectDates = FALSE, + skipEmptyRows = TRUE, + skipEmptyCols = TRUE, + rows = NULL, + cols = NULL, + check.names = FALSE, + sep.names = ".", + namedRegion = NULL, + na.strings = "NA", + fillMergedCells = FALSE +) { ## Validate inputs and get files xlsxFile <- getFile(xlsxFile) - + if (!file.exists(xlsxFile)) { stop("File does not exist.") } @@ -115,111 +119,72 @@ read.xlsx.default <- function(xlsxFile, sheet <- 1 sheetselected <- FALSE } - - if (grepl("\\.xls$|\\.xlm$", xlsxFile)) { - stop("openxlsx can not read .xls or .xlm files!") - } - - 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.") + + if (!grepl("\\.xlsx$", xlsxFile)) { + stop("openxlsx can only read .xlsx files", call. = FALSE) } - + + 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 - } else if (length(rows) > 1) { + } else if (length(rows) > 1L) { rows <- as.integer(sort(rows)) } - - - ## check startRow - if (!is.null(startRow)) { - if (length(startRow) > 1) { - stop("startRow must have length 1.") - } - } - - ## create temp dir and unzip + xmlDir <- file.path(tempdir(), paste0(sample(LETTERS, 10), collapse = ""), "_excelXMLRead") xmlFiles <- unzip(xlsxFile, exdir = xmlDir) - + on.exit(unlink(xmlDir, recursive = TRUE), add = TRUE) - - sharedStringsFile <- - xmlFiles[grepl("sharedStrings.xml$", xmlFiles, perl = TRUE)] - workbook <- - xmlFiles[grepl("workbook.xml$", xmlFiles, perl = TRUE)] - workbookRelsXML <- - xmlFiles[grepl("workbook.xml.rels$", xmlFiles, perl = TRUE)] - + + sharedStringsFile <- grep("sharedStrings.xml$", xmlFiles, perl = TRUE, value = TRUE) + workbook <- grep("workbook.xml$", xmlFiles, perl = TRUE, value = TRUE) + workbookRelsXML <- grep("workbook.xml.rels$", xmlFiles, perl = TRUE, value = TRUE) + ## get workbook names - workbookRelsXML <- - paste(readUTF8(workbookRelsXML), - collapse = "" - ) - workbookRelsXML <- - getChildlessNode(xml = workbookRelsXML, tag = "Relationship") - - workbook <- - unlist(readUTF8(workbook)) + workbookRelsXML <- paste(readUTF8(workbookRelsXML), collapse = "") + workbookRelsXML <- getChildlessNode(xml = workbookRelsXML, tag = "Relationship") + + workbook <- unlist(readUTF8(workbook)) workbook <- removeHeadTag(workbook) - - sheets <- - unlist(regmatches( - workbook, - gregexpr("(?<=).*(?=)", workbook, perl = TRUE) - )) - sheets <- - unlist(regmatches(sheets, gregexpr("]*>", sheets, perl = TRUE))) + + sheets <- unlist(regmatches( + workbook, + gregexpr("(?<=).*(?=)", workbook, perl = TRUE) + )) + sheets <- unlist(regmatches( + sheets, + gregexpr("]*>", sheets, perl = TRUE) + )) ## Some veryHidden sheets do not have a sheet content and their rId is empty. ## Such sheets need to be filtered out because otherwise their sheet names ## occur in the list of all sheet names, leading to a wrong association ## of sheet names with sheet indeces. - sheets <- - grep('r:id="[[:blank:]]*"', - sheets, - invert = TRUE, - value = TRUE - ) - - + sheets <- grep('r:id="[[:blank:]]*"', sheets, invert = TRUE, value = TRUE) + + ## make sure sheetId is 1 based sheetrId <- unlist(getRId(sheets)) - sheetNames <- - unlist(regmatches(sheets, gregexpr('(?<=name=")[^"]+', sheets, perl = TRUE))) + sheetNames <- unlist(regmatches( + sheets, + gregexpr('(?<=name=")[^"]+', sheets, perl = TRUE) + )) sheetNames <- replaceXMLEntities(sheetNames) - - + + nSheets <- length(sheetrId) if (nSheets == 0) { stop("Workbook has no worksheets") } - - + ## Named region logic reading_named_region <- FALSE if (!is.null(namedRegion)) { @@ -238,7 +203,7 @@ read.xlsx.default <- function(xlsxFile, # name, the name will be "'sheet 1'" instead of "sheet 1. dn_sheetNames[wsp] <- gsub("^'+|'+$", "\\1", dn_sheetNames[wsp]) } - + # namedRegion in between 'name="' and '"' dn_namedRegion <- gsub(".*name=\"(\\w+)\".*", "\\1", dn) @@ -255,9 +220,9 @@ read.xlsx.default <- function(xlsxFile, idx <- match(dn_namedRegion, namedRegion) # make sure that the length of both vectors is identical - dn <- dn[which(!is.na(idx))] - dn_namedRegion <- dn_namedRegion[which(!is.na(idx))] - dn_sheetNames <- dn_sheetNames[which(!is.na(idx))] + dn <- dn[!is.na(idx)] + dn_namedRegion <- dn_namedRegion[!is.na(idx)] + dn_sheetNames <- dn_sheetNames[!is.na(idx)] # a sheet was selected if (sheetselected) { @@ -285,8 +250,8 @@ read.xlsx.default <- function(xlsxFile, # Do not print warning if a specific sheet is requested if ((length(dn) > 1) & (!sheetselected)) { msg <- c(sprintf("Region '%s' found on multiple sheets: \n", namedRegion), - paste(dn_sheetNames, collapse = "\n"), - "\nUsing the first appearance.") + paste(dn_sheetNames, collapse = "\n"), + "\nUsing the first appearance.") message(msg) dn <- dn[1] @@ -294,63 +259,44 @@ read.xlsx.default <- function(xlsxFile, dn_sheetNames <- dn_sheetNames[1] } - region <- - regmatches(dn, regexpr("(?<=>)[^\\<]+", dn, perl = TRUE)) - sheet <- - sheetNames[sapply(sheetNames, function(x) { - grepl(x, dn) - })] + # region is redefined later + region <- regmatches(dn, regexpr("(?<=>)[^\\<]+", dn, perl = TRUE)) + sheet <- sheetNames[vapply(sheetNames, grepl, NA, dn)] + if (length(sheet) > 1) { sheet <- sheet[which.max(nchar(sheet))] } - - region <- - gsub("[^A-Z0-9:]", "", gsub(sheet, "", region, fixed = TRUE)) - + + region <- gsub("[^A-Z0-9:]", "", gsub(sheet, "", region, fixed = TRUE)) + if (grepl(":", region, fixed = TRUE)) { - cols <- - unlist(lapply( - strsplit(region, split = ":", fixed = TRUE), - convertFromExcelRef - )) - rows <- - unlist(lapply(strsplit(region, split = ":", fixed = TRUE), function(x) { - as.integer(gsub("[A-Z]", "", x, perl = TRUE)) - })) - - cols <- seq( - from = cols[1], - to = cols[2], - by = 1 - ) - rows <- seq( - from = rows[1], - to = rows[2], - by = 1 - ) + cols <- unlist(lapply( + strsplit(region, split = ":", fixed = TRUE), + convertFromExcelRef + )) + rows <- unlist(lapply(strsplit(region, split = ":", fixed = TRUE), function(x) { + as.integer(gsub("[A-Z]", "", x, perl = TRUE)) + })) + cols <- seq.int(min(cols), max(cols)) + rows <- seq.int(min(rows), max(rows)) } else { cols <- convertFromExcelRef(region) rows <- as.integer(gsub("[A-Z]", "", region, perl = TRUE)) } - + startRow <- 1 reading_named_region <- TRUE } - - - - - + ## get the file_name for each sheetrId file_name <- sapply(sheetrId, function(rId) { - txt <- - workbookRelsXML[grepl(sprintf('Id="%s"', rId), workbookRelsXML, fixed = TRUE)] + txt <- grep(sprintf('Id="%s"', rId), workbookRelsXML, fixed = TRUE, value = TRUE) regmatches(txt, regexpr('(?<=Target=").+xml(?=")', txt, perl = TRUE)) }) - - + + ## get the correct sheets - if ("character" %in% class(sheet)) { + if (is.character(sheet)) { sheetNames <- replaceXMLEntities(sheetNames) sheetInd <- which(sheetNames == sheet) if (length(sheetInd) == 0) { @@ -363,47 +309,35 @@ read.xlsx.default <- function(xlsxFile, } sheet <- file_name[sheet] } - + if (length(sheet) == 0) { - stop( - "Length of sheet is 0 - something has gone terribly wrong! Please report this bug on github (https://github.com/awalker89/openxlsx/issues) with an example xlsx file." - ) + stop("Length of sheet is 0", call. = FALSE) } - + ## get file - worksheet <- - xmlFiles[grepl( - pattern = tolower(sheet), - x = tolower(xmlFiles), - fixed = TRUE - )] + worksheet <- xmlFiles[grepl(tolower(sheet), tolower(xmlFiles), fixed = TRUE)] if (length(worksheet) == 0) { - stop( - "Length of worksheet is 0 - something has gone terribly wrong! Please report this bug on github (https://github.com/awalker89/openxlsx/issues) with an example xlsx file." - ) + stop("Length of worksheet is 0", call. = FALSE) } - - + ## read in sharedStrings if (length(sharedStringsFile) > 0) { sharedStrings <- getSharedStringsFromFile(sharedStringsFile = sharedStringsFile, isFile = TRUE) if (!is.null(na.strings)) { - sharedStrings[is.na(sharedStrings) | - sharedStrings %in% na.strings] <- "openxlsx_na_vlu" + sharedStrings[is.na(sharedStrings) | sharedStrings %in% na.strings] <- "openxlsx_na_vlu" } } else { sharedStrings <- "" } - - - if ("character" %in% class(startRow)) { + + if (is.character(startRow)) { startRowStr <- startRow startRow <- 1 } else { startRowStr <- NULL } - + ## single function get all r, s (if detect dates is TRUE), t, v cell_info <- getCellInfo( xmlFile = worksheet, @@ -413,18 +347,18 @@ read.xlsx.default <- function(xlsxFile, rows = rows, getDates = detectDates ) - + if (fillMergedCells & length(cell_info$cellMerge) > 0) { # stop("Not implemented") - + merge_mapping <- mergeCell2mapping(cell_info$cellMerge) - + ## remove any elements from r, string_refs, b, s that existing in merge_mapping ## insert all missing refs into r - + to_remove_inds <- cell_info$r %in% merge_mapping$ref to_remove_elems <- cell_info$r[to_remove_inds] - + if (any(to_remove_inds)) { cell_info$r <- cell_info$r[!to_remove_inds] cell_info$s <- cell_info$s[!to_remove_inds] @@ -432,10 +366,10 @@ read.xlsx.default <- function(xlsxFile, cell_info$string_refs <- cell_info$string_refs[!cell_info$string_refs %in% to_remove_elems] } - + ## Now insert inds <- match(merge_mapping$anchor_cell, cell_info$r) - + ## String refs (must sort) new_string_refs <- merge_mapping$ref[merge_mapping$anchor_cell %in% cell_info$string_refs] @@ -443,74 +377,59 @@ read.xlsx.default <- function(xlsxFile, c(cell_info$string_refs, new_string_refs) cell_info$string_refs <- cell_info$string_refs[order( - as.integer(gsub( - "[A-Z]", "", cell_info$string_refs, - perl = TRUE - )), + as.integer(gsub("[A-Z]", "", cell_info$string_refs, perl = TRUE)), nchar(cell_info$string_refs), cell_info$string_refs )] - + ## r cell_info$r <- c(cell_info$r, merge_mapping$ref) cell_info$v <- c(cell_info$v, cell_info$v[inds]) - - ord <- - order(as.integer( - gsub( - pattern = "[A-Z]", - replacement = "", - x = cell_info$r, - perl = TRUE - ) - ), nchar(cell_info$r), cell_info$r) - + + ord <- order( + as.integer(gsub("[A-Z]", "", cell_info$r, perl = TRUE)), + nchar(cell_info$r), + cell_info$r + ) + cell_info$r <- cell_info$r[ord] cell_info$v <- cell_info$v[ord] + if (length(cell_info$s) > 0) { cell_info$s <- c(cell_info$s, cell_info$s[inds])[ord] } - - - cell_info$nRows <- - calc_number_rows(x = cell_info$r, skipEmptyRows = skipEmptyRows) + + cell_info$nRows <- calc_number_rows(x = cell_info$r, skipEmptyRows = skipEmptyRows) } - - - - cell_rows <- - as.integer(gsub("[A-Z]", "", cell_info$r, perl = TRUE)) + + cell_rows <- as.integer(gsub("[A-Z]", "", cell_info$r, perl = TRUE)) cell_cols <- convert_from_excel_ref(x = cell_info$r) - - - ###################################################################### - ## subsetting - + + ## subsetting ---- ## Remove cells where cell is NA (na.strings or empty sharedString '') + if (length(cell_info$v) == 0) { warning("No data found on worksheet.\n", call. = FALSE) return(NULL) } - + keep <- !is.na(cell_info$v) if (!is.null(cols)) { keep <- keep & (cell_cols %in% cols) } - - + ## End of subsetting - ###################################################################### - + ## Subset cell_rows <- cell_rows[keep] cell_cols <- cell_cols[keep] - + v <- cell_info$v[keep] s <- cell_info$s[keep] - + string_refs <- match(cell_info$string_refs, cell_info$r[keep]) string_refs <- string_refs[!is.na(string_refs)] - + if (skipEmptyRows) { nRows <- length(unique(cell_rows)) } else if (reading_named_region) { @@ -519,20 +438,17 @@ read.xlsx.default <- function(xlsxFile, } else { nRows <- max(cell_rows) - min(cell_rows) + 1 } - + if (nRows == 0 | length(cell_rows) == 0) { warning("No data found on worksheet.", call. = FALSE) return(NULL) } - + Encoding(v) <- "UTF-8" ## only works if length(v) > 0 - - - - + if (!is.null(startRowStr)) { stop("startRowStr not implemented") - ind <- which(grepl(startRowStr, v, ignore.case = TRUE)) + ind <- grep(startRowStr, v, ignore.case = TRUE) if (length(ind) > 0) { startRow <- as.numeric(gsub("[A-Z]", "", r[ind[[1]]])) toKeep <- grep(sprintf("[A-Z]%s$", startRow), r)[[1]] @@ -546,8 +462,7 @@ read.xlsx.default <- function(xlsxFile, } } } - - + ## Determine date cells (if required) origin <- 25569L if (detectDates) { @@ -555,106 +470,92 @@ read.xlsx.default <- function(xlsxFile, if (grepl('date1904="1"|date1904="true"', workbook, ignore.case = TRUE)) { origin <- 24107L } - - stylesXML <- xmlFiles[grepl("styles.xml", xmlFiles)] + + stylesXML <- grep("styles.xml", xmlFiles, value = TRUE) styles <- readUTF8(stylesXML) styles <- removeHeadTag(styles) - + ## Number formats numFmts <- getChildlessNode(xml = styles, tag = "numFmt") - + dateIds <- NULL if (length(numFmts) > 0) { - numFmtsIds <- - sapply(numFmts, getAttr, tag = 'numFmtId="', USE.NAMES = FALSE) - formatCodes <- - sapply(numFmts, getAttr, tag = 'formatCode="', USE.NAMES = FALSE) - formatCodes <- - gsub(".*(?<=\\])|@", "", formatCodes, perl = TRUE) - + numFmtsIds <- sapply(numFmts, getAttr, tag = 'numFmtId="', USE.NAMES = FALSE) + formatCodes <- sapply(numFmts, getAttr, tag = 'formatCode="', USE.NAMES = FALSE) + formatCodes <- gsub(".*(?<=\\])|@", "", formatCodes, perl = TRUE) + ## this regex defines what "looks" like a date - dateIds <- - numFmtsIds[!grepl("[^mdyhsapAMP[:punct:] ]", formatCodes) & + dateIds <- numFmtsIds[!grepl("[^mdyhsapAMP[:punct:] ]", formatCodes) & nchar(formatCodes > 3)] } - + dateIds <- c(dateIds, 14) - + ## which styles are using these dateIds cellXfs <- getNodes(xml = styles, tagIn = " 1) creator <- creator[[1]] if (length(creator) == 0) creator <- "" if (!"character" %in% class(creator)) creator <- "" - + if (length(title) > 1) title <- title[[1]] if (length(subject) > 1) subject <- subject[[1]] if (length(category) > 1) category <- category[[1]] - + if (!is.null(title)) { if (!"character" %in% class(title)) { stop("title must be a string") } } - + if (!is.null(subject)) { if (!"character" %in% class(subject)) { stop("subject must be a string") } } - + if (!is.null(category)) { if (!"character" %in% class(category)) { stop("category must be a string") } } - + invisible(Workbook$new(creator = creator, title = title, subject = subject, category = category)) } @@ -74,7 +74,7 @@ createWorkbook <- function(creator = ifelse(.Platform$OS.type == "windows", Sys. #' @param wb A Workbook object to write to file #' @param file A character string naming an xlsx file #' @param overwrite If \code{TRUE}, overwrite any existing file. -#' @param returnValue If \code{TRUE}, returns \code{TRUE} in case of a success, else \code{FALSE}. +#' @param returnValue If \code{TRUE}, returns \code{TRUE} in case of a success, else \code{FALSE}. #' If flag is \code{FALSE}, then no return value is returned. #' @seealso \code{\link{createWorkbook}} #' @seealso \code{\link{addWorksheet}} @@ -95,36 +95,36 @@ saveWorkbook <- function(wb, file, overwrite = FALSE, returnValue = FALSE) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + ## increase scipen to avoid writing in scientific sci_pen <- getOption("scipen") options("scipen" = 10000) on.exit(options("scipen" = sci_pen), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + if (!is.logical(overwrite)) { overwrite <- FALSE } - + if (!is.logical(returnValue)) { returnValue <- FALSE } - + if (file.exists(file) & !overwrite) { stop("File already exists!") } - + xlsx_file <- wb$saveWorkbook() - + result<-tryCatch(file.copy(from = xlsx_file, to = file, overwrite = overwrite), - error = function(e) e, warning = function(w) w) - - - - + error = function(e) e, warning = function(w) w) + + + + ## delete temporary dir unlink(dirname(xlsx_file), force = TRUE, recursive = TRUE) if(returnValue == FALSE){ @@ -132,7 +132,7 @@ saveWorkbook <- function(wb, file, overwrite = FALSE, returnValue = FALSE) { }else{ return(result) } - + } @@ -179,15 +179,15 @@ mergeCells <- function(wb, sheet, cols, rows) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + if (!is.numeric(cols)) { cols <- convertFromExcelRef(cols) } - + wb$mergeCells(sheet, startRow = min(rows), endRow = max(rows), startCol = min(cols), endCol = max(cols)) } @@ -204,11 +204,11 @@ int2col <- function(x) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!is.numeric(x)) { stop("x must be numeric.") } - + convert_to_excel_ref(cols = x, LETTERS = LETTERS) } @@ -228,14 +228,14 @@ removeCellMerge <- function(wb, sheet, cols, rows) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + cols <- convertFromExcelRef(cols) rows <- as.integer(rows) - + wb$removeCellMerge(sheet, startRow = min(rows), endRow = max(rows), startCol = min(cols), endCol = max(cols)) } @@ -270,14 +270,14 @@ sheets <- function(wb) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + nms <- wb$sheet_names nms <- replaceXMLEntities(nms) - + return(nms) } @@ -368,12 +368,12 @@ addWorksheet <- function( gridLines = openxlsx_getOp("gridLines", TRUE), tabColour = NULL, zoom = 100, - header = openxlsx_getOp("header"), - footer = openxlsx_getOp("footer"), - evenHeader = openxlsx_getOp("evenHeader"), - evenFooter = openxlsx_getOp("evenFooter"), - firstHeader = openxlsx_getOp("firstHeader"), - firstFooter = openxlsx_getOp("firstFooter"), + header = openxlsx_getOp("header"), + footer = openxlsx_getOp("footer"), + evenHeader = openxlsx_getOp("evenHeader"), + evenFooter = openxlsx_getOp("evenFooter"), + firstHeader = openxlsx_getOp("firstHeader"), + firstFooter = openxlsx_getOp("firstFooter"), visible = TRUE, paperSize = openxlsx_getOp("paperSize", 9), orientation = openxlsx_getOp("orientation", "portrait"), @@ -383,91 +383,95 @@ addWorksheet <- function( od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + + if (inherits(wb, "list")) { + wb <- wb[[1]] + } + + if (!inherits(wb, "Workbook")) { + stop("wb must be a Workbok", call. = FALSE) + } + # Set NULL defaults gridLines <- gridLines %||% TRUE paperSize <- paperSize %||% 9 orientation <- orientation %||% "portrait" vdpi <- vdpi %||% 300 hdpi <- hdpi %||% 300 - - if (!"Workbook" %in% class(wb)) { - stop("First argument must be a Workbook.") - } - + if (tolower(sheetName) %in% tolower(wb$sheet_names)) { stop(paste0("A worksheet by the name '", sheetName, "' already exists! Sheet names must be unique case-insensitive.")) } - + if (!is.logical(gridLines) | length(gridLines) > 1) { stop("gridLines must be a logical of length 1.") } - + if (nchar(sheetName) > 31) { stop(paste0("sheetName '", sheetName, "' too long! Max length is 31 characters.")) } - + if (!is.null(tabColour)) { tabColour <- validateColour(tabColour, "Invalid tabColour in addWorksheet.") } - + if (!is.numeric(zoom)) { stop("zoom must be numeric") } - + if (!is.character(sheetName)) { sheetName <- as.character(sheetName) } - + if (!is.null(header) & length(header) != 3) { stop("header must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(footer) & length(footer) != 3) { stop("footer must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(evenHeader) & length(evenHeader) != 3) { stop("evenHeader must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(evenFooter) & length(evenFooter) != 3) { stop("evenFooter must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(firstHeader) & length(firstHeader) != 3) { stop("firstHeader must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(firstFooter) & length(firstFooter) != 3) { stop("firstFooter must have length 3 where elements correspond to positions: left, center, right.") } - + visible <- tolower(visible[1]) if (!visible %in% c("true", "false", "hidden", "visible", "veryhidden")) { stop("visible must be one of: TRUE, FALSE, 'hidden', 'visible', 'veryHidden'") } - + orientation <- tolower(orientation) if (!orientation %in% c("portrait", "landscape")) { stop("orientation must be 'portrait' or 'landscape'.") } - + vdpi <- as.integer(vdpi) if (is.na(vdpi)) { stop("vdpi must be numeric") } - + hdpi <- as.integer(hdpi) if (is.na(hdpi)) { stop("hdpi must be numeric") } - - - + + + ## Invalid XML characters sheetName <- replaceIllegalCharacters(sheetName) - + invisible(wb$addWorksheet( sheetName = sheetName, showGridLines = gridLines, @@ -512,22 +516,22 @@ cloneWorksheet <- function(wb, sheetName, clonedSheet) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + if (tolower(sheetName) %in% tolower(wb$sheet_names)) { stop("A worksheet by that name already exists! Sheet names must be unique case-insensitive.") } - + if (nchar(sheetName) > 31) { stop("sheetName too long! Max length is 31 characters.") } - + if (!is.character(sheetName)) { sheetName <- as.character(sheetName) } - + ## Invalid XML characters sheetName <- replaceIllegalCharacters(sheetName) - + invisible(wb$cloneWorksheet(sheetName = sheetName, clonedSheet = clonedSheet)) } @@ -568,11 +572,11 @@ renameWorksheet <- function(wb, sheet, newName) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + invisible(wb$setSheetName(sheet, newName)) } @@ -589,16 +593,16 @@ renameWorksheet <- function(wb, sheet, newName) { #' ## numbers will be removed #' convertFromExcelRef("R22") convertFromExcelRef <- function(col) { - + ## increase scipen to avoid writing in scientific exSciPen <- getOption("scipen") od <- getOption("OutDec") options("scipen" = 10000) options("OutDec" = ".") - + on.exit(options("scipen" = exSciPen), add = TRUE) on.exit(expr = options("OutDec" = od), add = TRUE) - + col <- toupper(col) charFlag <- grepl("[A-Z]", col) if (any(charFlag)) { @@ -607,9 +611,9 @@ convertFromExcelRef <- function(col) { col[charFlag] <- unlist(lapply(seq_along(d), function(i) sum(d[[i]] * (26^( seq_along(d[[i]]) - 1))))) } - + col[!charFlag] <- as.integer(col[!charFlag]) - + return(as.integer(col)) } @@ -752,7 +756,7 @@ createStyle <- function( border = NULL, borderColour = openxlsx_getOp("borderColour", "black"), borderStyle = openxlsx_getOp("borderStyle", "thin"), - bgFill = NULL, + bgFill = NULL, fgFill = NULL, halign = NULL, valign = NULL, @@ -760,20 +764,20 @@ createStyle <- function( wrapText = FALSE, textRotation = NULL, indent = NULL, - locked = NULL, + locked = NULL, hidden = NULL ) { - + ### Error checking od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + ## if num fmt is made up of dd, mm, yy numFmt_original <- numFmt[[1]] numFmt <- tolower(numFmt_original) validNumFmt <- c("general", "number", "currency", "accounting", "date", "longdate", "time", "percentage", "scientific", "text", "3", "4", "comma") - + if (numFmt == "date") { numFmt <- openxlsx_getOp("dateFormat", "date") } else if (numFmt == "longdate") { @@ -781,7 +785,7 @@ createStyle <- function( } else if (!numFmt %in% validNumFmt) { numFmt <- replaceIllegalCharacters(numFmt_original) } - + numFmtMapping <- list( list(numFmtId = 0), # GENERAL list(numFmtId = 2), # NUMBER @@ -797,83 +801,83 @@ createStyle <- function( list(numFmtId = 4), list(numFmtId = 3) ) - + names(numFmtMapping) <- validNumFmt - + ## Validate border line style if (!is.null(borderStyle)) { borderStyle <- validateBorderStyle(borderStyle) } - + if (!is.null(halign)) { halign <- tolower(halign[[1]]) if (!halign %in% c("left", "right", "center")) { stop("Invalid halign argument!") } } - + if (!is.null(valign)) { valign <- tolower(valign[[1]]) if (!valign %in% c("top", "bottom", "center")) { stop("Invalid valign argument!") } } - + if (!is.logical(wrapText)) { stop("Invalid wrapText") } - + if (!is.null(indent)) { if (!is.numeric(indent) & !is.integer(indent)) { stop("indent must be numeric") } } - + textDecoration <- tolower(textDecoration) if (!is.null(textDecoration)) { if (!all(textDecoration %in% c("bold", "strikeout", "italic", "underline", "underline2", ""))) { stop("Invalid textDecoration!") } } - + borderColour <- validateColour(borderColour, "Invalid border colour!") - + if (!is.null(fontColour)) { fontColour <- validateColour(fontColour, "Invalid font colour!") } - + if (!is.null(fontSize)) { if (fontSize < 1) stop("Font size must be greater than 0!") } - + if (!is.null(locked)) { if (!is.logical(locked)) stop("Cell attribute locked must be TRUE or FALSE") } if (!is.null(hidden)) { if (!is.logical(hidden)) stop("Cell attribute hidden must be TRUE or FALSE") } - - - - - + + + + + ######################### error checking complete ############################# style <- Style$new() - + if (!is.null(fontName)) { style$fontName <- list("val" = fontName) } - + if (!is.null(fontSize)) { style$fontSize <- list("val" = fontSize) } - + if (!is.null(fontColour)) { style$fontColour <- list("rgb" = fontColour) } - + style$fontDecoration <- toupper(textDecoration) - + ## background fill if (is.null(bgFill)) { # bgFillList <- NULL variable not used @@ -881,7 +885,7 @@ createStyle <- function( bgFill <- validateColour(bgFill, "Invalid bgFill colour") style$fill <- append(style$fill, list(fillBg = list("rgb" = bgFill))) } - + ## foreground fill if (is.null(fgFill)) { # fgFillList <- NULL variable not used @@ -889,81 +893,81 @@ createStyle <- function( fgFill <- validateColour(fgFill, "Invalid fgFill colour") style$fill <- append(style$fill, list(fillFg = list(rgb = fgFill))) } - - + + ## border if (!is.null(border)) { border <- toupper(border) border <- paste(border, collapse = "") - + ## find position of each side in string sides <- c("LEFT", "RIGHT", "TOP", "BOTTOM") pos <- sapply(sides, function(x) regexpr(x, border)) pos <- pos[order(pos, decreasing = FALSE)] nSides <- sum(pos > 0) - + borderColour <- rep(borderColour, length.out = nSides) borderStyle <- rep(borderStyle, length.out = nSides) - + pos <- pos[pos > 0] - + if (length(pos) == 0) { stop("Unknown border argument") } - + names(borderColour) <- names(pos) names(borderStyle) <- names(pos) - + if ("LEFT" %in% names(pos)) { style$borderLeft <- borderStyle[["LEFT"]] style$borderLeftColour <- list("rgb" = borderColour[["LEFT"]]) } - + if ("RIGHT" %in% names(pos)) { style$borderRight <- borderStyle[["RIGHT"]] style$borderRightColour <- list("rgb" = borderColour[["RIGHT"]]) } - + if ("TOP" %in% names(pos)) { style$borderTop <- borderStyle[["TOP"]] style$borderTopColour <- list("rgb" = borderColour[["TOP"]]) } - + if ("BOTTOM" %in% names(pos)) { style$borderBottom <- borderStyle[["BOTTOM"]] style$borderBottomColour <- list("rgb" = borderColour[["BOTTOM"]]) } } - + ## other fields if (!is.null(halign)) { style$halign <- halign } - + if (!is.null(valign)) { style$valign <- valign } - + if (!is.null(indent)) { style$indent <- indent } - + if (wrapText) { style$wrapText <- TRUE } - + if (!is.null(textRotation)) { if (!is.numeric(textRotation)) { stop("textRotation must be numeric.") } - + if (textRotation < 0 & textRotation >= -90) { textRotation <- (textRotation * -1) + 90 } - + style$textRotation <- round(textRotation[[1]], 0) } - + if (numFmt != "general") { if (numFmt %in% validNumFmt) { style$numFmt <- numFmtMapping[[numFmt[[1]]]] @@ -971,16 +975,16 @@ createStyle <- function( style$numFmt <- list("numFmtId" = 165, formatCode = numFmt) ## Custom numFmt } } - - + + if (!is.null(locked)) { style$locked <- locked } - + if (!is.null(hidden)) { style$hidden <- hidden } - + return(style) } @@ -1027,19 +1031,19 @@ createStyle <- function( #' saveWorkbook(wb, "addStyleExample.xlsx", overwrite = TRUE) #' } addStyle <- function( - wb, - sheet, - style, - rows, - cols, + wb, + sheet, + style, + rows, + cols, gridExpand = FALSE, stack = FALSE ) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - - + + if (!is.null(style$numFmt) & length(wb$styleObjects) > 0) { if (style$numFmt$numFmtId == 165) { maxnumFmtId <- max(c(sapply(wb$styleObjects, function(i) { @@ -1051,26 +1055,26 @@ addStyle <- function( } } sheet <- wb$validateSheet(sheet) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + if (!"Style" %in% class(style)) { stop("style argument must be a Style object.") } - + if (!is.logical(stack)) { stop("stack parameter must be a logical!") } - + if (length(cols) == 0 | length(rows) == 0) { return(invisible(0)) } - + cols <- convertFromExcelRef(cols) rows <- as.integer(rows) - + ## rows and cols need to be the same length if (gridExpand) { n <- length(cols) @@ -1083,8 +1087,8 @@ addStyle <- function( } else if (length(rows) != length(cols)) { stop("Length of rows and cols must be equal.") } - - + + wb$addStyle(sheet = sheet, style = style, rows = rows, cols = cols, stack = stack) } @@ -1105,26 +1109,26 @@ getCellRefs <- function(cellCoords) { if (!"data.frame" %in% class(cellCoords)) { stop("Provide a data.frame!") } - - - + + + if (!("numeric" %in% sapply(cellCoords[, 1], class) | - "integer" %in% sapply(cellCoords[, 1], class)) - & ("numeric" %in% sapply(cellCoords[, 2], class) | - "integer" %in% sapply(cellCoords[, 2], class)) - + "integer" %in% sapply(cellCoords[, 1], class)) + & ("numeric" %in% sapply(cellCoords[, 2], class) | + "integer" %in% sapply(cellCoords[, 2], class)) + ) { stop("Provide a data.frame containing integers!") } - - - - - + + + + + od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + l <- convert_to_excel_ref(cols = unlist(cellCoords[, 2]), LETTERS = LETTERS) paste0(l, cellCoords[, 1]) } @@ -1174,22 +1178,22 @@ freezePane <- function(wb, sheet, firstActiveRow = NULL, firstActiveCol = NULL, od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (is.null(firstActiveRow) & is.null(firstActiveCol) & !firstRow & !firstCol) { return(invisible(0)) } - + if (!is.logical(firstRow)) { stop("firstRow must be TRUE/FALSE") } - + if (!is.logical(firstCol)) { stop("firstCol must be TRUE/FALSE") } - - - - + + + + if (firstRow & !firstCol) { invisible(wb$freezePanes(sheet, firstRow = firstRow)) } else if (firstCol & !firstRow) { @@ -1197,20 +1201,20 @@ freezePane <- function(wb, sheet, firstActiveRow = NULL, firstActiveCol = NULL, } else if (firstRow & firstCol) { invisible(wb$freezePanes(sheet, firstActiveRow = 2L, firstActiveCol = 2L)) } else { ## else both firstRow and firstCol are FALSE - + ## Convert to numeric if column letter given if (!is.null(firstActiveRow)) { firstActiveRow <- convertFromExcelRef(firstActiveRow) } else { firstActiveRow <- 1L } - + if (!is.null(firstActiveCol)) { firstActiveCol <- convertFromExcelRef(firstActiveCol) } else { firstActiveCol <- 1L } - + invisible(wb$freezePanes(sheet, firstActiveRow = firstActiveRow, firstActiveCol = firstActiveCol, firstRow = firstRow, firstCol = firstCol)) } } @@ -1220,11 +1224,11 @@ convert2EMU <- function(d, units) { if (grepl("in", units)) { d <- d * 2.54 } - + if (grepl("mm|milli", units)) { d <- d / 10 } - + return(d * 360000) } @@ -1270,24 +1274,24 @@ insertImage <- function(wb, sheet, file, width = 6, height = 3, startRow = 1, st od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!file.exists(file)) { stop("File does not exist.") } - + if (!grepl("\\\\|\\/", file)) { file <- file.path(getwd(), file, fsep = .Platform$file.sep) } - + units <- tolower(units) - + if (!units %in% c("cm", "in", "px")) { stop("Invalid units.\nunits must be one of: cm, in, px") } - + startCol <- convertFromExcelRef(startCol) startRow <- as.integer(startRow) - + ## convert to inches if (units == "px") { width <- width / dpi @@ -1296,11 +1300,11 @@ insertImage <- function(wb, sheet, file, width = 6, height = 3, startRow = 1, st width <- width / 2.54 height <- height / 2.54 } - + ## Convert to EMUs widthEMU <- as.integer(round(width * 914400L, 0)) # (EMUs per inch) heightEMU <- as.integer(round(height * 914400L, 0)) # (EMUs per inch) - + wb$insertImage(sheet, file = file, startRow = startRow, startCol = startCol, width = widthEMU, height = heightEMU) } @@ -1308,10 +1312,10 @@ pixels2ExcelColWidth <- function(pixels) { if (any(!is.numeric(pixels))) { stop("All elements of pixels must be numeric") } - + pixels[pixels == 0] <- 8.43 pixels[pixels != 0] <- (pixels[pixels != 0] - 12) / 7 + 1 - + pixels } @@ -1345,27 +1349,27 @@ pixels2ExcelColWidth <- function(pixels) { #' } setRowHeights <- function(wb, sheet, rows, heights) { sheet <- wb$validateSheet(sheet) - + if (length(rows) > length(heights)) { heights <- rep(heights, length.out = length(rows)) } - + if (length(heights) > length(rows)) { stop("Greater number of height values than rows.") } - + od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + ## Remove duplicates heights <- heights[!duplicated(rows)] rows <- rows[!duplicated(rows)] - - + + heights <- as.character(as.numeric(heights)) names(heights) <- rows - + wb$setRowHeights(sheet, rows, heights) } @@ -1417,13 +1421,13 @@ setColWidths <- function(wb, sheet, cols, widths = 8.43, hidden = rep(FALSE, len od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + sheet <- wb$validateSheet(sheet) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + widths <- tolower(widths) ## possibly "auto" if (ignoreMergedCells) { widths[widths == "auto"] <- "auto2" @@ -1431,34 +1435,34 @@ setColWidths <- function(wb, sheet, cols, widths = 8.43, hidden = rep(FALSE, len # should do nothing if the cols' length is zero if (length(cols) == 0L) return(invisible(0)) - + if (length(widths) > length(cols)) { stop("More widths than columns supplied.") } - + if (length(hidden) > length(cols)) { stop("hidden argument is longer than cols.") } - + if (length(widths) < length(cols)) { widths <- rep(widths, length.out = length(cols)) } - + if (length(hidden) < length(cols)) { hidden <- rep(hidden, length.out = length(cols)) } - + ## Remove duplicates widths <- widths[!duplicated(cols)] hidden <- hidden[!duplicated(cols)] cols <- cols[!duplicated(cols)] cols <- convertFromExcelRef(cols) - + if (length(wb$colWidths[[sheet]]) > 0) { existing_cols <- names(wb$colWidths[[sheet]]) existing_widths <- unname(wb$colWidths[[sheet]]) existing_hidden <- attr(wb$colWidths[[sheet]], "hidden") - + ## check for existing custom widths flag <- existing_cols %in% cols if (any(flag)) { @@ -1466,17 +1470,17 @@ setColWidths <- function(wb, sheet, cols, widths = 8.43, hidden = rep(FALSE, len existing_widths <- existing_widths[!flag] existing_hidden <- existing_hidden[!flag] } - + all_names <- c(existing_cols, cols) all_widths <- c(existing_widths, widths) all_hidden <- c(existing_hidden, as.character(as.integer(hidden))) - + ord <- order(as.integer(all_names)) all_names <- all_names[ord] all_widths <- all_widths[ord] all_hidden <- all_hidden[ord] - - + + names(all_widths) <- all_names wb$colWidths[[sheet]] <- all_widths attr(wb$colWidths[[sheet]], "hidden") <- all_hidden @@ -1485,26 +1489,26 @@ setColWidths <- function(wb, sheet, cols, widths = 8.43, hidden = rep(FALSE, len wb$colWidths[[sheet]] <- widths attr(wb$colWidths[[sheet]], "hidden") <- as.character(as.integer(hidden)) } - + # Check if any conflicting column outline levels if (length(wb$colOutlineLevels[[sheet]]) > 0) { existing_cols <- names(wb$colOutlineLevels[[sheet]]) - + if (any(existing_cols %in% cols)) { for (i in intersect(existing_cols, cols)) { width_hidden <- attr(wb$colWidths[[sheet]], "hidden")[attr(wb$colWidths[[sheet]], "names") == i] outline_hidden <- attr(wb$colOutlineLevels[[sheet]], "hidden")[attr(wb$colOutlineLevels[[sheet]], "names") == i] - + if (outline_hidden != width_hidden) { attr(wb$colOutlineLevels[[sheet]], "hidden")[attr(wb$colOutlineLevels[[sheet]], "names") == i] <- width_hidden } } - + cols <- cols[!cols %in% existing_cols] hidden <- attr(wb$colWidths[[sheet]], "hidden")[attr(wb$colWidths[[sheet]], "names") %in% cols] } } - + invisible(0) } @@ -1530,15 +1534,15 @@ setColWidths <- function(wb, sheet, cols, widths = 8.43, hidden = rep(FALSE, len #' } removeColWidths <- function(wb, sheet, cols) { sheet <- wb$validateSheet(sheet) - + if (!is.numeric(cols)) { cols <- convertFromExcelRef(cols) } - + od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + customCols <- as.integer(names(wb$colWidths[[sheet]])) removeInds <- which(customCols %in% cols) if (length(removeInds) > 0) { @@ -1577,9 +1581,9 @@ removeRowHeights <- function(wb, sheet, rows) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + sheet <- wb$validateSheet(sheet) - + customRows <- as.integer(names(wb$rowHeights[[sheet]])) removeInds <- which(customRows %in% rows) if (length(removeInds) > 0) { @@ -1636,42 +1640,42 @@ removeRowHeights <- function(wb, sheet, rows) { #' saveWorkbook(wb, "insertPlotExample.xlsx", overwrite = TRUE) #' } insertPlot <- function(wb, sheet, width = 6, height = 4, xy = NULL, - startRow = 1, startCol = 1, fileType = "png", units = "in", dpi = 300) { + startRow = 1, startCol = 1, fileType = "png", units = "in", dpi = 300) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (is.null(dev.list()[[1]])) { warning("No plot to insert.") return() } - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + if (!is.null(xy)) { startCol <- xy[[1]] startRow <- xy[[2]] } - + fileType <- tolower(fileType) units <- tolower(units) - + if (fileType == "jpg") { fileType <- "jpeg" } - + if (!fileType %in% c("png", "jpeg", "tiff", "bmp")) { stop("Invalid file type.\nfileType must be one of: png, jpeg, tiff, bmp") } - + if (!units %in% c("cm", "in", "px")) { stop("Invalid units.\nunits must be one of: cm, in, px") } - + fileName <- tempfile(pattern = "figureImage", fileext = paste0(".", fileType)) - + if (fileType == "bmp") { dev.copy(bmp, filename = fileName, width = width, height = height, units = units, res = dpi) } else if (fileType == "jpeg") { @@ -1681,10 +1685,10 @@ insertPlot <- function(wb, sheet, width = 6, height = 4, xy = NULL, } else if (fileType == "tiff") { dev.copy(tiff, filename = fileName, width = width, height = height, units = units, compression = "none", res = dpi) } - + ## write image invisible(dev.off()) - + insertImage(wb = wb, sheet = sheet, file = fileName, width = width, height = height, startRow = startRow, startCol = startCol, units = units, dpi = dpi) } @@ -1719,19 +1723,19 @@ insertPlot <- function(wb, sheet, width = 6, height = 4, xy = NULL, #' } replaceStyle <- function(wb, index, newStyle) { nStyles <- length(wb$styleObjects) - + if (nStyles == 0) { stop("Workbook has no existing styles.") } - + if (index > nStyles) { stop(sprintf("Invalid index. Workbook only has %s styles.", nStyles)) } - + if (!all("Style" %in% class(newStyle))) { stop("Invalid style object.") } - + wb$styleObjects[[index]]$style <- newStyle } @@ -1748,13 +1752,13 @@ replaceStyle <- function(wb, index, newStyle) { #' getStyles(wb)[1:3] getStyles <- function(wb) { nStyles <- length(wb$styleObjects) - + if (nStyles == 0) { stop("Workbook has no existing styles.") } - + styles <- lapply(wb$styleObjects, "[[", "style") - + return(styles) } @@ -1783,13 +1787,13 @@ removeWorksheet <- function(wb, sheet) { if (class(wb) != "Workbook") { stop("wb must be a Workbook object!") } - + if (length(sheet) != 1) { stop("sheet must have length 1.") } - + wb$deleteWorksheet(sheet) - + invisible(0) } @@ -1821,15 +1825,15 @@ removeWorksheet <- function(wb, sheet) { #' } deleteData <- function(wb, sheet, cols, rows, gridExpand = FALSE) { sheet <- wb$validateSheet(sheet) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - - + + wb$worksheets[[sheet]]$sheet_data$delete(rows_in = rows, cols_in = cols, grid_expand = gridExpand) - - + + invisible(0) } @@ -1861,14 +1865,14 @@ modifyBaseFont <- function(wb, fontSize = 11, fontColour = "black", fontName = " if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (fontSize < 0) stop("Invalid fontSize") fontColour <- validateColour(fontColour) - + wb$styles$fonts[[1]] <- sprintf('', fontSize, fontColour, fontName) } @@ -1893,7 +1897,7 @@ getBaseFont <- function(wb) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + wb$getBaseFont() } @@ -1968,53 +1972,53 @@ getBaseFont <- function(wb) { #' saveWorkbook(wb, "setHeaderFooterExample.xlsx", overwrite = TRUE) #' } setHeaderFooter <- function(wb, sheet, - header = NULL, - footer = NULL, - evenHeader = NULL, - evenFooter = NULL, - firstHeader = NULL, - firstFooter = NULL) { + header = NULL, + footer = NULL, + evenHeader = NULL, + evenFooter = NULL, + firstHeader = NULL, + firstFooter = NULL) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) - + if (!is.null(header) & length(header) != 3) { stop("header must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(footer) & length(footer) != 3) { stop("footer must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(evenHeader) & length(evenHeader) != 3) { stop("evenHeader must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(evenFooter) & length(evenFooter) != 3) { stop("evenFooter must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(firstHeader) & length(firstHeader) != 3) { stop("firstHeader must have length 3 where elements correspond to positions: left, center, right.") } - + if (!is.null(firstFooter) & length(firstFooter) != 3) { stop("firstFooter must have length 3 where elements correspond to positions: left, center, right.") } - + od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + oddHeader <- headerFooterSub(header) oddFooter <- headerFooterSub(footer) evenHeader <- headerFooterSub(evenHeader) evenFooter <- headerFooterSub(evenFooter) firstHeader <- headerFooterSub(firstHeader) firstFooter <- headerFooterSub(firstFooter) - + naToNULLList <- function(x) { lapply(x, function(x) { if (is.na(x)) { @@ -2023,7 +2027,7 @@ setHeaderFooter <- function(wb, sheet, x }) } - + hf <- list( oddHeader = naToNULLList(oddHeader), oddFooter = naToNULLList(oddFooter), @@ -2032,12 +2036,12 @@ setHeaderFooter <- function(wb, sheet, firstHeader = naToNULLList(firstHeader), firstFooter = naToNULLList(firstFooter) ) - + if (all(sapply(hf, length) == 0)) { hf <- NULL } - - + + wb$worksheets[[sheet]]$headerFooter <- hf } @@ -2163,33 +2167,33 @@ setHeaderFooter <- function(wb, sheet, #' saveWorkbook(wb, "pageSetupExample.xlsx", overwrite = TRUE) #' } pageSetup <- function(wb, sheet, orientation = NULL, scale = 100, - left = 0.7, right = 0.7, top = 0.75, bottom = 0.75, - header = 0.3, footer = 0.3, - fitToWidth = FALSE, fitToHeight = FALSE, paperSize = NULL, - printTitleRows = NULL, printTitleCols = NULL, - summaryRow = NULL, summaryCol = NULL) { + left = 0.7, right = 0.7, top = 0.75, bottom = 0.75, + header = 0.3, footer = 0.3, + fitToWidth = FALSE, fitToHeight = FALSE, paperSize = NULL, + printTitleRows = NULL, printTitleCols = NULL, + summaryRow = NULL, summaryCol = NULL) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) xml <- wb$worksheets[[sheet]]$pageSetup - + if (!is.null(orientation)) { orientation <- tolower(orientation) if (!orientation %in% c("portrait", "landscape")) stop("Invalid page orientation.") } else { orientation <- ifelse(grepl("landscape", xml), "landscape", "portrait") ## get existing } - + if (scale < 10 | scale > 400) { stop("Scale must be between 10 and 400.") } - + if (!is.null(paperSize)) { paperSizes <- 1:68 paperSizes <- paperSizes[!paperSizes %in% 48:49] @@ -2200,25 +2204,25 @@ pageSetup <- function(wb, sheet, orientation = NULL, scale = 100, } else { paperSize <- regmatches(xml, regexpr('(?<=paperSize=")[0-9]+', xml, perl = TRUE)) ## get existing } - - + + ############################## ## Keep defaults on orientation, hdpi, vdpi, paperSize hdpi <- regmatches(xml, regexpr('(?<=horizontalDpi=")[0-9]+', xml, perl = TRUE)) vdpi <- regmatches(xml, regexpr('(?<=verticalDpi=")[0-9]+', xml, perl = TRUE)) - - + + ############################## ## Update wb$worksheets[[sheet]]$pageSetup <- sprintf( '', paperSize, orientation, scale, as.integer(fitToWidth), as.integer(fitToHeight), hdpi, vdpi ) - + if (fitToHeight | fitToWidth) { wb$worksheets[[sheet]]$sheetPr <- unique(c(wb$worksheets[[sheet]]$sheetPr, '')) } - + wb$worksheets[[sheet]]$pageMargins <- sprintf('', left, right, top, bottom, header, footer) @@ -2262,7 +2266,7 @@ pageSetup <- function(wb, sheet, orientation = NULL, scale = 100, if (!is.numeric(printTitleRows)) { stop("printTitleRows must be numeric.") } - + wb$createNamedRegion( ref1 = paste0("$", min(printTitleRows)), ref2 = paste0("$", max(printTitleRows)), @@ -2274,7 +2278,7 @@ pageSetup <- function(wb, sheet, orientation = NULL, scale = 100, if (!is.numeric(printTitleCols)) { stop("printTitleCols must be numeric.") } - + cols <- convert_to_excel_ref(cols = range(printTitleCols), LETTERS = LETTERS) wb$createNamedRegion( ref1 = paste0("$", cols[1]), @@ -2287,19 +2291,19 @@ pageSetup <- function(wb, sheet, orientation = NULL, scale = 100, if (!is.numeric(printTitleRows)) { stop("printTitleRows must be numeric.") } - + if (!is.numeric(printTitleCols)) { stop("printTitleCols must be numeric.") } cols <- convert_to_excel_ref(cols = range(printTitleCols), LETTERS = LETTERS) rows <- range(printTitleRows) - + cols <- paste(paste0("$", cols[1]), paste0("$", cols[2]), sep = ":") rows <- paste(paste0("$", rows[1]), paste0("$", rows[2]), sep = ":") localSheetId <- sheet - 1L sheet <- names(wb)[[sheet]] - + wb$workbook$definedNames <- c( wb$workbook$definedNames, sprintf('\'%s\'!%s,\'%s\'!%s', localSheetId, sheet, cols, sheet, rows) @@ -2349,25 +2353,25 @@ pageSetup <- function(wb, sheet, orientation = NULL, scale = 100, #' saveWorkbook(wb, "pageSetupExample.xlsx", overwrite = TRUE) #' } protectWorksheet <- function(wb, sheet, protect = TRUE, password = NULL, - lockSelectingLockedCells = NULL, lockSelectingUnlockedCells = NULL, - lockFormattingCells = NULL, lockFormattingColumns = NULL, lockFormattingRows = NULL, - lockInsertingColumns = NULL, lockInsertingRows = NULL, lockInsertingHyperlinks = NULL, - lockDeletingColumns = NULL, lockDeletingRows = NULL, - lockSorting = NULL, lockAutoFilter = NULL, lockPivotTables = NULL, - lockObjects = NULL, lockScenarios = NULL) { + lockSelectingLockedCells = NULL, lockSelectingUnlockedCells = NULL, + lockFormattingCells = NULL, lockFormattingColumns = NULL, lockFormattingRows = NULL, + lockInsertingColumns = NULL, lockInsertingRows = NULL, lockInsertingHyperlinks = NULL, + lockDeletingColumns = NULL, lockDeletingRows = NULL, + lockSorting = NULL, lockAutoFilter = NULL, lockPivotTables = NULL, + lockObjects = NULL, lockScenarios = NULL) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) # xml <- wb$worksheets[[sheet]]$sheetProtection variable not used - + props <- c() - + if (!missing(password) && !is.null(password)) { props["password"] <- hashPassword(password) } - + if (!missing(lockSelectingLockedCells) && !is.null(lockSelectingLockedCells)) { props["selectLockedCells"] <- toString(as.numeric(lockSelectingLockedCells)) } @@ -2413,7 +2417,7 @@ protectWorksheet <- function(wb, sheet, protect = TRUE, password = NULL, if (!missing(lockScenarios) && !is.null(lockScenarios)) { props["scenarios"] <- toString(as.numeric(lockScenarios)) } - + if (protect) { props["sheet"] <- "1" wb$worksheets[[sheet]]$sheetProtection <- sprintf("", paste(names(props), '="', props, '"', collapse = " ", sep = "")) @@ -2450,7 +2454,7 @@ protectWorkbook <- function(wb, protect = TRUE, password = NULL, lockStructure = if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + invisible(wb$protectWorkbook(protect = protect, password = password, lockStructure = lockStructure, lockWindows = lockWindows)) } @@ -2478,16 +2482,16 @@ showGridLines <- function(wb, sheet, showGridLines = FALSE) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) - + if (!is.logical(showGridLines)) stop("showGridLines must be a logical") - - + + sv <- wb$worksheets[[sheet]]$sheetViews showGridLines <- as.integer(showGridLines) ## If attribute exists gsub @@ -2496,7 +2500,7 @@ showGridLines <- function(wb, sheet, showGridLines = FALSE) { } else { sv <- gsub(" length(wb$worksheets))) { stop("Elements of order are greater than the number of worksheets") } - + wb$sheetOrder <- value - + invisible(wb) } @@ -2596,7 +2600,7 @@ convertToDate <- function(x, origin = "1900-01-01", ...) { x[notNa] <- x[notNa] - 2 x[earlyDate & notNa] <- x[earlyDate & notNa] + 1 } - + return(as.Date(x, origin = origin, ...)) } @@ -2619,25 +2623,25 @@ convertToDateTime <- function(x, origin = "1900-01-01", ...) { sci_pen <- getOption("scipen") options("scipen" = 10000) on.exit(options("scipen" = sci_pen), add = TRUE) - + x <- as.numeric(x) date <- convertToDate(x, origin) - + x <- x * 86400 rem <- x %% 86400 - + hours <- as.integer(floor(rem / 3600)) minutes_fraction <- rem %% 3600 minutes_whole <- as.integer(floor(minutes_fraction / 60)) secs <- minutes_fraction %% 60 - + y <- sprintf("%02d:%02d:%06.3f", hours, minutes_whole, secs) notNA <- !is.na(x) date_time <- rep(NA, length(x)) date_time[notNA] <- as.POSIXct(paste(date[notNA], y[notNA]), ...) - + date_time <- .POSIXct(date_time) - + return(date_time) } @@ -2673,31 +2677,31 @@ names.Workbook <- function(x) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (any(duplicated(tolower(value)))) { stop("Worksheet names must be unique.") } - + existing_sheets <- x$sheet_names inds <- which(value != existing_sheets) - + if (length(inds) == 0) { return(invisible(x)) } - + if (length(value) != length(x$worksheets)) { stop(sprintf("names vector must have length equal to number of worksheets in Workbook [%s]", length(existing_sheets))) } - + if (any(nchar(value) > 31)) { warning("Worksheet names must less than 32 characters. Truncating names...") value[nchar(value) > 31] <- sapply(value[nchar(value) > 31], substr, start = 1, stop = 31) } - + for (i in inds) { invisible(x$setSheetName(i, value[[i]])) } - + invisible(x) } @@ -2753,46 +2757,46 @@ createNamedRegion <- function(wb, sheet, cols, rows, name) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + sheet <- wb$validateSheet(sheet) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + if (!is.numeric(rows)) { stop("rows argument must be a numeric/integer vector") } - + if (!is.numeric(cols)) { stop("cols argument must be a numeric/integer vector") } - + ## check name doesn't already exist ## named region - + ex_names <- regmatches(wb$workbook$definedNames, regexpr('(?<=name=")[^"]+', wb$workbook$definedNames, perl = TRUE)) ex_names <- tolower(replaceXMLEntities(ex_names)) - + if (tolower(name) %in% ex_names) { stop(sprintf("Named region with name '%s' already exists!", name)) } else if (grepl("^[A-Z]{1,3}[0-9]+$", name)) { stop("name cannot look like a cell reference.") } - - + + cols <- round(cols) rows <- round(rows) - + startCol <- min(cols) endCol <- max(cols) - + startRow <- min(rows) endRow <- max(rows) - + ref1 <- paste0("$", convert_to_excel_ref(cols = startCol, LETTERS = LETTERS), "$", startRow) ref2 <- paste0("$", convert_to_excel_ref(cols = endCol, LETTERS = LETTERS), "$", endRow) - + invisible( wb$createNamedRegion(ref1 = ref1, ref2 = ref2, name = name, sheet = wb$sheet_names[sheet]) ) @@ -2853,22 +2857,22 @@ getNamedRegions.default <- function(x) { if (!file.exists(x)) { stop(sprintf("File '%s' does not exist.", x)) } - + xmlDir <- file.path(tempdir(), "named_regions_tmp") xmlFiles <- unzip(x, exdir = xmlDir) - - workbook <- xmlFiles[grepl("workbook.xml$", xmlFiles, perl = TRUE)] + + workbook <- grep("workbook.xml$", xmlFiles, perl = TRUE, value = TRUE) workbook <- unlist(readUTF8(workbook)) - + dn <- getChildlessNode(xml = removeHeadTag(workbook), tag = "definedName") if (length(dn) == 0) { return(NULL) } - + dn_names <- get_named_regions_from_string(dn = dn) - + unlink(xmlDir, recursive = TRUE, force = TRUE) - + return(dn_names) } @@ -2879,9 +2883,9 @@ getNamedRegions.Workbook <- function(x) { if (length(dn) == 0) { return(NULL) } - + dn_names <- get_named_regions_from_string(dn = dn) - + return(dn_names) } @@ -2924,23 +2928,23 @@ addFilter <- function(wb, sheet, rows, cols) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) - + if (length(rows) != 1) { stop("row must be a numeric of length 1.") } - + if (!is.numeric(cols)) { cols <- convertFromExcelRef(cols) } - + wb$worksheets[[sheet]]$autoFilter <- sprintf('', paste(getCellRefs(data.frame("x" = c(rows, rows), "y" = c(min(cols), max(cols)))), collapse = ":")) - + invisible(wb) } @@ -2976,12 +2980,12 @@ removeFilter <- function(wb, sheet) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + for (s in sheet) { s <- wb$validateSheet(s) wb$worksheets[[s]]$autoFilter <- character(0) } - + invisible(wb) } @@ -3023,22 +3027,22 @@ removeFilter <- function(wb, sheet) { #' } setHeader <- function(wb, text, position = "center") { warning("This function is deprecated. Use function 'setHeaderFooter()'") - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + position <- tolower(position) if (!position %in% c("left", "center", "right")) { stop("Invalid position.") } - + if (length(text) != 1) { stop("Text argument must be a character vector of length 1") } - + # sheet <- wb$validateSheet(1) variable not used - wb$headFoot$text[wb$headFoot$pos == position & wb$headFoot$head == "head"] <- + wb$headFoot$text[wb$headFoot$pos == position & wb$headFoot$head == "head"] <- as.character(text) } @@ -3071,20 +3075,20 @@ setHeader <- function(wb, text, position = "center") { #' } setFooter <- function(wb, text, position = "center") { warning("This function is deprecated. Use function 'setHeaderFooter()'") - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + position <- tolower(position) if (!position %in% c("left", "center", "right")) { stop("Invalid position.") } - + if (length(text) != 1) { stop("Text argument must be a character vector of length 1") } - + # sheet <- wb$validateSheet(1) variable not used wb$headFoot$text[wb$headFoot$pos == position & wb$headFoot$head == "foot"] <- as.character(text) } @@ -3171,18 +3175,18 @@ dataValidation <- function(wb, sheet, cols, rows, type, operator, value, allowBl od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + ## rows and cols if (!is.numeric(cols)) { cols <- convertFromExcelRef(cols) } rows <- as.integer(rows) - + ## check length of value if (length(value) > 2) { stop("value argument must be length < 2") } - + valid_types <- c( "whole", "decimal", @@ -3191,12 +3195,12 @@ dataValidation <- function(wb, sheet, cols, rows, type, operator, value, allowBl "textLength", "list" ) - + if (!tolower(type) %in% tolower(valid_types)) { stop("Invalid 'type' argument!") } - - + + ## operator == 'between' we leave out valid_operators <- c( "between", @@ -3208,48 +3212,48 @@ dataValidation <- function(wb, sheet, cols, rows, type, operator, value, allowBl "greaterThanOrEqual", "lessThanOrEqual" ) - + if (tolower(type) != "list") { if (!tolower(operator) %in% tolower(valid_operators)) { stop("Invalid 'operator' argument!") } - + operator <- valid_operators[tolower(valid_operators) %in% tolower(operator)][1] } else { operator <- "between" ## ignored } - + if (!is.logical(allowBlank)) { stop("Argument 'allowBlank' musts be logical!") } - + if (!is.logical(showInputMsg)) { stop("Argument 'showInputMsg' musts be logical!") } - + if (!is.logical(showErrorMsg)) { stop("Argument 'showErrorMsg' musts be logical!") } - + ## All inputs validated - + type <- valid_types[tolower(valid_types) %in% tolower(type)][1] - + ## check input combinations if (type == "date" & !"Date" %in% class(value)) { stop("If type == 'date' value argument must be a Date vector.") } - + if (type == "time" & !any(tolower(class(value)) %in% c("posixct", "posixt"))) { stop("If type == 'date' value argument must be a POSIXct or POSIXlt vector.") } - - + + value <- head(value, 2) allowBlank <- as.integer(allowBlank[1]) showInputMsg <- as.integer(showInputMsg[1]) showErrorMsg <- as.integer(showErrorMsg[1]) - + if (type == "list") { invisible(wb$dataValidation_list( sheet = sheet, @@ -3277,9 +3281,9 @@ dataValidation <- function(wb, sheet, cols, rows, type, operator, value, allowBl showErrorMsg = showErrorMsg )) } - - - + + + invisible(0) } @@ -3316,26 +3320,26 @@ getDateOrigin <- function(xlsxFile) { if (!file.exists(xlsxFile)) { stop("File does not exist.") } - + if (grepl("\\.xls$|\\.xlm$", xlsxFile)) { stop("openxlsx can not read .xls or .xlm files!") } - + ## create temp dir and unzip xmlDir <- file.path(tempdir(), "_excelXMLRead") xmlFiles <- unzip(xlsxFile, exdir = xmlDir) - + on.exit(unlink(xmlDir, recursive = TRUE), add = TRUE) - - workbook <- xmlFiles[grepl("workbook.xml$", xmlFiles, perl = TRUE)] + + workbook <- grep("workbook.xml$", xmlFiles, perl = TRUE, value = TRUE) workbook <- paste(unlist(readUTF8(workbook)), collapse = "") - + if (grepl('date1904="1"|date1904="true"', workbook, ignore.case = TRUE)) { origin <- "1904-01-01" } else { origin <- "1900-01-01" } - + return(origin) } @@ -3359,32 +3363,32 @@ getSheetNames <- function(file) { if (!file.exists(file)) { stop("file does not exist.") } - + if (grepl("\\.xls$|\\.xlm$", file)) { stop("openxlsx can not read .xls or .xlm files!") } - + ## create temp dir and unzip xmlDir <- file.path(tempdir(), "_excelXMLRead") xmlFiles <- unzip(file, exdir = xmlDir) - + on.exit(unlink(xmlDir, recursive = TRUE), add = TRUE) - - workbook <- xmlFiles[grepl("workbook.xml$", xmlFiles, perl = TRUE)] + + workbook <- grep("workbook.xml$", xmlFiles, perl = TRUE, value = TRUE) workbook <- readUTF8(workbook) workbook <- removeHeadTag(workbook) sheets <- unlist(regmatches(workbook, gregexpr("(?<=).*(?=)", workbook, perl = TRUE))) sheets <- unlist(regmatches(sheets, gregexpr("]*>", sheets, perl = TRUE))) - + ## Some veryHidden sheets do not have a sheet content and their rId is empty. ## Such sheets need to be filtered out because otherwise their sheet names ## occur in the list of all sheet names, leading to a wrong association ## of sheet names with sheet indeces. sheets <- grep('r:id="[[:blank:]]*"', sheets, invert = TRUE, value = TRUE) - + sheetNames <- unlist(regmatches(sheets, gregexpr('(?<=name=")[^"]+', sheets, perl = TRUE))) sheetNames <- replaceXMLEntities(sheetNames) - + return(sheetNames) } @@ -3414,12 +3418,12 @@ sheetVisibility <- function(wb) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + state <- rep("visible", length(wb$workbook$sheets)) state[grepl("hidden", wb$workbook$sheets)] <- "hidden" state[grepl("veryHidden", wb$workbook$sheets, ignore.case = TRUE)] <- "veryHidden" - - + + return(state) } @@ -3430,37 +3434,37 @@ sheetVisibility <- function(wb) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + value <- tolower(as.character(value)) if (!any(value %in% c("true", "visible"))) { stop("A workbook must have atleast 1 visible worksheet.") } - + value[value %in% "true"] <- "visible" value[value %in% "false"] <- "hidden" value[value %in% "veryhidden"] <- "veryHidden" - - + + exState0 <- regmatches(wb$workbook$sheets, regexpr('(?<=state=")[^"]+', wb$workbook$sheets, perl = TRUE)) exState <- tolower(exState0) exState[exState %in% "true"] <- "visible" exState[exState %in% "hidden"] <- "hidden" exState[exState %in% "false"] <- "hidden" exState[exState %in% "veryhidden"] <- "veryHidden" - + if (length(value) != length(wb$workbook$sheets)) { stop(sprintf("value vector must have length equal to number of worksheets in Workbook [%s]", length(exState))) } - + inds <- which(value != exState) if (length(inds) == 0) { return(invisible(wb)) } - + for (i in seq_along(wb$worksheets)) { wb$workbook$sheets[i] <- gsub(exState0[i], value[i], wb$workbook$sheets[i], fixed = TRUE) } - + invisible(wb) } @@ -3493,23 +3497,23 @@ pageBreak <- function(wb, sheet, i, type = "row") { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) - + type <- tolower(type)[1] if (!type %in% c("row", "column")) { stop("'type' argument must be 'row' or 'column'.") } - + if (!is.numeric(i)) { stop("'i' must be numeric.") } i <- round(i) - + if (type == "row") { wb$worksheets[[sheet]]$rowBreaks <- c( wb$worksheets[[sheet]]$rowBreaks, @@ -3521,10 +3525,10 @@ pageBreak <- function(wb, sheet, i, type = "row") { sprintf('', i) ) } - - + + # wb$worksheets[[sheet]]$autoFilter <- sprintf('', paste(getCellRefs(data.frame("x" = c(rows, rows), "y" = c(min(cols), max(cols)))), collapse = ":")) - + invisible(wb) } @@ -3567,7 +3571,7 @@ conditionalFormat <- function(wb, sheet, cols, rows, rule = NULL, style = NULL, warning("conditionalFormat() has been deprecated. Use conditionalFormatting().") ## Rule always applies to top left of sqref, $ determine which cells the rule depends on ## Rule for "databar" and colourscale are colours of length 2/3 or 1 respectively. - + type <- tolower(type) if (tolower(type) %in% c("colorscale", "colourscale")) { type <- "colorScale" @@ -3576,62 +3580,62 @@ conditionalFormat <- function(wb, sheet, cols, rows, rule = NULL, style = NULL, } else if (type != "expression") { stop("Invalid type argument. Type must be 'expression', 'colourScale' or 'databar'") } - + ## rows and cols if (!is.numeric(cols)) { cols <- convertFromExcelRef(cols) } rows <- as.integer(rows) - + ## check valid rule if (type == "colorScale") { if (!length(rule) %in% 2:3) { stop("rule must be a vector containing 2 or 3 colours if type is 'colorScale'") } - + rule <- validateColour(rule, errorMsg = "Invalid colour specified in rule.") dxfId <- NULL } else if (type == "dataBar") { - + ## If rule is NULL use default colour if (is.null(rule)) { rule <- "FF638EC6" } else { rule <- validateColour(rule, errorMsg = "Invalid colour specified in rule.") } - + dxfId <- NULL } else { ## else type == "expression" - + rule <- toupper(gsub(" ", "", rule)) rule <- replaceIllegalCharacters(rule) rule <- gsub("!=", "<>", rule) rule <- gsub("==", "=", rule) - + if (!grepl("[A-Z]", substr(rule, 1, 2))) { - + ## formula looks like "operatorX" , attach top left cell to rule rule <- paste0(getCellRefs(data.frame("x" = min(rows), "y" = min(cols))), rule) } ## else, there is a letter in the formula and apply as is - + if (is.null(style)) { style <- createStyle(fontColour = "#9C0006", bgFill = "#FFC7CE") } - + invisible(dxfId <- wb$addDXFS(style)) } - - + + invisible(wb$conditionalFormatCell(sheet, - startRow = min(rows), - endRow = max(rows), - startCol = min(cols), - endCol = max(cols), - dxfId, - formula = rule, - type = type + startRow = min(rows), + endRow = max(rows), + startCol = min(cols), + endCol = max(cols), + dxfId, + formula = rule, + type = type )) - + invisible(0) } @@ -3647,8 +3651,8 @@ conditionalFormat <- function(wb, sheet, cols, rows, rule = NULL, style = NULL, #' @param current A \code{Workbook} object #' @param ... ignored all.equal.Workbook <- function(target, current, ...) { - - + + # print("Comparing workbooks...") # ".rels", # "app", @@ -3668,92 +3672,92 @@ all.equal.Workbook <- function(target, current, ...) { # "tables", # "tables.xml.rels", # "theme" - - + + ## TODO # sheet_data - + x <- target y <- current - - - - + + + + nSheets <- length(names(x)) failures <- NULL - + flag <- all(names(x$charts) %in% names(y$charts)) & all(names(y$charts) %in% names(x$charts)) if (!flag) { message("charts not equal") failures <- c(failures, "wb$charts") } - + flag <- all(sapply(1:nSheets, function(i) isTRUE(all.equal(x$colWidths[[i]], y$colWidths[[i]])))) if (!flag) { message("colWidths not equal") failures <- c(failures, "wb$colWidths") } - + flag <- all(x$Content_Types %in% y$Content_Types) & all(y$Content_Types %in% x$Content_Types) if (!flag) { message("Content_Types not equal") failures <- c(failures, "wb$Content_Types") } - + flag <- all(unlist(x$core) == unlist(y$core)) if (!flag) { message("core not equal") failures <- c(failures, "wb$core") } - - + + flag <- all(unlist(x$drawings) %in% unlist(y$drawings)) & all(unlist(y$drawings) %in% unlist(x$drawings)) if (!flag) { message("drawings not equal") failures <- c(failures, "wb$drawings") } - + flag <- all(unlist(x$drawings_rels) %in% unlist(y$drawings_rels)) & all(unlist(y$drawings_rels) %in% unlist(x$drawings_rels)) if (!flag) { message("drawings_rels not equal") failures <- c(failures, "wb$drawings_rels") } - + flag <- all(sapply(1:nSheets, function(i) isTRUE(all.equal(x$drawings_rels[[i]], y$drawings_rels[[i]])))) if (!flag) { message("drawings_rels not equal") failures <- c(failures, "wb$drawings_rels") } - - - - + + + + flag <- all(names(x$media) %in% names(y$media) & names(y$media) %in% names(x$media)) if (!flag) { message("media not equal") failures <- c(failures, "wb$media") } - + flag <- all(sapply(1:nSheets, function(i) isTRUE(all.equal(x$rowHeights[[i]], y$rowHeights[[i]])))) if (!flag) { message("rowHeights not equal") failures <- c(failures, "wb$rowHeights") } - + flag <- all(sapply(1:nSheets, function(i) isTRUE(all.equal(names(x$rowHeights[[i]]), names(y$rowHeights[[i]]))))) if (!flag) { message("rowHeights not equal") failures <- c(failures, "wb$rowHeights") } - + flag <- all(x$sharedStrings %in% y$sharedStrings) & all(y$sharedStrings %in% x$sharedStrings) & (length(x$sharedStrings) == length(y$sharedStrings)) if (!flag) { message("sharedStrings not equal") failures <- c(failures, "wb$sharedStrings") } - - - + + + # flag <- sapply(1:nSheets, function(i) isTRUE(all.equal(x$worksheets[[i]]$sheet_data, y$worksheets[[i]]$sheet_data))) # if(!all(flag)){ # @@ -3797,170 +3801,170 @@ all.equal.Workbook <- function(target, current, ...) { # return(FALSE) # } # } - - + + flag <- all(names(x$styles) %in% names(y$styles)) & all(names(y$styles) %in% names(x$styles)) if (!flag) { message("names styles not equal") failures <- c(failures, "names of styles not equal") } - + flag <- all(unlist(x$styles) %in% unlist(y$styles)) & all(unlist(y$styles) %in% unlist(x$styles)) if (!flag) { message("styles not equal") failures <- c(failures, "styles not equal") } - - + + flag <- length(x$styleObjects) == length(y$styleObjects) if (!flag) { message("styleObjects lengths not equal") failures <- c(failures, "styleObjects lengths not equal") } - - + + nStyles <- length(x$styleObjects) if (nStyles > 0) { for (i in 1:nStyles) { sx <- x$styleObjects[[i]] sy <- y$styleObjects[[i]] - + flag <- isTRUE(all.equal(sx$sheet, sy$sheet)) if (!flag) { message(sprintf("styleObjects '%s' sheet name not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' sheet name not equal", i)) } - - + + flag <- isTRUE(all.equal(sx$rows, sy$rows)) if (!flag) { message(sprintf("styleObjects '%s' rows not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' rows not equal", i)) } - + flag <- isTRUE(all.equal(sx$cols, sy$cols)) if (!flag) { message(sprintf("styleObjects '%s' cols not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' cols not equal", i)) } - + ## check style class equality flag <- isTRUE(all.equal(sx$style$fontName, sy$style$fontName)) if (!flag) { message(sprintf("styleObjects '%s' fontName not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' fontName not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$fontColour, sy$style$fontColour)) if (!flag) { message(sprintf("styleObjects '%s' fontColour not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' fontColour not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$fontSize, sy$style$fontSize)) if (!flag) { message(sprintf("styleObjects '%s' fontSize not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' fontSize not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$fontFamily, sy$style$fontFamily)) if (!flag) { message(sprintf("styleObjects '%s' fontFamily not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' fontFamily not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$fontDecoration, sy$style$fontDecoration)) if (!flag) { message(sprintf("styleObjects '%s' fontDecoration not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' fontDecoration not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$borderTop, sy$style$borderTop)) if (!flag) { message(sprintf("styleObjects '%s' borderTop not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' borderTop not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$borderLeft, sy$style$borderLeft)) if (!flag) { message(sprintf("styleObjects '%s' borderLeft not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' borderLeft not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$borderRight, sy$style$borderRight)) if (!flag) { message(sprintf("styleObjects '%s' borderRight not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' borderRight not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$borderBottom, sy$style$borderBottom)) if (!flag) { message(sprintf("styleObjects '%s' borderBottom not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' borderBottom not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$borderTopColour, sy$style$borderTopColour)) if (!flag) { message(sprintf("styleObjects '%s' borderTopColour not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' borderTopColour not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$borderLeftColour, sy$style$borderLeftColour)) if (!flag) { message(sprintf("styleObjects '%s' borderLeftColour not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' borderLeftColour not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$borderRightColour, sy$style$borderRightColour)) if (!flag) { message(sprintf("styleObjects '%s' borderRightColour not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' borderRightColour not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$borderBottomColour, sy$style$borderBottomColour)) if (!flag) { message(sprintf("styleObjects '%s' borderBottomColour not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' borderBottomColour not equal", i)) } - - + + flag <- isTRUE(all.equal(sx$style$halign, sy$style$halign)) if (!flag) { message(sprintf("styleObjects '%s' halign not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' halign not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$valign, sy$style$valign)) if (!flag) { message(sprintf("styleObjects '%s' valign not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' valign not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$indent, sy$style$indent)) if (!flag) { message(sprintf("styleObjects '%s' indent not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' indent not equal", i)) } - - + + flag <- isTRUE(all.equal(sx$style$textRotation, sy$style$textRotation)) if (!flag) { message(sprintf("styleObjects '%s' textRotation not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' textRotation not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$numFmt, sy$style$numFmt)) if (!flag) { message(sprintf("styleObjects '%s' numFmt not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' numFmt not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$fill, sy$style$fill)) if (!flag) { message(sprintf("styleObjects '%s' fill not equal", i)) failures <- c(failures, sprintf("styleObjects '%s' fill not equal", i)) } - + flag <- isTRUE(all.equal(sx$style$wrapText, sy$style$wrapText)) if (!flag) { message(sprintf("styleObjects '%s' wrapText not equal", i)) @@ -3968,37 +3972,37 @@ all.equal.Workbook <- function(target, current, ...) { } } } - - + + flag <- all(x$sheet_names %in% y$sheet_names) & all(y$sheet_names %in% x$sheet_names) if (!flag) { message("names workbook not equal") failures <- c(failures, "names workbook not equal") } - + flag <- all(unlist(x$workbook) %in% unlist(y$workbook)) & all(unlist(y$workbook) %in% unlist(x$workbook)) if (!flag) { message("workbook not equal") failures <- c(failures, "wb$workbook") } - + flag <- all(unlist(x$workbook.xml.rels) %in% unlist(y$workbook.xml.rels)) & all(unlist(y$workbook.xml.rels) %in% unlist(x$workbook.xml.rels)) if (!flag) { message("workbook.xml.rels not equal") failures <- c(failures, "wb$workbook.xml.rels") } - - + + for (i in 1:nSheets) { ws_x <- x$worksheets[[i]] ws_y <- y$worksheets[[i]] - + flag <- all(names(ws_x) %in% names(ws_y)) & all(names(ws_y) %in% names(ws_x)) if (!flag) { message(sprintf("names of worksheet elements for sheet %s not equal", i)) failures <- c(failures, sprintf("names of worksheet elements for sheet %s not equal", i)) } - + nms <- c( "sheetPr", "dataValidations", "sheetViews", "cols", "pageMargins", "extLst", "conditionalFormatting", "oleObjects", @@ -4006,7 +4010,7 @@ all.equal.Workbook <- function(target, current, ...) { "mergeCells", "hyperlinks", "headerFooter", "autoFilter", "rowBreaks", "pageSetup", "freezePane", "legacyDrawingHF", "legacyDrawing" ) - + for (j in nms) { flag <- isTRUE(all.equal(gsub(" |\t", "", ws_x[[j]]), gsub(" |\t", "", ws_y[[j]]))) if (!flag) { @@ -4015,51 +4019,51 @@ all.equal.Workbook <- function(target, current, ...) { } } } - - + + flag <- all(unlist(x$sheetOrder) %in% unlist(y$sheetOrder)) & all(unlist(y$sheetOrder) %in% unlist(x$sheetOrder)) if (!flag) { message("sheetOrder not equal") failures <- c(failures, "sheetOrder not equal") } - - + + flag <- length(x$tables) == length(y$tables) if (!flag) { message("length of tables not equal") failures <- c(failures, "length of tables not equal") } - + flag <- all(names(x$tables) == names(y$tables)) if (!flag) { message("names of tables not equal") failures <- c(failures, "names of tables not equal") } - + flag <- all(unlist(x$tables) == unlist(y$tables)) if (!flag) { message("tables not equal") failures <- c(failures, "tables not equal") } - - + + flag <- isTRUE(all.equal(x$tables.xml.rels, y$tables.xml.rels)) if (!flag) { message("tables.xml.rels not equal") failures <- c(failures, "tables.xml.rels not equal") } - + flag <- x$theme == y$theme if (!flag) { message("theme not equal") failures <- c(failures, "theme not equal") } - + if (!is.null(failures)) { return(FALSE) } - - + + # "connections", # "externalLinks", # "externalLinksRels", @@ -4073,8 +4077,8 @@ all.equal.Workbook <- function(target, current, ...) { # "slicers", # "slicerCaches", # "vbaProject", - - + + return(TRUE) } @@ -4100,14 +4104,14 @@ all.equal.Workbook <- function(target, current, ...) { #' @export sheetVisible <- function(wb) { warning("This function is deprecated. Use function 'sheetVisibility()'") - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + state <- rep(TRUE, length(wb$workbook$sheets)) state[grepl("hidden", wb$workbook$sheets)] <- FALSE - + return(state) } @@ -4116,35 +4120,35 @@ sheetVisible <- function(wb) { #' @export `sheetVisible<-` <- function(wb, value) { warning("This function is deprecated. Use function 'sheetVisibility()'") - + if (!is.logical(value)) { stop("value must be a logical vector.") } - + if (!any(value)) { stop("A workbook must have atleast 1 visible worksheet.") } - + value <- as.character(value) value[value %in% "TRUE"] <- "visible" value[value %in% "FALSE"] <- "hidden" - + exState <- rep("visible", length(wb$workbook$sheets)) exState[grepl("hidden", wb$workbook$sheets)] <- "hidden" - + if (length(value) != length(wb$workbook$sheets)) { stop(sprintf("value vector must have length equal to number of worksheets in Workbook [%s]", length(exState))) } - + inds <- which(value != exState) if (length(inds) == 0) { return(invisible(wb)) } - + for (i in inds) { wb$workbook$sheets[i] <- gsub(exState[i], value[i], wb$workbook$sheets[i]) } - + invisible(wb) } @@ -4171,7 +4175,7 @@ copyWorkbook <- function(wb) { if (!inherits(wb, "Workbook")) { stop("argument must be a Workbook.") } - + return(wb$copy()) } @@ -4198,28 +4202,28 @@ getTables <- function(wb, sheet) { if (!inherits(wb, "Workbook")) { stop("argument must be a Workbook.") } - + if (length(sheet) != 1) { stop("sheet argument must be length 1") } - + if (length(wb$tables) == 0) { return(character(0)) } - + sheet <- wb$validateSheet(sheetName = sheet) - + table_sheets <- attr(wb$tables, "sheet") tables <- attr(wb$tables, "tableName") refs <- names(wb$tables) - + refs <- refs[table_sheets == sheet & !grepl("openxlsx_deleted", tables, fixed = TRUE)] tables <- tables[table_sheets == sheet & !grepl("openxlsx_deleted", tables, fixed = TRUE)] - + if (length(tables) > 0) { attr(tables, "refs") <- refs } - + return(tables) } @@ -4265,53 +4269,53 @@ removeTable <- function(wb, sheet, table) { if (!inherits(wb, "Workbook")) { stop("argument must be a Workbook.") } - + if (length(sheet) != 1) { stop("sheet argument must be length 1") } - + if (length(table) != 1) { stop("table argument must be length 1") } - + ## delete table object and all data in it sheet <- wb$validateSheet(sheetName = sheet) - + if (!table %in% attr(wb$tables, "tableName")) { stop(sprintf("table '%s' does not exist.", table), call. = FALSE) } - + ## get existing tables table_sheets <- attr(wb$tables, "sheet") table_names <- attr(wb$tables, "tableName") refs <- names(wb$tables) - + ## delete table object (by flagging as deleted) inds <- which(table_sheets %in% sheet & table_names %in% table) table_name_original <- table_names[inds] - + table_names[inds] <- paste0(table_name_original, "_openxlsx_deleted") attr(wb$tables, "tableName") <- table_names - + ## delete reference from worksheet to table worksheet_table_names <- attr(wb$worksheets[[sheet]]$tableParts, "tableName") to_remove <- which(worksheet_table_names == table_name_original) - + wb$worksheets[[sheet]]$tableParts <- wb$worksheets[[sheet]]$tableParts[-to_remove] attr(wb$worksheets[[sheet]]$tableParts, "tableName") <- worksheet_table_names[-to_remove] - - + + ## Now delete data from the worksheet refs <- strsplit(refs[[inds]], split = ":")[[1]] rows <- as.integer(gsub("[A-Z]", "", refs)) rows <- seq(from = rows[1], to = rows[2], by = 1) - + cols <- convertFromExcelRef(refs) cols <- seq(from = cols[1], to = cols[2], by = 1) - + ## now delete data deleteData(wb = wb, sheet = sheet, rows = rows, cols = cols, gridExpand = TRUE) - + invisible(0) } @@ -4333,25 +4337,25 @@ groupColumns <- function(wb, sheet, cols, hidden = FALSE) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + sheet <- wb$validateSheet(sheet) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + if (any(cols) < 1L) { stop("Invalid columns selected (<= 0).") } - + if (!is.logical(hidden)) { stop("Hidden should be a logical value (TRUE/FALSE).") } - + if (length(hidden) > length(cols)) { stop("Hidden argument is of greater length than number of cols.") } - + levels <- rep("1", length(cols)) hidden <- rep(hidden, length.out = length(cols)) @@ -4359,11 +4363,11 @@ groupColumns <- function(wb, sheet, cols, hidden = FALSE) { levels <- levels[!duplicated(cols)] cols <- cols[!duplicated(cols)] cols <- convertFromExcelRef(cols) - + if (length(wb$colWidths[[sheet]]) > 0) { existing_cols <- names(wb$colWidths[[sheet]]) existing_hidden <- attr(wb$colWidths[[sheet]], "hidden", exact = TRUE) - + if (any(existing_cols %in% cols)) { for (i in intersect(existing_cols, cols)) { width_hidden <- attr(wb$colWidths[[sheet]], "hidden")[attr(wb$colWidths[[sheet]], "names") == i] @@ -4373,20 +4377,20 @@ groupColumns <- function(wb, sheet, cols, hidden = FALSE) { attr(wb$colWidths[[sheet]], "hidden")[attr(wb$colWidths[[sheet]], "names") == i] <- outline_hidden } } - + # cols <- cols[!cols %in% existing_cols] # hidden <- attr(wb$colOutlineLevels[[sheet]], "hidden")[attr(wb$colOutlineLevels[[sheet]], "name") %in% cols] - + # wb$colOutlineLevels[[sheet]] <- cols # attr(wb$colOutlineLevels[[sheet]], "hidden") <- as.character(as.integer(hidden)) } } - + if (length(wb$colOutlineLevels[[sheet]]) > 0) { existing_cols <- names(wb$colOutlineLevels[[sheet]]) existing_levels <- unname(wb$colOutlineLevels[[sheet]]) existing_hidden <- attr(wb$colOutlineLevels[[sheet]], "hidden") - + # check if column is already grouped flag <- existing_cols %in% cols if (any(flag)) { @@ -4394,17 +4398,17 @@ groupColumns <- function(wb, sheet, cols, hidden = FALSE) { existing_levels <- existing_levels[!flag] existing_hidden <- existing_hidden[!flag] } - + all_names <- c(existing_cols, cols) all_levels <- c(existing_levels, levels) all_hidden <- c(existing_hidden, as.character(as.integer(hidden))) - + ord <- order(as.integer(all_names)) all_names <- all_names[ord] all_levels <- all_levels[ord] all_hidden <- all_hidden[ord] - - + + names(all_levels) <- all_names wb$colOutlineLevels[[sheet]] <- all_levels levels <- all_levels @@ -4415,7 +4419,7 @@ groupColumns <- function(wb, sheet, cols, hidden = FALSE) { wb$colOutlineLevels[[sheet]] <- levels attr(wb$colOutlineLevels[[sheet]], "hidden") <- as.character(as.integer(hidden)) } - + invisible(0) } @@ -4434,24 +4438,24 @@ ungroupColumns <- function(wb, sheet, cols) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) - + if (!is.numeric(cols)) { cols <- convertFromExcelRef(cols) } - + if (any(cols) < 1L) { stop("Invalid columns selected (<= 0).") } - + od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + customCols <- as.integer(names(wb$colOutlineLevels[[sheet]])) removeInds <- which(customCols %in% cols) - + # Check if any selected columns are already grouped if (length(removeInds) > 0) { remainingCols <- customCols[-removeInds] @@ -4464,7 +4468,7 @@ ungroupColumns <- function(wb, sheet, cols) { wb$colOutlineLevels[[sheet]] <- rem_widths } } - + if (length(wb$colWidths[[sheet]]) > 0) { if (any(cols %in% names(wb$colWidths[[sheet]]))) { attr(wb$colWidths[[sheet]], "hidden")[attr(wb$colWidths[[sheet]], "names") %in% cols] <- "0" @@ -4487,36 +4491,36 @@ groupRows <- function(wb, sheet, rows, hidden = FALSE) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) - + if (length(hidden) > length(rows)) { stop("Hidden argument is of greater length than number of rows.") } - + if (!is.logical(hidden)) { stop("Hidden should be a logical value (TRUE/FALSE).") } - + if (any(rows) < 1L) { stop("Invalid rows entered (<= 0).") } - + hidden <- rep(as.character(as.integer(hidden)), length.out = length(rows)) - + od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + levels <- rep("1", length(rows)) - + # Remove duplicates hidden <- hidden[!duplicated(rows)] levels <- levels[!duplicated(rows)] rows <- rows[!duplicated(rows)] - + names(levels) <- rows - + wb$groupRows(sheet = sheet, rows = rows, hidden = hidden, levels = levels) } @@ -4535,23 +4539,23 @@ ungroupRows <- function(wb, sheet, rows) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - + sheet <- wb$validateSheet(sheet) - + if (any(rows) < 1L) { stop("Invalid rows entered (<= 0).") } - + customRows <- as.integer(names(wb$outlineLevels[[sheet]])) removeInds <- which(customRows %in% rows) if (length(removeInds) > 0) { wb$outlineLevels[[sheet]] <- wb$outlineLevels[[sheet]][-removeInds] } - + if (length(wb$outlineLevels[[sheet]]) == 0) { wb$worksheets[[sheet]]$sheetFormatPr <- sub(' outlineLevelRow="1"', "", wb$worksheets[[sheet]]$sheetFormatPr) } @@ -4575,7 +4579,7 @@ addCreator <- function(wb, Creator) { if (!inherits(wb, "Workbook")) { stop("argument must be a Workbook.") } - + invisible(wb$addCreator(Creator)) } @@ -4594,7 +4598,7 @@ setLastModifiedBy <- function(wb, LastModifiedBy) { if (!inherits(wb, "Workbook")) { stop("argument must be a Workbook.") } - + invisible(wb$changeLastModifiedBy(LastModifiedBy)) } @@ -4616,7 +4620,7 @@ getCreators <- function(wb) { if (!inherits(wb, "Workbook")) { stop("argument must be a Workbook.") } - + return(wb$getCreators()) } @@ -4643,8 +4647,8 @@ activeSheet <- function(wb) { if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - - + + return(wb$ActiveSheet) } @@ -4655,14 +4659,14 @@ activeSheet <- function(wb) { od <- getOption("OutDec") options("OutDec" = ".") on.exit(expr = options("OutDec" = od), add = TRUE) - + if (!"Workbook" %in% class(wb)) { stop("First argument must be a Workbook.") } - - - + + + invisible(wb$setactiveSheet(value)) - + invisible(wb) -} \ No newline at end of file +} diff --git a/R/writeData.R b/R/writeData.R index a5590903..9ca2593d 100644 --- a/R/writeData.R +++ b/R/writeData.R @@ -14,6 +14,7 @@ #' \code{c(startCol, startRow)}. #' @param colNames If \code{TRUE}, column names of x are written. #' @param rowNames If \code{TRUE}, data.frame row names of x are written. +#' @param row.names,col.names Deprecated, please use \code{rowNames}, \code{colNames} instead #' @param headerStyle Custom style to apply to column names. #' @param borders Either "\code{none}" (default), "\code{surrounding}", #' "\code{columns}", "\code{rows}" or \emph{respective abbreviations}. If @@ -173,22 +174,24 @@ writeData <- function( keepNA = openxlsx_getOp("keepNA", FALSE), na.string = openxlsx_getOp("na.string"), name = NULL, - sep = ", " + sep = ", ", + col.names, + row.names ) { - ## increase scipen to avoid writing in scientific - exSciPen <- getOption("scipen") - od <- getOption("OutDec") - exDigits <- getOption("digits") - - options("scipen" = 200) - options("OutDec" = ".") - options("digits" = 22) - - on.exit(options("scipen" = exSciPen), add = TRUE) - on.exit(expr = options("OutDec" = od), add = TRUE) - on.exit(options("digits" = exDigits), add = TRUE) - + op <- get_set_options() + on.exit(options(op), add = TRUE) + + if (!missing(row.names)) { + warning("Please use 'rowNames' instead of 'row.names'", call. = FALSE) + rowNames <- row.names + } + + if (!missing(col.names)) { + warning("Please use 'colNames' instead of 'col.names'", call. = FALSE) + colNames <- col.names + } + # Set NULLs borders <- borders %||% "none" borderColour <- borderColour %||% "black" @@ -215,16 +218,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") @@ -232,13 +231,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 @@ -278,7 +277,11 @@ writeData <- function( colClasses <- lapply(x, function(x) tolower(class(x))) colClasss2 <- colClasses - colClasss2[sapply(colClasses, function(x) "formula" %in% x) & sapply(colClasses, function(x) "hyperlink" %in% x)] <- "formula" + colClasss2[vapply( + colClasses, + function(i) inherits(i, "formula") & inherits(i, "hyperlink"), + NA + )] <- "formula" if (is.numeric(sheet)) { sheetX <- wb$validateSheet(sheet) @@ -289,26 +292,26 @@ writeData <- function( if (wb$isChartSheet[[sheetX]]) { stop("Cannot write to chart sheet.") - return(NULL) } ## Check not overwriting existing table headers wb$check_overwrite_tables( - sheet = sheet, - new_rows = c(startRow, startRow + nRow - 1L + colNames), - new_cols = c(startCol, startCol + nCol - 1L), + sheet = sheet, + new_rows = c(startRow, startRow + nRow - 1L + colNames), + new_cols = c(startCol, startCol + nCol - 1L), check_table_header_only = TRUE, - error_msg = - "Cannot overwrite table headers. Avoid writing over the header row or see getTables() & removeTables() to remove the table object." + error_msg = "Cannot overwrite table headers. Avoid writing over the header row or see getTables() & removeTables() to remove the table object." ) ## write autoFilter, can only have a single filter per worksheet if (withFilter) { - coords <- data.frame("x" = c(startRow, startRow + nRow + colNames - 1L), "y" = c(startCol, startCol + nCol - 1L)) + coords <- data.frame( + x = c(startRow, startRow + nRow + colNames - 1L), + y = c(startCol, startCol + nCol - 1L) + ) + ref <- stri_join(getCellRefs(coords), collapse = ":") - wb$worksheets[[sheetX]]$autoFilter <- sprintf('', ref) - l <- convert_to_excel_ref(cols = unlist(coords[, 2]), LETTERS = LETTERS) dfn <- sprintf("'%s'!%s", names(wb)[sheetX], stri_join("$", l, "$", coords[, 1], collapse = ":")) @@ -339,12 +342,15 @@ writeData <- function( ) ## header style - if ("Style" %in% class(headerStyle) & colNames) { + if (inherits(headerStyle, "Style") & colNames) { addStyle( - wb = wb, sheet = sheet, style = headerStyle, - rows = startRow, - cols = 0:(nCol - 1) + startCol, - gridExpand = TRUE, stack = TRUE + wb = wb, + sheet = sheet, + style = headerStyle, + rows = startRow, + cols = 0:(nCol - 1) + startCol, + gridExpand = TRUE, + stack = TRUE ) } @@ -517,7 +523,8 @@ writeFormula <- function( array = FALSE, xy = NULL ) { - if (!"character" %in% class(x)) { + + if (!is.character(x)) { stop("x must be a character vector.") } diff --git a/R/writeDataTable.R b/R/writeDataTable.R index 8d280cc5..011759e7 100644 --- a/R/writeDataTable.R +++ b/R/writeDataTable.R @@ -12,6 +12,7 @@ #' A vector of the form c(startCol, startRow) #' @param colNames If \code{TRUE}, column names of x are written. #' @param rowNames If \code{TRUE}, row names of x are written. +#' @param row.names,col.names Deprecated, please use \code{rowNames}, \code{colNames} instead #' @param tableStyle Any excel table style name or "none" (see "formatting" vignette). #' @param tableName name of table in workbook. The table name must be unique. #' @param headerStyle Custom style to apply to column names. @@ -155,8 +156,24 @@ writeDataTable <- function( firstColumn = openxlsx_getOp("firstColumn", FALSE), lastColumn = openxlsx_getOp("lastColumn", FALSE), bandedRows = openxlsx_getOp("bandedRows", TRUE), - bandedCols = openxlsx_getOp("bandedCols", FALSE) + bandedCols = openxlsx_getOp("bandedCols", FALSE), + col.names, + row.names ) { + op <- get_set_options() + on.exit(options(op), add = TRUE) + + ## increase scipen to avoid writing in scientific + + if (!missing(row.names)) { + warning("Please use 'rowNames' instead of 'row.names'", call. = FALSE) + row.names <- rowNames + } + + if (!missing(col.names)) { + warning("Please use 'colNames' instead of 'col.names'", call. = FALSE) + colNames <- col.names + } # Set NULLs withFilter <- withFilter %||% TRUE @@ -165,6 +182,7 @@ writeDataTable <- function( lastColumn <- lastColumn %||% FALSE bandedRows <- bandedRows %||% TRUE bandedCols <- bandedCols %||% FALSE + withFilter <- withFilter %||% TRUE if (!is.null(xy)) { if (length(xy) != 2) { @@ -174,47 +192,25 @@ 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.") - 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.logical(withFilter)) stop("withFilter must be a logical.") - if ((!is.character(sep)) | (length(sep) != 1)) stop("sep must be a character vector of length 1") - - if (!is.logical(firstColumn)) stop("firstColumn must be a logical.") - if (!is.logical(lastColumn)) stop("lastColumn must be a logical.") - if (!is.logical(bandedRows)) stop("bandedRows must be a logical.") - if (!is.logical(bandedCols)) stop("bandedCols must be a logical.") - if (is.null(tableName)) { - tableName <- paste0("Table", as.character(length(wb$tables) + 3L)) + tableName <- sprintf("Table%i", length(wb$tables) + 3L) } else { tableName <- wb$validate_table_name(tableName) } - - ## increase scipen to avoid writing in scientific - exSciPen <- getOption("scipen") - od <- getOption("OutDec") - exDigits <- getOption("digits") - - options("scipen" = 200) - options("OutDec" = ".") - options("digits" = 22) - - on.exit(options("scipen" = exSciPen), add = TRUE) - on.exit(expr = options("OutDec" = od), add = TRUE) - on.exit(options("digits" = exDigits), add = TRUE) - ## convert startRow and startCol if (!is.numeric(startCol)) { startCol <- convertFromExcelRef(startCol) @@ -227,25 +223,17 @@ 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, - cols = 0:(ncol(x) - 1L) + startCol, + wb = wb, + sheet = sheet, + style = headerStyle, + rows = startRow, + cols = 0:(ncol(x) - 1L) + startCol, gridExpand = TRUE ) } @@ -254,9 +242,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 @@ -264,12 +250,16 @@ writeDataTable <- function( colNames[char0] <- colnames(x)[char0] <- paste0("Column", which(char0)) } } else { - colNames <- paste0("Column", seq_len(ncol(x))) + colNames <- paste0("Column", seq_along(x)) names(x) <- colNames } + ## If zero rows, append an empty row (prevent XML from corrupting) if (nrow(x) == 0) { - x <- rbind(as.data.frame(x), matrix("", nrow = 1, ncol = ncol(x), dimnames = list(character(), colnames(x)))) + x <- rbind( + as.data.frame(x), + matrix("", nrow = 1, ncol = ncol(x), dimnames = list(character(), colnames(x))) + ) names(x) <- colNames } @@ -280,14 +270,24 @@ writeDataTable <- function( ## check not overwriting another table wb$check_overwrite_tables( sheet = sheet, - new_rows = c(startRow, startRow + nrow(x) - 1L + 1L) ## + header - , new_cols = c(startCol, startCol + ncol(x) - 1L) + new_rows = c(startRow, startRow + nrow(x) - 1L + 1L), ## + header + new_cols = c(startCol, startCol + ncol(x) - 1L) ) ## column class styling + # consider not using lowercase and instead use inherits(x, class) colClasses <- lapply(x, function(x) tolower(class(x))) - classStyles(wb, sheet = sheet, startRow = startRow, startCol = startCol, colNames = TRUE, nRow = nrow(x), colClasses = colClasses, stack = stack) + classStyles( + wb, + sheet = sheet, + startRow = startRow, + startCol = startCol, + colNames = TRUE, + nRow = nrow(x), + colClasses = colClasses, + stack = stack + ) ## write data to worksheet wb$writeData( diff --git a/R/writexlsx.R b/R/writexlsx.R index cdd256aa..c47300c3 100644 --- a/R/writexlsx.R +++ b/R/writexlsx.R @@ -3,11 +3,11 @@ #' @name write.xlsx #' @title write data to an xlsx file #' @description write a data.frame or list of data.frames to an xlsx file -#' @author Alexander Walker -#' @param x object or a list of objects that can be handled by \code{\link{writeData}} to write to file -#' @param file xlsx file name -#' @param asTable write using writeDataTable as opposed to writeData -#' @param ... optional parameters to pass to functions: +#' @author Alexander Walker, Jordan Mark Barbone +#' @inheritParams buildWorkbook +#' @param file A file path to save the xlsx file +#' @param overwrite If `TRUE` will save over `file` if present (default: `FALSE`) +#' #' \itemize{ #' \item{createWorkbook} #' \item{addWorksheet} @@ -76,6 +76,7 @@ #' @seealso \code{\link{addWorksheet}} #' @seealso \code{\link{writeData}} #' @seealso \code{\link{createStyle}} for style parameters +#' @seealso \code{\link{buildWorkbook}} #' @return A workbook object #' @examples #' @@ -120,512 +121,8 @@ #' } #' #' @export -write.xlsx <- function(x, file, asTable = FALSE, ...) { - - - ## set scientific notation penalty - - params <- list(...) - - ## Possible parameters - - #---createWorkbook---# - ## creator - - #---addWorksheet---# - ## sheetName - ## gridLines - ## tabColour = NULL - ## zoom = 100 - ## header = NULL - ## footer = NULL - ## evenHeader = NULL - ## evenFooter = NULL - ## firstHeader = NULL - ## firstFooter = NULL - - #---writeData---# - ## startCol = 1, - ## startRow = 1, - ## xy = NULL, - ## colNames = TRUE, - ## rowNames = FALSE, - ## headerStyle = NULL, - ## borders = NULL, - ## borderColour = "#4F81BD" - ## borderStyle - ## keepNA = FALSE - ## na.string = NULL - - #----writeDataTable---# - ## startCol = 1 - ## startRow = 1 - ## xy = NULL - ## colNames = TRUE - ## rowNames = FALSE - ## tableStyle = "TableStyleLight9" - ## tableName = NULL - ## headerStyle = NULL - ## withFilter = TRUE - - #---freezePane---# - ## firstActiveRow = NULL - ## firstActiveCol = NULL - ## firstRow = FALSE - ## firstCol = FALSE - - - #---saveWorkbook---# - # overwrite = TRUE - - if (!is.logical(asTable)) { - stop("asTable must be a logical.") - } - - creator <- params$creator %||% openxlsx_getOp("creator", "") - title <- params$title ### will return NULL of not exist - subject <- params$subject ### will return NULL of not exist - category <- params$category ### will return NULL of not exist - - - sheetName <- "Sheet 1" - if ("sheetName" %in% names(params)) { - if (any(nchar(params$sheetName) > 31)) { - stop("sheetName too long! Max length is 31 characters.") - } - - sheetName <- as.character(params$sheetName) - - if ("list" %in% class(x) & length(sheetName) == length(x)) { - names(x) <- sheetName - } - } - - tabColour <- openxlsx_getOp("tabColour") - if ("tabColour" %in% names(params)) { - tabColour <- validateColour(params$tabColour, "Invalid tabColour!") - } - - zoom <- 100 - if ("zoom" %in% names(params)) { - if (is.numeric(params$zoom)) { - zoom <- params$zoom - } else { - stop("zoom must be numeric") - } - } - - ## AddWorksheet - gridLines <- openxlsx_getOp("gridLines") - if ("gridLines" %in% names(params)) { - if (all(is.logical(params$gridLines))) { - gridLines <- params$gridLines - } else { - stop("Argument gridLines must be TRUE or FALSE") - } - } - - overwrite <- TRUE - if ("overwrite" %in% names(params)) { - if (is.logical(params$overwrite)) { - overwrite <- params$overwrite - } else { - stop("Argument overwrite must be TRUE or FALSE") - } - } - - - withFilter <- openxlsx_getOp("withFilter") - if ("withFilter" %in% names(params)) { - if (is.logical(params$withFilter)) { - withFilter <- params$withFilter - } else { - stop("Argument withFilter must be TRUE or FALSE") - } - } - - startRow <- 1 - if ("startRow" %in% names(params)) { - if (all(startRow > 0)) { - startRow <- params$startRow - } else { - stop("startRow must be a positive integer") - } - } - - startCol <- 1 - if ("startCol" %in% names(params)) { - if (all(startCol > 0)) { - startCol <- params$startCol - } else { - stop("startCol must be a positive integer") - } - } - - colNames <- TRUE - if ("colNames" %in% names(params)) { - if (is.logical(params$colNames)) { - colNames <- params$colNames - } else { - stop("Argument colNames must be TRUE or FALSE") - } - } - - ## to be consistent with write.csv - if ("col.names" %in% names(params)) { - if (is.logical(params$col.names)) { - colNames <- params$col.names - } else { - stop("Argument col.names must be TRUE or FALSE") - } - } - - rowNames <- FALSE - if ("rowNames" %in% names(params)) { - if (is.logical(params$rowNames)) { - rowNames <- params$rowNames - } else { - stop("Argument colNames must be TRUE or FALSE") - } - } - - ## to be consistent with write.csv - if ("row.names" %in% names(params)) { - if (is.logical(params$row.names)) { - rowNames <- params$row.names - } else { - stop("Argument row.names must be TRUE or FALSE") - } - } - - xy <- NULL - if ("xy" %in% names(params)) { - if (length(params$xy) != 2) { - stop("xy parameter must have length 2") - } - xy <- params$xy - } - - headerStyle <- openxlsx_getOp("headerStyle") - if ("headerStyle" %in% names(params)) { - if (length(params$headerStyle) == 1) { - if ("Style" %in% class(params$headerStyle)) { - headerStyle <- params$headerStyle - } else { - stop("headerStyle must be a style object.") - } - } else { - if (all(sapply(params$headerStyle, function(x) "Style" %in% class(x)))) { - headerStyle <- params$headerStyle - } else { - stop("headerStyle must be a style object.") - } - } - } - - borders <- openxlsx_getOp("borders") - if ("borders" %in% names(params)) { - borders <- tolower(params$borders) - if (!all(borders %in% c("surrounding", "rows", "columns", "all"))) { - stop("Invalid borders argument") - } - } - - borderColour <- openxlsx_getOp("borderColour") - if ("borderColour" %in% names(params)) { - borderColour <- params$borderColour - } - - borderStyle <- openxlsx_getOp("borderStyle") - if ("borderStyle" %in% names(params)) { - borderStyle <- validateBorderStyle(params$borderStyle) - } - - keepNA <- openxlsx_getOp("keepNA") - if ("keepNA" %in% names(params)) { - if (!"logical" %in% class(keepNA)) { - stop("keepNA must be a logical.") - } else { - keepNA <- params$keepNA - } - } - - na.string <- openxlsx_getOp("na.string") - if ("na.string" %in% names(params)) { - na.string <- as.character(params$na.string) - } - - - tableStyle <- openxlsx_getOp("tableStyle") - if ("tableStyle" %in% names(params)) { - tableStyle <- params$tableStyle - } - - - ## auto column widths - colWidths <- "" - if ("colWidths" %in% names(params)) { - if (length(params$colWidths) != 1L && !is.list(params$colWidths)) { - warning("colWidths must be passed as a list", call. = FALSE) - } - colWidths <- params$colWidths - } - - - ## create new Workbook object - wb <- createWorkbook( - creator = creator, - title = title, - subject = subject, - category = category - ) - - - ## If a list is supplied write to individual worksheets using names if available - nSheets <- 1 - if ("list" %in% class(x)) { - nms <- names(x) - nSheets <- length(x) - - if (is.null(nms)) { - nms <- paste("Sheet", 1:nSheets) - } else if (any("" %in% nms)) { - nms[nms %in% ""] <- paste("Sheet", (1:nSheets)[nms %in% ""]) - } else { - nms <- make.unique(nms) - } - - if (any(nchar(nms) > 31)) { - warning("Truncating list names to 31 characters.") - nms <- substr(nms, 1, 31) - } - - ## make all inputs as long as the list - if (!is.null(tabColour)) { - if (length(tabColour) != nSheets) { - tabColour <- rep_len(tabColour, length.out = nSheets) - } - } - - if (length(zoom) != nSheets) { - zoom <- rep_len(zoom, length.out = nSheets) - } - - if (length(gridLines) != nSheets) { - gridLines <- rep_len(gridLines, length.out = nSheets) - } - - if (length(withFilter) != nSheets) { - withFilter <- withFilter %||% asTable - withFilter <- rep_len(withFilter, length.out = nSheets) - } - - if (length(colNames) != nSheets) { - colNames <- rep_len(colNames, length.out = nSheets) - } - - if (length(rowNames) != nSheets) { - rowNames <- rep_len(rowNames, length.out = nSheets) - } - - if (length(startRow) != nSheets) { - startRow <- rep_len(startRow, length.out = nSheets) - } - - if (length(startCol) != nSheets) { - startCol <- rep_len(startCol, length.out = nSheets) - } - - if (!is.null(headerStyle)) { - headerStyle <- lapply(1:nSheets, function(x) { - return(headerStyle) - }) - } - - if (length(borders) != nSheets & !is.null(borders)) { - borders <- rep_len(borders, length.out = nSheets) - } - - if (length(borderColour) != nSheets) { - borderColour <- rep_len(borderColour, length.out = nSheets) - } - - if (length(borderStyle) != nSheets) { - borderStyle <- rep_len(borderStyle, length.out = nSheets) - } - - if (length(keepNA) != nSheets) { - keepNA <- rep_len(keepNA, length.out = nSheets) - } - - if (length(na.string) != nSheets & !is.null(na.string)) { - na.string <- rep_len(na.string, length.out = nSheets) - } - - if (length(asTable) != nSheets) { - asTable <- rep_len(asTable, length.out = nSheets) - } - - if (length(tableStyle) != nSheets) { - tableStyle <- rep_len(tableStyle, length.out = nSheets) - } - - if (length(colWidths) != nSheets) { - colWidths <- rep_len(colWidths, length.out = nSheets) - } - - for (i in 1:nSheets) { - wb$addWorksheet(nms[[i]], showGridLines = gridLines[i], tabColour = tabColour[i], zoom = zoom[i]) - - if (asTable[i]) { - writeDataTable( - wb = wb, - sheet = i, - x = x[[i]], - startCol = startCol[[i]], - startRow = startRow[[i]], - xy = xy, - colNames = colNames[[i]], - rowNames = rowNames[[i]], - tableStyle = tableStyle[[i]], - tableName = NULL, - headerStyle = headerStyle[[i]], - withFilter = withFilter[[i]], - keepNA = keepNA[[i]], - na.string = na.string[[i]] - ) - } else { - writeData( - wb = wb, - sheet = i, - x = x[[i]], - startCol = startCol[[i]], - startRow = startRow[[i]], - xy = xy, - colNames = colNames[[i]], - rowNames = rowNames[[i]], - headerStyle = headerStyle[[i]], - borders = borders[[i]], - borderColour = borderColour[[i]], - borderStyle = borderStyle[[i]], - keepNA = keepNA[[i]], - na.string = na.string[[i]] - ) - } - - if (identical(colWidths[[i]], "auto")) { - setColWidths(wb, sheet = i, cols = seq_along(x[[i]]) + startCol[[i]] - 1L, widths = "auto") - } else if (!identical(colWidths[[i]], "")) { - setColWidths(wb, sheet = i, cols = seq_along(x[[i]]) + startCol[[i]] - 1L, widths = colWidths[[i]]) - } - } - } else { - wb$addWorksheet(sheetName, showGridLines = gridLines, tabColour = tabColour, zoom = zoom) - - if (asTable) { - if (!"data.frame" %in% class(x)) { - stop("x must be a data.frame is asTable == TRUE") - } - - writeDataTable( - wb = wb, - sheet = 1, - x = x, - startCol = startCol, - startRow = startRow, - xy = xy, - colNames = colNames, - rowNames = rowNames, - tableStyle = tableStyle, - tableName = NULL, - headerStyle = headerStyle, - withFilter = withFilter, - keepNA = keepNA, - na.string = na.string - ) - } else { - writeData( - wb = wb, - sheet = 1, - x = x, - startCol = startCol, - startRow = startRow, - xy = xy, - colNames = colNames, - rowNames = rowNames, - headerStyle = headerStyle, - borders = borders, - borderColour = borderColour, - borderStyle = borderStyle, - withFilter = withFilter, - keepNA = keepNA, - na.string = na.string - ) - } - - if (identical(colWidths, "auto")) { - setColWidths(wb, sheet = 1, cols = seq_along(x) + startCol - 1L, widths = "auto") - } else if (!identical(colWidths, "")) { - setColWidths(wb, sheet = 1, cols = seq_along(x) + startCol - 1L, widths = colWidths) - } - } - - ### --Freeze Panes---### - ## firstActiveRow = NULL - ## firstActiveCol = NULL - ## firstRow = FALSE - ## firstCol = FALSE - - freezePanes <- FALSE - firstActiveRow <- rep_len(1L, length.out = nSheets) - if ("firstActiveRow" %in% names(params)) { - firstActiveRow <- params$firstActiveRow - freezePanes <- TRUE - if (length(firstActiveRow) != nSheets) { - firstActiveRow <- rep_len(firstActiveRow, length.out = nSheets) - } - } - - firstActiveCol <- rep_len(1L, length.out = nSheets) - if ("firstActiveCol" %in% names(params)) { - firstActiveCol <- params$firstActiveCol - freezePanes <- TRUE - if (length(firstActiveCol) != nSheets) { - firstActiveCol <- rep_len(firstActiveCol, length.out = nSheets) - } - } - - firstRow <- rep_len(FALSE, length.out = nSheets) - if ("firstRow" %in% names(params)) { - firstRow <- params$firstRow - freezePanes <- TRUE - if ("list" %in% class(x) & length(firstRow) != nSheets) { - firstRow <- rep_len(firstRow, length.out = nSheets) - } - } - - firstCol <- rep_len(FALSE, length.out = nSheets) - if ("firstCol" %in% names(params)) { - firstCol <- params$firstCol - freezePanes <- TRUE - if ("list" %in% class(x) & length(firstCol) != nSheets) { - firstCol <- rep_len(firstCol, length.out = nSheets) - } - } - - if (freezePanes) { - for (i in 1:nSheets) { - freezePane( - wb = wb, - sheet = i, - firstActiveRow = firstActiveRow[i], - firstActiveCol = firstActiveCol[i], - firstRow = firstRow[i], - firstCol = firstCol[i] - ) - } - } - - saveWorkbook(wb = wb, file = file, overwrite = overwrite) +write.xlsx <- function(x, file, asTable = FALSE, overwrite = FALSE, ...) { + wb <- buildWorkbook(x, asTable = asTable, ...) + saveWorkbook(wb, file = file, overwrite = overwrite) invisible(wb) } diff --git a/man/buildWorkbook.Rd b/man/buildWorkbook.Rd new file mode 100644 index 00000000..d1a4fe71 --- /dev/null +++ b/man/buildWorkbook.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/build_workbook.R +\name{buildWorkbook} +\alias{buildWorkbook} +\title{Build Workbook} +\usage{ +buildWorkbook(x, asTable = FALSE, ...) +} +\arguments{ +\item{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} + +\item{asTable}{If \code{TRUE} will use \code{\link{writeDataTable}} rather +than \code{\link{writeData}} to write \code{x} to the file (default: +\code{FALSE})} + +\item{...}{Additional arguments passed to \code{\link{writeData}}, +\code{\link{writeDataTable}}, \code{\link{setColWidths}}} +} +\value{ +A Workbook object +} +\description{ +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}}. +} +\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}} +} +\author{ +Jordan Mark Barbone +} diff --git a/man/if_null_then.Rd b/man/if_null_then.Rd index e1ea58bf..c86f36d7 100644 --- a/man/if_null_then.Rd +++ b/man/if_null_then.Rd @@ -20,6 +20,6 @@ Replace NULL x <- NULL x <- x \%||\% "none" x <- x \%||\% NA -} +} } diff --git a/man/openxlsx_options.Rd b/man/openxlsx_options.Rd index 5982138b..1535fbd5 100644 --- a/man/openxlsx_options.Rd +++ b/man/openxlsx_options.Rd @@ -8,7 +8,7 @@ \alias{openxlsx_setOp} \title{openxlsx Options} \format{ -An object of class \code{list} of length 32. +An object of class \code{list} of length 34. } \usage{ op.openxlsx diff --git a/man/saveWorkbook.Rd b/man/saveWorkbook.Rd index ed88d33c..95742578 100644 --- a/man/saveWorkbook.Rd +++ b/man/saveWorkbook.Rd @@ -13,7 +13,7 @@ saveWorkbook(wb, file, overwrite = FALSE, returnValue = FALSE) \item{overwrite}{If \code{TRUE}, overwrite any existing file.} -\item{returnValue}{If \code{TRUE}, returns \code{TRUE} in case of a success, else \code{FALSE}. +\item{returnValue}{If \code{TRUE}, returns \code{TRUE} in case of a success, else \code{FALSE}. If flag is \code{FALSE}, then no return value is returned.} } \description{ diff --git a/man/write.xlsx.Rd b/man/write.xlsx.Rd index 7067d9e8..c81128f6 100644 --- a/man/write.xlsx.Rd +++ b/man/write.xlsx.Rd @@ -4,16 +4,20 @@ \alias{write.xlsx} \title{write data to an xlsx file} \usage{ -write.xlsx(x, file, asTable = FALSE, ...) +write.xlsx(x, file, asTable = FALSE, overwrite = FALSE, ...) } \arguments{ -\item{x}{object or a list of objects that can be handled by \code{\link{writeData}} to write to file} +\item{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} -\item{file}{xlsx file name} +\item{file}{A file path to save the xlsx file} -\item{asTable}{write using writeDataTable as opposed to writeData} +\item{asTable}{If \code{TRUE} will use \code{\link{writeDataTable}} rather +than \code{\link{writeData}} to write \code{x} to the file (default: +\code{FALSE})} + +\item{overwrite}{If `TRUE` will save over `file` if present (default: `FALSE`) -\item{...}{optional parameters to pass to functions: \itemize{ \item{createWorkbook} \item{addWorksheet} @@ -23,6 +27,9 @@ write.xlsx(x, file, asTable = FALSE, ...) } see details.} + +\item{...}{Additional arguments passed to \code{\link{writeData}}, +\code{\link{writeDataTable}}, \code{\link{setColWidths}}} } \value{ A workbook object @@ -137,7 +144,9 @@ write.xlsx(l, "writeList2.xlsx", colWidths = list(rep(10, 5), rep(8, 11), rep(5, \code{\link{writeData}} \code{\link{createStyle}} for style parameters + +\code{\link{buildWorkbook}} } \author{ -Alexander Walker +Alexander Walker, Jordan Mark Barbone } diff --git a/man/writeData.Rd b/man/writeData.Rd index 6b821255..43247095 100644 --- a/man/writeData.Rd +++ b/man/writeData.Rd @@ -22,7 +22,9 @@ writeData( keepNA = openxlsx_getOp("keepNA", FALSE), na.string = openxlsx_getOp("na.string"), name = NULL, - sep = ", " + sep = ", ", + col.names, + row.names ) } \arguments{ @@ -84,6 +86,8 @@ each column. If "\code{all}" all cell borders are drawn.} \item{name}{If not NULL, a named region is defined.} \item{sep}{Only applies to list columns. The separator used to collapse list columns to a character vector e.g. sapply(x$list_column, paste, collapse = sep).} + +\item{row.names, col.names}{Deprecated, please use \code{rowNames}, \code{colNames} instead} } \value{ invisible(0) diff --git a/man/writeDataTable.Rd b/man/writeDataTable.Rd index 247cf457..b7bdeaba 100644 --- a/man/writeDataTable.Rd +++ b/man/writeDataTable.Rd @@ -24,7 +24,9 @@ writeDataTable( firstColumn = openxlsx_getOp("firstColumn", FALSE), lastColumn = openxlsx_getOp("lastColumn", FALSE), bandedRows = openxlsx_getOp("bandedRows", TRUE), - bandedCols = openxlsx_getOp("bandedCols", FALSE) + bandedCols = openxlsx_getOp("bandedCols", FALSE), + col.names, + row.names ) } \arguments{ @@ -75,6 +77,8 @@ existing style is replaced by the new style. \item{bandedRows}{logical. If TRUE, rows are colour banded} \item{bandedCols}{logical. If TRUE, the columns are colour banded} + +\item{row.names, col.names}{Deprecated, please use \code{rowNames}, \code{colNames} instead} } \description{ Write to a worksheet and format as an Excel table diff --git a/tests/testthat/test-activeSheet.R b/tests/testthat/test-activeSheet.R index 9add9cd4..2776af01 100644 --- a/tests/testthat/test-activeSheet.R +++ b/tests/testthat/test-activeSheet.R @@ -4,9 +4,9 @@ context("active Sheet ") test_that("get and set active sheet of a workbook", { - tempFile1 <- file.path(tempdir(), "temp1.xlsx") - tempFile2 <- file.path(tempdir(), "temp2.xlsx") - tempFile3 <- file.path(tempdir(), "temp3.xlsx") + tempFile1 <- temp_xlsx("temp1") + tempFile2 <- temp_xlsx("temp2") + tempFile3 <- temp_xlsx("temp3") wbook <- createWorkbook() addWorksheet(wbook, sheetName = "S1") addWorksheet(wbook, sheetName = "S2") diff --git a/tests/testthat/test-build_workbook.R b/tests/testthat/test-build_workbook.R new file mode 100644 index 00000000..aee84e21 --- /dev/null +++ b/tests/testthat/test-build_workbook.R @@ -0,0 +1,42 @@ +test_that("buildWorkbook() accepts tableName [187]", { + x <- data.frame(a = 1, b = 2) + + # default name + wb <- buildWorkbook(x, asTable = TRUE) + expect_equal(attr(wb$tables, "tableName"), "Table3") + + # define 1/2 table name + wb <- buildWorkbook(x, asTable = TRUE, tableName = "table_x") + expect_equal(attr(wb$tables, "tableName"), "table_x") + + # define 2/2 table names + wb <- buildWorkbook(list(x, x), asTable = TRUE, tableName = c("table_x", "table_y")) + expect_equal(attr(wb$tables, "tableName"), c("table_x", "table_y")) + + # try to define 1/2 table names + expect_error(buildWorkbook(list(x, x), asTable = TRUE, tableName = "table_x")) +}) + +test_that("row.name and col.name are deprecated", { + x <- data.frame(a = 1) + + expect_warning( + buildWorkbook(x, file = temp_xlsx(), row.names = TRUE, overwrite = TRUE), + "Please use 'rowNames' instead of 'row.names'" + ) + + expect_warning( + buildWorkbook(x, file = temp_xlsx(), row.names = TRUE, overwrite = TRUE, asTable = TRUE), + "Please use 'rowNames' instead of 'row.names'" + ) + + expect_warning( + buildWorkbook(x, file = temp_xlsx(), col.names = TRUE, overwrite = TRUE), + "Please use 'colNames' instead of 'col.names'" + ) + + expect_warning( + buildWorkbook(x, file = temp_xlsx(), col.names = TRUE, overwrite = TRUE, asTable = TRUE), + "Please use 'colNames' instead of 'col.names'" + ) +}) diff --git a/tests/testthat/test-deleting_tables.R b/tests/testthat/test-deleting_tables.R index ddd0e662..5a0a9659 100644 --- a/tests/testthat/test-deleting_tables.R +++ b/tests/testthat/test-deleting_tables.R @@ -9,9 +9,7 @@ test_that("Deleting a Table Object", { writeDataTable(wb, sheet = "Sheet 1", x = iris, tableName = "iris") writeDataTable(wb, sheet = 1, x = mtcars, tableName = "mtcars", startCol = 10) - - ################################################################################### - ## Get table + # Get table ---- expect_equal(length(getTables(wb, sheet = 1)), 2L) expect_equal(length(getTables(wb, sheet = "Sheet 1")), 2L) @@ -30,12 +28,7 @@ test_that("Deleting a Table Object", { expect_equal(length(wb$tables), 2L) - - - - - ################################################################################### - ## Deleting a worksheet + ## Deleting a worksheet ---- removeWorksheet(wb, 1) expect_equal(length(wb$tables), 2L) @@ -88,9 +81,6 @@ test_that("Deleting a Table Object", { "mtcars" )) - - - ## removeTable clears table object and all data writeDataTable(wb, sheet = 1, x = iris, tableName = "iris", startCol = 1) expect_equal(wb$worksheets[[1]]$tableParts, c("", ""), check.attributes = FALSE) @@ -115,11 +105,8 @@ test_that("Deleting a Table Object", { expect_equal(getTables(wb, sheet = 1), "mtcars", check.attributes = FALSE) }) - - - test_that("Save and load Table Deletion", { - temp_file <- tempfile(fileext = ".xlsx") + temp_file <- temp_xlsx() wb <- createWorkbook() addWorksheet(wb, sheetName = "Sheet 1") @@ -161,7 +148,7 @@ test_that("Save and load Table Deletion", { removeTable(wb = wb, sheet = 1, table = "iris") expect_equal(attr(wb$tables, "tableName"), c("iris_openxlsx_deleted", "mtcars")) - temp_file <- tempfile(fileext = ".xlsx") + temp_file <- temp_xlsx() saveWorkbook(wb = wb, file = temp_file, overwrite = TRUE) wb <- loadWorkbook(file = temp_file) @@ -186,7 +173,7 @@ test_that("Save and load Table Deletion", { removeTable(wb = wb, sheet = 1, table = "mtcars") expect_equal(attr(wb$tables, "tableName"), c("iris_openxlsx_deleted", "mtcars_openxlsx_deleted", "mtcars2")) - temp_file <- tempfile(fileext = ".xlsx") + temp_file <- temp_xlsx() saveWorkbook(wb = wb, file = temp_file, overwrite = TRUE) wb <- loadWorkbook(file = temp_file) diff --git a/tests/testthat/test-encoding.R b/tests/testthat/test-encoding.R index 28c183a1..26b55dbd 100644 --- a/tests/testthat/test-encoding.R +++ b/tests/testthat/test-encoding.R @@ -6,7 +6,7 @@ context("Encoding Tests") test_that("Write read encoding equality", { - tempFile <- file.path(tempdir(), "temp.xlsx") + tempFile <- temp_xlsx() wb <- createWorkbook() for (i in 1:4) { @@ -53,7 +53,7 @@ test_that("Support non-ASCII strings not in UTF-8 encodings", { X = non_ascii, Y = seq_along(non_ascii), stringsAsFactors = FALSE ) colnames(non_ascii_df) <- non_ascii[3:4] - file <- tempfile(fileext = ".xlsx") + file <- temp_xlsx() wb <- createWorkbook(creator = non_ascii[1]) ws <- addWorksheet(wb, non_ascii[2]) writeDataTable(wb, ws, non_ascii_df, tableName = non_ascii[3]) diff --git a/tests/testthat/test-fill_merged_cells.R b/tests/testthat/test-fill_merged_cells.R index 87423cd3..fdae4667 100644 --- a/tests/testthat/test-fill_merged_cells.R +++ b/tests/testthat/test-fill_merged_cells.R @@ -21,7 +21,7 @@ test_that("fill merged cells", { mergeCells(wb = wb, sheet = 1, cols = 2:4, rows = 4) mergeCells(wb = wb, sheet = 1, cols = 2:4, rows = 5) - tmp_file <- tempfile(fileext = ".xlsx") + tmp_file <- temp_xlsx() saveWorkbook(wb = wb, file = tmp_file, overwrite = TRUE) expect_equal(names(read.xlsx(tmp_file, fillMergedCells = FALSE)), c("A", "B", "X3", "X4")) diff --git a/tests/testthat/test-load_read_file_read_equality.R b/tests/testthat/test-load_read_file_read_equality.R index f7145018..01636f8e 100644 --- a/tests/testthat/test-load_read_file_read_equality.R +++ b/tests/testthat/test-load_read_file_read_equality.R @@ -13,7 +13,7 @@ test_that("Reading from loaded workbook", { writeData(wb, sheet = 3, x = mtcars, colNames = FALSE, rowNames = TRUE, startRow = 2, startCol = 2, borders = "columns") writeData(wb, sheet = 4, x = mtcars, colNames = FALSE, rowNames = FALSE, startRow = 12, startCol = 1, borders = "surrounding") - tempFile <- file.path(tempdir(), "temp.xlsx") + tempFile <- temp_xlsx() saveWorkbook(wb, tempFile, overwrite = TRUE) wb <- loadWorkbook(tempFile) diff --git a/tests/testthat/test-loading_workbook.R b/tests/testthat/test-loading_workbook.R index fcd971d6..dd89a0b2 100644 --- a/tests/testthat/test-loading_workbook.R +++ b/tests/testthat/test-loading_workbook.R @@ -930,6 +930,6 @@ test_that("Load and saving a file with Threaded Comments works", { fl <- system.file("extdata", "loadThreadComment.xlsx", package = "openxlsx") wb <- loadWorkbook(fl) # Check that wb can be saved without error - expect_silent(saveWorkbook(wb, file = tempfile())) + expect_silent(saveWorkbook(wb, file = temp_xlsx())) }) diff --git a/tests/testthat/test-named_regions.R b/tests/testthat/test-named_regions.R index 4c474dfa..0766b4f8 100644 --- a/tests/testthat/test-named_regions.R +++ b/tests/testthat/test-named_regions.R @@ -1,13 +1,7 @@ - - context("Named Regions") - - test_that("Maintaining Named Regions on Load", { - - ## create named regions wb <- createWorkbook() addWorksheet(wb, "Sheet 1") @@ -23,39 +17,36 @@ test_that("Maintaining Named Regions on Load", { cols = seq_len(ncol(iris)) ) - ## using writeData 'name' argument writeData(wb, sheet = 1, x = iris, name = "iris2", startCol = 10) - ## Named region size 1 writeData(wb, sheet = 2, x = 99, name = "region1", startCol = 3, startRow = 3) ## save file for testing - out_file <- tempfile(fileext = ".xlsx") + out_file <- temp_xlsx() saveWorkbook(wb, out_file, overwrite = TRUE) - expect_equal(object = getNamedRegions(wb), expected = getNamedRegions(out_file)) df1 <- read.xlsx(wb, namedRegion = "iris") df2 <- read.xlsx(out_file, namedRegion = "iris") - expect_equal(object = df1, expected = df2) + expect_equal(df1, df2) df1 <- read.xlsx(wb, namedRegion = "region1") - expect_equal(object = class(df1), expected = "data.frame") - expect_equal(object = nrow(df1), expected = 0) - expect_equal(object = ncol(df1), expected = 1) + expect_s3_class(df1, "data.frame") + expect_equal(nrow(df1), 0) + expect_equal(ncol(df1), 1) df1 <- read.xlsx(wb, namedRegion = "region1", colNames = FALSE) - expect_equal(object = class(df1), expected = "data.frame") - expect_equal(object = nrow(df1), expected = 1) - expect_equal(object = ncol(df1), expected = 1) + expect_s3_class(df1, "data.frame") + expect_equal(nrow(df1), 1) + expect_equal(ncol(df1), 1) df1 <- read.xlsx(wb, namedRegion = "region1", rowNames = TRUE) - expect_equal(object = class(df1), expected = "data.frame") - expect_equal(object = nrow(df1), expected = 0) - expect_equal(object = ncol(df1), expected = 0) + expect_s3_class(df1, "data.frame") + expect_equal(nrow(df1), 0) + expect_equal(ncol(df1), 0) }) test_that("Correctly Loading Named Regions Created in Excel", { @@ -150,7 +141,7 @@ test_that("Load names from an Excel file with funky non-region names", { test_that("Missing rows in named regions", { - temp_file <- tempfile(fileext = ".xlsx") + temp_file <- temp_xlsx() wb <- createWorkbook() addWorksheet(wb, "Sheet 1") @@ -227,7 +218,7 @@ test_that("Missing rows in named regions", { test_that("Missing columns in named regions", { - temp_file <- tempfile(fileext = ".xlsx") + temp_file <- temp_xlsx() wb <- createWorkbook() addWorksheet(wb, "Sheet 1") @@ -305,7 +296,7 @@ test_that("Missing columns in named regions", { test_that("Matching Substrings breaks reading named regions", { - temp_file <- tempfile(fileext = ".xlsx") + temp_file <- temp_xlsx() wb <- createWorkbook() addWorksheet(wb, "table") diff --git a/tests/testthat/test-outlines.R b/tests/testthat/test-outlines.R index 0f929b12..1c8b0b68 100644 --- a/tests/testthat/test-outlines.R +++ b/tests/testthat/test-outlines.R @@ -81,8 +81,8 @@ test_that("loading workbook preserves outlines", { groupColumns(wbb, "Test", cols = 5:10, hidden = FALSE) setColWidths(wbb, "Test", cols = 15:20, widths = 9) - tf <- tempfile("test", fileext = ".xlsx") - tf2 <- tempfile("test2", fileext = ".xlsx") + tf <- temp_xlsx("test") + tf2 <- temp_xlsx("test2") saveWorkbook(wbb, tf, overwrite = T) test <- wbb$worksheets[[1]]$copy() @@ -127,8 +127,8 @@ test_that("Consecutive calls to saveWorkbook doesn't corrupt attributes", { groupColumns(wbb, "Test", cols = 5:10, hidden = FALSE) setColWidths(wbb, "Test", cols = 15:20, widths = 9) - tf <- tempfile("test", fileext = ".xlsx") - tf2 <- tempfile("test2", fileext = ".xlsx") + tf <- temp_xlsx("test") + tf2 <- temp_xlsx("test2") saveWorkbook(wbb, tf, overwrite = T) test <- wbb$worksheets[[1]]$copy() diff --git a/tests/testthat/test-read_from_created_wb.R b/tests/testthat/test-read_from_created_wb.R index b95a493b..009a72cd 100644 --- a/tests/testthat/test-read_from_created_wb.R +++ b/tests/testthat/test-read_from_created_wb.R @@ -1,11 +1,6 @@ - - - context("Reading from wb object is identical to reading from file") - - test_that("Reading from new workbook", { curr_wd <- getwd() @@ -43,22 +38,11 @@ test_that("Reading from new workbook", { rm(wb) }) - - - - - - - - - - test_that("Empty workbook", { curr_wd <- getwd() wb <- createWorkbook() addWorksheet(wb, "Sheet 1") - expect_equal(NULL, suppressWarnings(read.xlsx(wb))) expect_equal(NULL, suppressWarnings(read.xlsx(wb, sheet = 1, colNames = FALSE))) @@ -73,9 +57,6 @@ test_that("Empty workbook", { expect_equal(NULL, suppressWarnings(read.xlsx(wb, sheet = 1, colNames = FALSE, skipEmptyRows = TRUE, detectDates = TRUE, rows = 4:10))) expect_equal(NULL, suppressWarnings(read.xlsx(wb, sheet = 1, colNames = TRUE, skipEmptyRows = TRUE, detectDates = FALSE, cols = 4:10))) - - - expect_warning(read.xlsx(wb)) expect_warning(read.xlsx(wb, sheet = 1, colNames = FALSE)) @@ -91,10 +72,6 @@ test_that("Empty workbook", { expect_warning(read.xlsx(wb, sheet = 1, colNames = TRUE, skipEmptyRows = TRUE, detectDates = FALSE, cols = 4:10)) - - - - ## 1 element writeData(wb, 1, "a") @@ -171,18 +148,16 @@ test_that("Empty workbook", { }) - - test_that("Reading NAs and NaN values", { fileName <- file.path(tempdir(), "NaN.xlsx") na.string <- "*" ## data a <- data.frame( - "X" = c(-pi / 0, NA, NaN), - "Y" = letters[1:3], - "Z" = c(pi / 0, 99, NaN), - "Z2" = c(1, NaN, NaN), + X = c(-pi / 0, NA, NaN), + Y = letters[1:3], + Z = c(pi / 0, 99, NaN), + Z2 = c(1, NaN, NaN), stringsAsFactors = FALSE ) @@ -235,8 +210,6 @@ test_that("Reading NAs and NaN values", { expect_equal(read.xlsx(wb), expected_df) - - ## keepNA = FALSE expect_equal(read.xlsx(wb), read.xlsx(fileName)) expect_equal(b, read.xlsx(wb)) @@ -258,9 +231,6 @@ test_that("Reading NAs and NaN values", { }) - - - test_that("Reading from new workbook 2 ", { ## data @@ -310,7 +280,7 @@ test_that("Reading from new workbook cols/rows", { addWorksheet(wb, sprintf("Sheet %s", i)) } - tempFile <- file.path(tempdir(), "temp.xlsx") + tempFile <- temp_xlsx() ## 1 writeData(wb, sheet = 1, x = mtcars, colNames = TRUE, rowNames = FALSE) diff --git a/tests/testthat/test-remove_worksheets.R b/tests/testthat/test-remove_worksheets.R index 89d6e9a7..6d36a32a 100644 --- a/tests/testthat/test-remove_worksheets.R +++ b/tests/testthat/test-remove_worksheets.R @@ -2,13 +2,10 @@ - - - context("Removing worksheets.") test_that("Deleting worksheets", { - tempFile <- file.path(tempdir(), "temp.xlsx") + tempFile <- temp_xlsx() genWS <- function(wb, sheetName) { addWorksheet(wb, sheetName) writeDataTable(wb, sheetName, data.frame("X" = sprintf("This is sheet: %s", sheetName)), colNames = FALSE) diff --git a/tests/testthat/test-saveWorkbook.R b/tests/testthat/test-saveWorkbook.R index dbb5a69c..fc0cb2f0 100644 --- a/tests/testthat/test-saveWorkbook.R +++ b/tests/testthat/test-saveWorkbook.R @@ -4,7 +4,7 @@ context("save workbook") test_that("test return values for saveWorkbook", { - tempFile <- file.path(tempdir(), "temp.xlsx") + tempFile <- temp_xlsx() wb<-createWorkbook() addWorksheet(wb,"name") expect_true( saveWorkbook(wb,tempFile,returnValue = TRUE)) diff --git a/tests/testthat/test-skip_empty_cols.R b/tests/testthat/test-skip_empty_cols.R index 332915b5..0611b812 100644 --- a/tests/testthat/test-skip_empty_cols.R +++ b/tests/testthat/test-skip_empty_cols.R @@ -1,13 +1,8 @@ - - - context("Skip Empty Cols") - - test_that("skip empty rows", { - xlsxfile <- tempfile() + xlsxfile <- temp_xlsx() df <- data.frame("x" = c(1, NA, NA, 2), "y" = c(1, NA, NA, 3)) write.xlsx(df, xlsxfile) @@ -20,15 +15,11 @@ test_that("skip empty rows", { expect_equal(df, df1) expect_equal(df, df2) - v <- c("A1", "B1", "A2", "B2", "A5", "B5") expect_equal(calc_number_rows(x = v, skipEmptyRows = TRUE), 3) expect_equal(calc_number_rows(x = v, skipEmptyRows = FALSE), 5) - - ## DONT SKIP - df1 <- readWorkbook(xlsxfile, skipEmptyRows = TRUE) df2 <- readWorkbook(wb, skipEmptyRows = TRUE) @@ -39,16 +30,9 @@ test_that("skip empty rows", { expect_equivalent(df[c(1, 4), ], df2) }) - - - - - - test_that("Version 4 fixes from File", { fl <- system.file("extdata", "readTest.xlsx", package = "openxlsx") - x <- read.xlsx(xlsxFile = fl, sheet = 4, skipEmptyCols = TRUE, skipEmptyRows = TRUE, colNames = FALSE) expect_equal(nrow(x), 5L) expect_equal(ncol(x), 4L) diff --git a/tests/testthat/test-skip_empty_rows.R b/tests/testthat/test-skip_empty_rows.R index 96de29bf..1321f7cf 100644 --- a/tests/testthat/test-skip_empty_rows.R +++ b/tests/testthat/test-skip_empty_rows.R @@ -1,13 +1,8 @@ - - - context("Skip Empty Rows") - - test_that("skip empty rows", { - xlsxfile <- tempfile() + xlsxfile <- temp_xlsx() df <- data.frame("x" = c(1, NA, NA, 2), "y" = c(1, NA, NA, 3)) write.xlsx(df, xlsxfile) @@ -25,10 +20,7 @@ test_that("skip empty rows", { expect_equal(calc_number_rows(x = v, skipEmptyRows = TRUE), 3) expect_equal(calc_number_rows(x = v, skipEmptyRows = FALSE), 5) - - ## DONT SKIP - df1 <- readWorkbook(xlsxfile, skipEmptyRows = TRUE) df2 <- readWorkbook(wb, skipEmptyRows = TRUE) @@ -39,13 +31,8 @@ test_that("skip empty rows", { expect_equivalent(df[c(1, 4), ], df2) }) - - - - - test_that("skip empty cols", { - xlsxfile <- tempfile() + xlsxfile <- temp_xlsx() x <- data.frame("a" = c(1, NA, NA, 2), "b" = c(1, NA, NA, 3)) y <- data.frame("x" = c(1, NA, NA, 2), "y" = c(1, NA, NA, 3)) diff --git a/tests/testthat/test-trying_to_break_openxlsx.R b/tests/testthat/test-trying_to_break_openxlsx.R index 26c6efdb..23269451 100644 --- a/tests/testthat/test-trying_to_break_openxlsx.R +++ b/tests/testthat/test-trying_to_break_openxlsx.R @@ -7,7 +7,7 @@ context("Images and Tables.") test_that("Images and Tables - reordering and removing", { if (FALSE) { options("stringsAsFactors" = FALSE) - tempFile <- file.path(tempdir(), "break.xlsx") + tempFile <- temp_xlsx("break") getPlot <- function(i) { n <- 5000 @@ -199,7 +199,7 @@ test_that("Images and Tables - reordering and removing", { }) test_that("setColWidths() should support zero-length cols", { - file <- tempfile(fileext = ".xlsx") + file <- temp_xlsx() on.exit(unlink(file), add = TRUE) wb <- createWorkbook() ws <- addWorksheet(wb, "empty") diff --git a/tests/testthat/test-worksheet_ordering.R b/tests/testthat/test-worksheet_ordering.R index 575c60ea..3c8ffdd4 100644 --- a/tests/testthat/test-worksheet_ordering.R +++ b/tests/testthat/test-worksheet_ordering.R @@ -21,7 +21,7 @@ test_that("Worksheet ordering from new Workbook", { genWS(wb, "Sheet 3") - tempFile <- file.path(tempdir(), "orderingTest.xlsx") + tempFile <- temp_xlsx("orderingTest") ## no ordering saveWorkbook(wb, file = tempFile, overwrite = TRUE) @@ -244,7 +244,7 @@ test_that("Worksheet ordering from new Workbook", { test_that("Worksheet ordering from new Workbook", { - tempFile <- file.path(tempdir(), "temp.xlsx") + tempFile <- temp_xlsx() wb <- createWorkbook() addWorksheet(wb = wb, sheetName = "Sheet 1", gridLines = FALSE) diff --git a/tests/testthat/test-write_data_to_sheetData.R b/tests/testthat/test-write_data_to_sheetData.R index 930b92c6..8c17933a 100644 --- a/tests/testthat/test-write_data_to_sheetData.R +++ b/tests/testthat/test-write_data_to_sheetData.R @@ -187,7 +187,7 @@ test_that("Converting R types to Excel types", { test_that("Write zero rows & columns", { - tempFile <- file.path(tempdir(), "temp.xlsx") + tempFile <- temp_xlsx() wb <- createWorkbook() addWorksheet(wb, "s1") addWorksheet(wb, "s2") diff --git a/tests/testthat/test-write_read_equality.R b/tests/testthat/test-write_read_equality.R index 079554dd..136c4cc9 100644 --- a/tests/testthat/test-write_read_equality.R +++ b/tests/testthat/test-write_read_equality.R @@ -41,9 +41,6 @@ test_that("Writing then reading returns identical data.frame 1", { expect_equal(object = getwd(), curr_wd) }) - - - test_that("Writing then reading returns identical data.frame 2", { curr_wd <- getwd() @@ -112,65 +109,79 @@ test_that("Writing then reading returns identical data.frame 2", { unlink(fileName, recursive = TRUE, force = TRUE) }) - - - - - - test_that("Writing then reading rowNames, colNames combinations", { - fileName <- file.path(tempdir(), "tmp.xlsx") + op <- options() + options(stringsAsFactors = FALSE) + on.exit(options(op), add = TRUE) + + + fileName <- temp_xlsx() curr_wd <- getwd() - - ## rowNames = colNames = TRUE - write.xlsx(mtcars, file = fileName, overwrite = TRUE, row.names = TRUE) + mt <- utils::head(mtcars) # don't need the whole thing + + # write the row and column names for testing + write.xlsx(mt, file = fileName, overwrite = TRUE, rowNames = TRUE, colNames = TRUE) + + # rowNames = colNames = TRUE + # Row names = first column + # Col names = first row x <- read.xlsx(fileName, sheet = 1, rowNames = TRUE) - expect_equal(object = x, expected = mtcars, check.attributes = TRUE) + expect_equal(x, mt) - ## rowNames = TRUE, colNames = FALSE - write.xlsx(mtcars, file = fileName, overwrite = TRUE, rowNames = TRUE, colNames = FALSE) + # rowNames = TRUE, colNames = FALSE + # Row names = first column + # Col names = X1, X2, etc + + # need to create an expected output + y <- as.data.frame(rbind(colnames(mt), as.matrix(mt))) + colnames(y) <- c(make.names(seq_along(mt))) x <- read.xlsx(fileName, sheet = 1, rowNames = TRUE, colNames = FALSE) - expect_equal(object = x, expected = mtcars, check.attributes = FALSE) - expect_equal(object = rownames(x), expected = rownames(mtcars)) + expect_equal(x, y) - ## rowNames = FALSE, colNames = TRUE - write.xlsx(mtcars, file = fileName, overwrite = TRUE, rowNames = FALSE, colNames = TRUE) + # rowNames = FALSE, colNames = TRUE + # Row names = "" + # Cl names = first row + y2 <- cbind(row.names(mt), mt) + colnames(y2)[1] <- "" + row.names(y2) <- NULL x <- read.xlsx(fileName, sheet = 1, rowNames = FALSE, colNames = TRUE) - expect_equal(object = x, expected = mtcars, check.attributes = FALSE) - - ## rowNames = FALSE, colNames = FALSE - write.xlsx(mtcars, file = fileName, overwrite = TRUE, rowNames = FALSE, colNames = FALSE) + expect_equal(x, y2) + + # rowNames = FALSE, colNames = FALSE + # Row names = "" + # Col names = X1, X2, etc + y3 <- cbind(row.names(y), y) + colnames(y3) <- make.names(seq_along(y3)) + row.names(y3) <- NULL x <- read.xlsx(fileName, sheet = 1, rowNames = FALSE, colNames = FALSE) - expect_equal(object = x, expected = mtcars, check.attributes = FALSE) + expect_equal(x, y3) - expect_equal(object = getwd(), curr_wd) + + # Check wd + expect_equal(getwd(), curr_wd) + unlink(fileName, recursive = TRUE, force = TRUE) }) - - - - - test_that("Writing then reading returns identical data.frame 3", { + op <- options() + options(openxlsx.dateFormat = "yyyy-mm-dd") + on.exit(options(op), add = TRUE) ## data - genDf <- function() { - data.frame( - "Date" = Sys.Date() - 0:4, - "Logical" = c(TRUE, FALSE, TRUE, TRUE, FALSE), - "Currency" = -2:2, - "Accounting" = -2:2, - "hLink" = "https://CRAN.R-project.org/", - "Percentage" = seq(-1, 1, length.out = 5), - "TinyNumber" = runif(5) / 1E9, stringsAsFactors = FALSE - ) - } - - df <- genDf() + df <- data.frame( + Date = as.Date("2021-05-21") - 0:4, + Logical = c(TRUE, FALSE, TRUE, TRUE, FALSE), + Currency = -2:2, + Accounting = -2:2, + hLink = "https://CRAN.R-project.org/", + Percentage = seq.int(-1, 1, length.out = 5), + TinyNumber = runif(5) / 1E9, + stringsAsFactors = FALSE + ) class(df$Currency) <- "currency" class(df$Accounting) <- "accounting" @@ -178,44 +189,38 @@ test_that("Writing then reading returns identical data.frame 3", { class(df$Percentage) <- "percentage" class(df$TinyNumber) <- "scientific" - options("openxlsx.dateFormat" = "yyyy-mm-dd") - - fileName <- file.path(tempdir(), "allClasses.xlsx") + fileName <- tempfile("allClasses", fileext = ".xlsx") write.xlsx(df, file = fileName, overwrite = TRUE) - ## rows, cols combinations rows <- 1:4 cols <- c(1, 3, 5) - x <- read.xlsx(xlsxFile = fileName, detectDates = TRUE, rows = rows, cols = cols) - expect_equal(object = x, expected = genDf()[sort((rows - 1)[(rows - 1) <= nrow(df)]), sort(cols[cols <= ncol(df)])], check.attributes = FALSE) - + x <- read.xlsx(fileName, detectDates = TRUE, rows = rows, cols = cols) + exp <- df[sort((rows - 1)[(rows - 1) <= nrow(df)]), sort(cols[cols <= ncol(df)])] + expect_equal(x, exp) rows <- 1:4 cols <- 1:9 x <- read.xlsx(xlsxFile = fileName, detectDates = TRUE, rows = rows, cols = cols) - expect_equal(object = x, expected = genDf()[sort((rows - 1)[(rows - 1) <= nrow(df)]), sort(cols[cols <= ncol(df)])], check.attributes = FALSE) - + exp <- df[sort((rows - 1)[(rows - 1) <= nrow(df)]), sort(cols[cols <= ncol(df)])] + expect_equal(x, exp) rows <- 1:200 cols <- c(5, 99, 2) x <- read.xlsx(xlsxFile = fileName, detectDates = TRUE, rows = rows, cols = cols) - expect_equal(object = x, expected = genDf()[sort((rows - 1)[(rows - 1) <= nrow(df)]), sort(cols[cols <= ncol(df)])], check.attributes = FALSE) + exp <- df[sort((rows - 1)[(rows - 1) <= nrow(df)]), sort(cols[cols <= ncol(df)])] + expect_equal(x, exp) rows <- 1000:900 cols <- c(5, 99, 2) suppressWarnings(x <- read.xlsx(xlsxFile = fileName, detectDates = TRUE, rows = rows, cols = cols)) - expect_equal(object = x, expected = NULL, check.attributes = FALSE) + expect_identical(x, NULL) unlink(fileName, recursive = TRUE, force = TRUE) }) - - - - test_that("Writing then reading returns identical data.frame 4", { ## data @@ -225,7 +230,7 @@ test_that("Writing then reading returns identical data.frame 4", { df[6, 4] <- NA - tf <- tempfile(fileext = ".xlsx") + tf <- temp_xlsx() write.xlsx(x = df, file = tf, keepNA = TRUE) x <- read.xlsx(tf) @@ -233,7 +238,7 @@ test_that("Writing then reading returns identical data.frame 4", { unlink(tf, recursive = TRUE, force = TRUE) - tf <- tempfile(fileext = ".xlsx") + tf <- temp_xlsx() write.xlsx(x = df, file = tf, keepNA = FALSE) x <- read.xlsx(tf) @@ -256,7 +261,7 @@ test_that("Writing then reading returns identical data.frame 5", { df_expected[6, 4] <- na.string - tf <- tempfile(fileext = ".xlsx") + tf <- temp_xlsx() write.xlsx(x = df, file = tf, keepNA = TRUE, na.string = na.string) x <- read.xlsx(tf) @@ -266,9 +271,8 @@ test_that("Writing then reading returns identical data.frame 5", { - test_that("Special characters in sheet names", { - tf <- tempfile(fileext = ".xlsx") + tf <- temp_xlsx() ## data sheet_name <- "A & B < D > D" diff --git a/tests/testthat/test-write_xlsx_vector_args.R b/tests/testthat/test-write_xlsx_vector_args.R index dbd49ba3..d91b542c 100644 --- a/tests/testthat/test-write_xlsx_vector_args.R +++ b/tests/testthat/test-write_xlsx_vector_args.R @@ -3,11 +3,11 @@ context("write.xlsx vector arguments") test_that("Writing then reading returns identical data.frame 1", { tmp_file <- file.path(tempdir(), "xlsx_vector_args.xlsx") - + df1 <- data.frame(1:2) df2 <- data.frame(1:3) x <- list(df1, df2) - + write.xlsx( file = tmp_file, x = x, @@ -16,50 +16,34 @@ test_that("Writing then reading returns identical data.frame 1", { zoom = c(50, 90), tabColour = c("red", "blue") ) - + wb <- loadWorkbook(tmp_file) - - expect_equal(object = getSheetNames(tmp_file), expected = c("a", "b")) - expect_equal(object = names(wb), expected = c("a", "b")) - - expect_true(object = grepl('rgb="FFFF0000"', wb$worksheets[[1]]$sheetPr)) - expect_true(object = grepl('rgb="FF0000FF"', wb$worksheets[[2]]$sheetPr)) - - expect_true(object = grepl('zoomScale="50"', wb$worksheets[[1]]$sheetViews)) - expect_true(object = grepl('zoomScale="90"', wb$worksheets[[2]]$sheetViews)) - - expect_true(object = grepl('showGridLines="0"', wb$worksheets[[1]]$sheetViews)) - expect_true(object = grepl('showGridLines="1"', wb$worksheets[[2]]$sheetViews)) - + + expect_equal(getSheetNames(tmp_file), expected = c("a", "b")) + expect_equal(names(wb), expected = c("a", "b")) + + expect_true(grepl('rgb="FFFF0000"', wb$worksheets[[1]]$sheetPr)) + expect_true(grepl('rgb="FF0000FF"', wb$worksheets[[2]]$sheetPr)) + + expect_true(grepl('zoomScale="50"', wb$worksheets[[1]]$sheetViews)) + expect_true(grepl('zoomScale="90"', wb$worksheets[[2]]$sheetViews)) + + expect_true(grepl('showGridLines="0"', wb$worksheets[[1]]$sheetViews)) + expect_true(grepl('showGridLines="1"', wb$worksheets[[2]]$sheetViews)) + expect_equal(read.xlsx(tmp_file, sheet = 1), df1) expect_equal(read.xlsx(tmp_file, sheet = 2), df2) - + unlink(tmp_file, recursive = TRUE, force = TRUE) }) test_that("write.xlsx() passes withFilter and colWidths [151]", { df <- data.frame(x = 1, b = 2) - tf1 <- tempfile("file_1_", fileext = ".xlsx") - tf2 <- tempfile("file_2_", fileext = ".xlsx") - on.exit(file.remove(tf1, tf2), add = TRUE) - - # undebug(write.xlsx) - # withFilter default should be FALSE when asTable is FALSE - write.xlsx(df, tf1) - write.xlsx(df, tf2, withFilter = TRUE, colWidths = 15) - - x <- loadWorkbook(tf1) - y <- loadWorkbook(tf2) - - expect_equal( - x$worksheets[[1]]$autoFilter, - character() - ) - expect_equal( - y$worksheets[[1]]$autoFilter, - "" - ) + x <- buildWorkbook(df) + y <- buildWorkbook(df, withFilter = TRUE, colWidths = 15) + expect_equal(x$worksheets[[1]]$autoFilter, character()) + expect_equal(y$worksheets[[1]]$autoFilter, "") expect_equal(x$colWidths, list(list())) expect_equal( @@ -70,57 +54,53 @@ test_that("write.xlsx() passes withFilter and colWidths [151]", { test_that("write.xlsx() correctly passes default asTable and withFilters", { df <- data.frame(x = 1, b = 2) - tf1 <- tempfile(fileext = ".xlsx") - tf2 <- tempfile(fileext = ".xlsx") - on.exit(file.remove(tf1, tf2), add = TRUE) # asTable = TRUE >> writeDataTable >> withFilter = TRUE # asTable = FALSE >> writeData >> withFilter = FALSE - write.xlsx(df, tf1, asTable = FALSE) - write.xlsx(df, tf2, asTable = TRUE) + x <- buildWorkbook(df, asTable = FALSE) + y <- buildWorkbook(df, asTable = TRUE) - x <- loadWorkbook(tf1) - y <- loadWorkbook(tf2) + # Save the workbook + tf <- temp_xlsx() + saveWorkbook(y, tf) + y2 <- loadWorkbook(tf) + expect_identical(x$worksheets[[1]]$autoFilter, character()) + + # not autoFilter for tables -- not named in buildWorkbook expect_equal( - x$worksheets[[1]]$autoFilter, - character() + y$worksheets[[1]]$tableParts, + structure("", tableName = "Table3") ) - # not autoFilter for tables expect_equal( - y$worksheets[[1]]$tableParts, + y2$worksheets[[1]]$tableParts, structure("", tableName = c(`A1:B2` = "Table3")) ) + + file.remove(tf) }) test_that("write.xlsx() correctly handles colWidths", { x <- data.frame(a = 1, b = 2, c = 3) - file <- tempfile("write_xlsx_", fileext = ".xlsx") - on.exit(if (file.exists(file)) file.remove(file), add = TRUE) zero3 <- rep("0", 3) # No warning when passing "auto" - expect_warning(write.xlsx(rep_len(list(x), 3), file, colWidths = "auto"), NA) + expect_warning(buildWorkbook(rep_len(list(x), 3), colWidths = "auto"), NA) # single value is repeated for all columns - write.xlsx(rep_len(list(x), 3), file, colWidths = 13) - - expect_equal( - loadWorkbook(file)$colWidths, - rep_len(list(structure(c(`1` = "13", `2` = "13", `3` = "13"), hidden = zero3)), 3) - ) - - # sets are repated - write.xlsx(rep_len(list(x), 3), file, colWidths = list(c(10, 20, 30))) + wb <- buildWorkbook(rep_len(list(x), 3), colWidths = 13) + exp <- rep_len(list(structure(c(`1` = "13", `2` = "13", `3` = "13"), hidden = zero3)), 3) + expect_equal(wb$colWidths, exp) - expect_equal( - loadWorkbook(file)$colWidths, - rep_len(list(structure(c(`1` = "10", `2` = "20", `3` = "30"), hidden = zero3)), 3) - ) + # sets are repeated + wb <- buildWorkbook(rep_len(list(x), 3), colWidths = list(c(10, 20, 30))) + exp <- rep_len(list(structure(c(`1` = "10", `2` = "20", `3` = "30"), hidden = zero3)), 3) + expect_equal(wb$colWidths, exp) # 3 distinct sets - write.xlsx(rep_len(list(x), 3), file, + wb <- buildWorkbook( + rep_len(list(x), 3), colWidths = list( c(10, 20, 30), c(100, 200, 300), @@ -128,7 +108,7 @@ test_that("write.xlsx() correctly handles colWidths", { )) expect_equal( - loadWorkbook(file)$colWidths, + wb$colWidths, list( structure(c(`1` = "10", `2` = "20", `3` = "30"), hidden = zero3), structure(c(`1` = "100", `2` = "200", `3` = "300"), hidden = zero3), diff --git a/tests/testthat/test-writing_sheet_data.R b/tests/testthat/test-writing_sheet_data.R index 81976e60..f45f6110 100644 --- a/tests/testthat/test-writing_sheet_data.R +++ b/tests/testthat/test-writing_sheet_data.R @@ -1,13 +1,9 @@ - - - - context("Writing Sheet Data XML") test_that("Writing sheetData rows XML - iris", { - temp_file <- tempfile(fileext = ".xlsx") + temp_file <- temp_xlsx() openxlsx::write.xlsx(iris, temp_file) unzip(temp_file, exdir = tempdir()) @@ -177,14 +173,9 @@ test_that("Writing sheetData rows XML - iris", { }) - - - - - test_that("Writing sheetData rows XML - mtcars", { - temp_file <- tempfile(fileext = ".xlsx") - openxlsx::write.xlsx(mtcars, temp_file, row.names = TRUE) + temp_file <- temp_xlsx() + openxlsx::write.xlsx(mtcars, temp_file, rowNames = TRUE) unzip(temp_file, exdir = tempdir()) x <- readUTF8(file.path(tempdir(), "xl", "worksheets", "sheet1.xml"))