', clientData, ""
)
}
genClientData <- function(col, row, visible, height, width) {
txt <- sprintf(
'
%s, 15, %s, 10, %s, 147, %s, 18False%s%s',
col, row - 2L, col + width - 1L, row + height - 1L, row - 1L, col - 1L
)
if (visible) {
txt <- paste0(txt, "")
}
txt <- paste0(txt, "")
return(txt)
}
# genBaseRels <- function(){
#
# '
#
#
'
#
# }
#
#
# genBaseApp <- function(){
# list('
Microsoft Excel')
# }
genBaseCore <- function(creator = "", title = NULL, subject = NULL, category = NULL) {
core <- '
'
core <- stri_c(core, sprintf("%s", replaceIllegalCharacters(creator)))
core <- stri_c(core, sprintf("%s", replaceIllegalCharacters(creator)))
core <- stri_c(core, sprintf('%s', format(as_POSIXct_utc(Sys.time()), "%Y-%m-%dT%H:%M:%SZ")))
if (!is.null(title)) {
core <- stri_c(core, sprintf("%s", replaceIllegalCharacters(title)))
}
if (!is.null(subject)) {
core <- stri_c(core, sprintf("%s", replaceIllegalCharacters(subject)))
}
if (!is.null(category)) {
core <- stri_c(core, sprintf("%s", replaceIllegalCharacters(category)))
}
core <- stri_c(core, "")
return(core)
}
#
# addAuthor <- function(wb,Author = NULL){
#
# if (!is.null(Author)) {
# current_creator <-
# stri_match(wb$core, regex = "
(.*?)")[1, 2]
# wb$core <-
# stri_replace_all_fixed(
# wb$core,
# pattern = current_creator,
# replacement = stri_c(current_creator, Author, sep = ";")
# )
# }
#
#
# }
#
#
# setAuthor <- function(wb,Author = NULL){
#
# if (!is.null(Author)) {
# current_creator <-
# stri_match(wb$core, regex = "
(.*?)")[1, 2]
# wb$core <-
# stri_replace_all_fixed(
# wb$core,
# pattern = current_creator,
# replacement = Author
# )
# }
#
#
# }
#
# setLastModifiedBy <- function(wb,ModifiedBy=NULL){
#
# if (!is.null(addmodifier)) {
# current_lastmodifier <-
# stri_match(wb$core, regex = "
(.*?)")[1, 2]
# wb$core <-
# stri_replace_all_fixed(
# wb$core,
# pattern = current_lastmodifier,
# replacement = ModifiedBy
# )
# }
#
#
# }
#
#
#
#
# setBaseCore <- function(core,setcreator="",setmodifier="",
# title = NULL, subject = NULL, category = NULL){
#
#
# core <- c(core, sprintf('
%s', setcreator))
# core <- c(core, sprintf('
%s', format(Sys.time(), "%Y-%m-%dT%H:%M:%SZ")))
#
# if(!is.null(title))
# core <- c(core, sprintf('
%s', replaceIllegalCharacters(title)))
#
# if(!is.null(subject))
# core <- c(core, sprintf('
%s', replaceIllegalCharacters(subject)))
#
# if(!is.null(category))
# core <- c(core, sprintf('
%s', replaceIllegalCharacters(category)))
#
# core <- c(core, '')
#
# return(core)
#
# }
genBaseWorkbook.xml.rels <- function() {
c(
'
',
'
',
'
'
)
}
genBaseWorkbook <- function() {
list(
workbookPr = '
',
workbookProtection = NULL,
bookViews = '
',
sheets = NULL,
externalReferences = NULL,
definedNames = NULL,
calcPr = NULL,
pivotCaches = NULL,
extLst = NULL
)
}
genBaseSheetRels <- function(sheetInd) {
c(
sprintf('
', sheetInd),
sprintf('
', sheetInd),
sprintf('
', sheetInd)
)
}
genBaseStyleSheet <- function(dxfs = NULL, tableStyles = NULL, extLst = NULL) {
list(
numFmts = NULL,
fonts = c('
'),
fills = c(
'
',
'
'
),
borders = c("
"),
cellStyleXfs = c('
'),
cellXfs = c('
'),
cellStyles = c('
'),
dxfs = dxfs,
tableStyles = tableStyles,
indexedColors = NULL,
extLst = extLst
)
}
genBasePic <- function(imageNo, imageRelNo, hyperlinkXML) {
sprintf('
', imageNo, imageNo, hyperlinkXML, imageRelNo)
}
genBaseTheme <- function() {
'
'
}
genPrinterSettings <- function() {
"5c 00 5c 00 41 00 55 00 43 00 41 00 4c 00 50 00 52 00 4f 00 44 00 46 00 50 00 5c 00 4c 00 31 00 34 00 78 00 65 00 72 00 6f 00 78 00 31 00 20 00 2d 00 20 00 58 00 65 00 72 00 6f 00 00 00 00 00 01 04 00 52 dc 00 5c 05 13 ff 81 07 02 00 09 00 9a 0b 34 08 64 00 01 00 0f 00 2c 01 02 00 02 00 2c 01 03 00 01 00 41 00 34 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01 00 00 00 01 00 00 00 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 52 c0 21 46 00 58 00 20 00 41 00 70 00 65 00 6f 00 73 00 50 00 6f 00 72 00 74 00 2d 00 49 00 49 00 49 00 20 00 43 00 34 00 34 00 30 00 30 00 20 00 50 00 43 00 4c 00 20 00 36 00 00 00 00 00 00 00 00 00 4e 08 a0 13 40 09 08 00 0b 01 64 00 01 00 07 00 01 00 00 00 00 00 00 00 00 00 07 00 01 00 08 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 08 08 08 00 08 08 08 00 08 08 08 00 08 08 08 00 00 01 03 00 02 02 00 01 02 02 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01 00 00 00 00 00 00 00 02 02 48 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 bc 02 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 05 00 00 00 00 00 00 08 00 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01 00 00 00 00 00 00 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 0b 96 00 00 00 c8 00 01 01 01 01 01 01 01 01 01 01 01 01 09 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 bc 02 00 00 00 00 00 00 00 00 02 00 41 00 72 00 69 00 61 00 6c 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01 00 01 00 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 12 70 5f 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00"
}
gen_databar_extlst <- function(guid, sqref, posColour, negColour, values, border, gradient) {
xml <- sprintf('
', guid, border, gradient)
if (is.null(values)) {
xml <- sprintf('
%s
%s', xml, posColour, negColour, negColour, sqref)
} else {
xml <- sprintf('
%s
%s%s
%s', xml, values[[1]], values[[2]], posColour, negColour, negColour, sqref)
}
return(xml)
}
contentTypePivotXML <- function(i) {
c(
sprintf('
', i),
sprintf('
', i),
sprintf('
', i)
)
}
contentTypeSlicerCacheXML <- function(i) {
c(
sprintf('
', i),
sprintf('
', i)
)
}
genBaseSlicerXML <- function() {
'
'
}
genSlicerCachesExtLst <- function(i) {
paste0(
'
',
paste(sprintf('', i), collapse = ""),
""
)
}
openxlsx/R/zzz.R 0000644 0001762 0000144 00000000247 14374150317 013323 0 ustar ligges users .onAttach <- function(libname, pkgname) {
op <- options()
toset <- !(names(op.openxlsx) %in% names(op))
if (any(toset)) {
options(op.openxlsx[toset])
}
}
openxlsx/R/onUnload.R 0000644 0001762 0000144 00000000117 14374150317 014241 0 ustar ligges users .onUnload <- function(libpath) {
library.dynam.unload("openxlsx", libpath)
}
openxlsx/R/helperFunctions.R 0000644 0001762 0000144 00000076256 14745234534 015661 0 ustar ligges users #' @name makeHyperlinkString
#' @title create Excel hyperlink string
#' @description Wrapper to create internal hyperlink string to pass to writeFormula(). Either link to external urls or local files or straight to cells of local Excel sheets.
#' @param sheet Name of a worksheet
#' @param row integer row number for hyperlink to link to
#' @param col column number of letter for hyperlink to link to
#' @param text display text
#' @param file Excel file name to point to. If NULL hyperlink is internal.
#' @seealso [writeFormula()]
#' @export makeHyperlinkString
#' @examples
#'
#' ## Writing internal hyperlinks
#' wb <- createWorkbook()
#' addWorksheet(wb, "Sheet1")
#' addWorksheet(wb, "Sheet2")
#' addWorksheet(wb, "Sheet 3")
#' writeData(wb, sheet = 3, x = iris)
#'
#' ## External Hyperlink
#' x <- c("https://www.google.com", "https://www.google.com.au")
#' names(x) <- c("google", "google Aus")
#' class(x) <- "hyperlink"
#'
#' writeData(wb, sheet = 1, x = x, startCol = 10)
#'
#'
#' ## Internal Hyperlink - create hyperlink formula manually
#' writeFormula(
#' wb, "Sheet1",
#' x = '=HYPERLINK(\"#Sheet2!B3\", "Text to Display - Link to Sheet2")',
#' startCol = 3
#' )
#'
#' ## Internal - No text to display using makeHyperlinkString() function
#' writeFormula(
#' wb, "Sheet1",
#' startRow = 1,
#' x = makeHyperlinkString(sheet = "Sheet 3", row = 1, col = 2)
#' )
#'
#' ## Internal - Text to display
#' writeFormula(
#' wb, "Sheet1",
#' startRow = 2,
#' x = makeHyperlinkString(
#' sheet = "Sheet 3", row = 1, col = 2,
#' text = "Link to Sheet 3"
#' )
#' )
#'
#' ## Link to file - No text to display
#' writeFormula(
#' wb, "Sheet1",
#' startRow = 4,
#' x = makeHyperlinkString(
#' sheet = "testing", row = 3, col = 10,
#' file = system.file("extdata", "loadExample.xlsx", package = "openxlsx")
#' )
#' )
#'
#' ## Link to file - Text to display
#' writeFormula(
#' wb, "Sheet1",
#' startRow = 3,
#' x = makeHyperlinkString(
#' sheet = "testing", row = 3, col = 10,
#' file = system.file("extdata", "loadExample.xlsx", package = "openxlsx"),
#' text = "Link to File."
#' )
#' )
#'
#' ## Link to external file - Text to display
#' writeFormula(
#' wb, "Sheet1",
#' startRow = 10, startCol = 1,
#' x = '=HYPERLINK("[C:/Users]", "Link to an external file")'
#' )
#'
#' ## Link to internal file
#' x = makeHyperlinkString(text = "test.png", file = "D:/somepath/somepicture.png")
#' writeFormula(wb, "Sheet1", startRow = 11, startCol = 1, x = x)
#'
#' \dontrun{
#' saveWorkbook(wb, "internalHyperlinks.xlsx", overwrite = TRUE)
#' }
#'
makeHyperlinkString <- function(sheet, row = 1, col = 1, text = NULL, file = NULL) {
op <- get_set_options()
on.exit(options(op), add = TRUE)
if (missing(sheet)) {
if (!missing(row) || !missing(col)) warning("Option for col and/or row found, but no sheet was provided.")
if (is.null(text))
str <- sprintf("=HYPERLINK(\"%s\")", file)
if (is.null(file))
str <- sprintf("=HYPERLINK(\"%s\")", text)
if (!is.null(text) && !is.null(file))
str <- sprintf("=HYPERLINK(\"%s\", \"%s\")", file, text)
} else {
cell <- paste0(int2col(col), row)
if (!is.null(file)) {
dest <- sprintf('"[%s]%s!%s"', file, sheet, cell)
} else {
dest <- sprintf('"#\'%s\'!%s"', sheet, cell)
}
if (is.null(text)) {
str <- sprintf('=HYPERLINK(%s)', dest)
} else {
str <- sprintf('=HYPERLINK(%s, \"%s\")', dest, text)
}
}
return(str)
}
getRId <- function(x) {
regmatches(x, gregexpr('(?<= r:id=")[0-9A-Za-z]+', x, perl = TRUE))
}
getId <- function(x) {
regmatches(x, gregexpr('(?<= Id=")[0-9A-Za-z]+', x, perl = TRUE))
}
## creates style object based on column classes
## Used in writeData for styling when no borders and writeData table for all column-class based styling
classStyles <- function(wb, sheet, startRow, startCol, colNames, nRow, colClasses, stack = TRUE) {
sheet <- wb$validateSheet(sheet)
allColClasses <- unlist(colClasses, use.names = FALSE)
rowInds <- (1 + startRow + colNames - 1L):(nRow + startRow + colNames - 1L)
startCol <- startCol - 1L
newStylesElements <- NULL
names(colClasses) <- NULL
# For custom number formats, ensure unique IDs (extract the current maximum and add 1 for each new format)
maxnumFmtId <- max(unlist(sapply(wb$styleObjects, function(i) {
as.integer(
max(c(i$style$numFmt$numFmtId, 0))
)
})), 165)
if ("hyperlink" %in% allColClasses) {
## style hyperlinks
inds <- which(sapply(colClasses, function(x) "hyperlink" %in% x))
hyperlinkstyle <- createStyle(textDecoration = "underline")
hyperlinkstyle$fontColour <- list("theme" = "10")
styleElements <- list(
"style" = hyperlinkstyle,
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
if ("date" %in% allColClasses) {
## style dates
inds <- which(sapply(colClasses, function(x) "date" %in% x))
# make sure the style has a unique ID:
style = createStyle(numFmt = "date")
if (style$numFmt$numFmtId == 165) {
style$numFmt$numFmtId <- maxnumFmtId + 1
maxnumFmtId <- style$numFmt$numFmtId
}
styleElements <- list(
"style" = style,
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
if (any(c("posixlt", "posixct", "posixt") %in% allColClasses)) {
## style POSIX
inds <- which(sapply(colClasses, function(x) any(c("posixct", "posixt", "posixlt") %in% x)))
# make sure the style has a unique ID:
style = createStyle(numFmt = "LONGDATE")
if (style$numFmt$numFmtId == 165) {
style$numFmt$numFmtId <- maxnumFmtId + 1
maxnumFmtId <- style$numFmt$numFmtId
}
styleElements <- list(
"style" = style,
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
## style currency as CURRENCY
if ("currency" %in% allColClasses) {
inds <- which(sapply(colClasses, function(x) "currency" %in% x))
styleElements <- list(
"style" = createStyle(numFmt = "CURRENCY"),
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
## style accounting as ACCOUNTING
if ("accounting" %in% allColClasses) {
inds <- which(sapply(colClasses, function(x) "accounting" %in% x))
styleElements <- list(
"style" = createStyle(numFmt = "ACCOUNTING"),
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
## style percentages
if ("percentage" %in% allColClasses) {
inds <- which(sapply(colClasses, function(x) "percentage" %in% x))
styleElements <- list(
"style" = createStyle(numFmt = "percentage"),
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
## style big mark
if ("scientific" %in% allColClasses) {
inds <- which(sapply(colClasses, function(x) "scientific" %in% x))
styleElements <- list(
"style" = createStyle(numFmt = "scientific"),
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
## style big mark
if ("3" %in% allColClasses || "comma" %in% allColClasses) {
inds <- which(sapply(colClasses, function(x) "3" %in% tolower(x) | "comma" %in% tolower(x)))
styleElements <- list(
"style" = createStyle(numFmt = "3"),
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
## numeric sigfigs (Col must be numeric and numFmt options must only have 0s and \\.)
if ("numeric" %in% allColClasses && !grepl("[^0\\.,#\\$\\* %]", getOption("openxlsx.numFmt", "GENERAL"))) {
inds <- which(sapply(colClasses, function(x) "numeric" %in% tolower(x)))
styleElements <- list(
"style" = createStyle(numFmt = getOption("openxlsx.numFmt", "0")),
"sheet" = wb$sheet_names[sheet],
"rows" = rep.int(rowInds, times = length(inds)),
"cols" = rep(inds + startCol, each = length(rowInds))
)
newStylesElements <- append(newStylesElements, list(styleElements))
}
if (!is.null(newStylesElements)) {
if (stack) {
for (i in seq_along(newStylesElements)) {
wb$addStyle(
sheet = sheet,
style = newStylesElements[[i]]$style,
rows = newStylesElements[[i]]$rows,
cols = newStylesElements[[i]]$cols, stack = TRUE
)
}
} else {
wb$styleObjects <- append(wb$styleObjects, newStylesElements)
}
}
invisible(1)
}
#' @name validateColour
#' @description validate the colour input
#' @param colour colour
#' @param errorMsg Error message
#' @author Philipp Schauberger
#' @importFrom grDevices colours
#' @keywords internal
#' @noRd
validateColour <- function(colour, errorMsg = "Invalid colour!") {
## check if
if (is.null(colour)) {
colour <- "black"
}
validColours <- colours()
if (any(colour %in% validColours)) {
colour[colour %in% validColours] <- col2hex(colour[colour %in% validColours])
}
if (any(!grepl("^#[A-Fa-f0-9]{6}$", colour))) {
stop(errorMsg, call. = FALSE)
}
colour <- gsub("^#", "FF", toupper(colour))
return(colour)
}
#' @name col2hex
#' @description convert rgb to hex
#' @param creator my.col
#' @author Philipp Schauberger
#' @importFrom grDevices col2rgb rgb
#' @keywords internal
#' @noRd
col2hex <- function(my.col) {
rgb(t(col2rgb(my.col)), maxColorValue = 255)
}
## header and footer replacements
headerFooterSub <- function(x) {
if (!is.null(x)) {
x <- replaceIllegalCharacters(x)
x <- gsub("\\[Page\\]", "P", x)
x <- gsub("\\[Pages\\]", "N", x)
x <- gsub("\\[Date\\]", "D", x)
x <- gsub("\\[Time\\]", "T", x)
x <- gsub("\\[Path\\]", "Z", x)
x <- gsub("\\[File\\]", "F", x)
x <- gsub("\\[Tab\\]", "A", x)
}
return(x)
}
writeCommentXML <- function(comment_list, file_name) {
authors <- unique(sapply(comment_list, "[[", "author"))
xml <- '
'
xml <- c(xml, paste0("", paste(sprintf("%s", authors), collapse = ""), ""))
for (i in seq_along(comment_list)) {
authorInd <- which(authors == comment_list[[i]]$author) - 1L
xml <- c(xml, sprintf('', comment_list[[i]]$ref, authorInd))
if (length(comment_list[[i]]$style) != 0) {
## check that style information is present
for (j in seq_along(comment_list[[i]]$comment)) {
xml <- c(xml, sprintf('%s%s',
comment_list[[i]]$style[[j]],
comment_list[[i]]$comment[[j]]))
}
} else {
## Case with no styling information.
for (j in seq_along(comment_list[[i]]$comment)) {
xml <- c(xml, sprintf('%s',
comment_list[[i]]$comment[[j]]))
}
}
xml <- c(xml, "")
}
write_file(body = paste(xml, collapse = ""), tail = "", fl = file_name)
NULL
}
illegalchars <- c("&", '"', "'", "<", ">", "\a", "\b", "\v", "\f")
illegalcharsreplace <- c("&", """, "'", "<", ">", "", "", "", "")
replaceIllegalCharacters <- function(v) {
vEnc <- Encoding(v)
v <- as.character(v)
flg <- vEnc != "UTF-8"
if (any(flg)) {
v[flg] <- stri_conv(v[flg], from = "", to = "UTF-8")
}
v <- stri_replace_all_fixed(v, illegalchars, illegalcharsreplace, vectorize_all = FALSE)
return(v)
}
replaceXMLEntities <- function(v) {
v <- gsub("&", "&", v, fixed = TRUE)
v <- gsub(""", '"', v, fixed = TRUE)
v <- gsub("'", "'", v, fixed = TRUE)
v <- gsub("<", "<", v, fixed = TRUE)
v <- gsub(">", ">", v, fixed = TRUE)
return(v)
}
pxml <- function(x) {
paste(unique(unlist(x)), collapse = "")
}
removeHeadTag <- function(x) {
x <- paste(x, collapse = "")
if (any(grepl("<\\?", x))) {
x <- gsub("<\\?xml [^>]+", "", x)
}
x <- gsub("^>", "", x)
x
}
validateBorderStyle <- function(borderStyle) {
valid <- c(
"none", "thin", "medium", "dashed", "dotted", "thick", "double", "hair", "mediumDashed",
"dashDot", "mediumDashDot", "dashDotDot", "mediumDashDotDot", "slantDashDot"
)
ind <- match(tolower(borderStyle), tolower(valid))
if (any(is.na(ind))) {
stop("Invalid borderStyle", call. = FALSE)
}
return(valid[ind])
}
getAttrsFont <- function(xml, tag) {
x <- lapply(xml, getChildlessNode, tag = tag)
x[sapply(x, length) == 0] <- ""
x <- unlist(x)
a <- lapply(x, function(x) unlist(regmatches(x, gregexpr('[a-zA-Z]+=".*?"', x))))
nms <- lapply(a, function(xml) regmatches(xml, regexpr('[a-zA-Z]+(?=\\=".*?")', xml, perl = TRUE)))
vals <- lapply(a, function(xml) regmatches(xml, regexpr('(?<=").*?(?=")', xml, perl = TRUE)))
vals <- lapply(vals, function(x) {
Encoding(x) <- "UTF-8"
x
})
vals <- lapply(seq_along(vals), function(i) {
names(vals[[i]]) <- nms[[i]]
vals[[i]]
})
return(vals)
}
getAttrs <- function(xml, tag) {
x <- lapply(xml, getChildlessNode_ss, tag = tag)
x[sapply(x, length) == 0] <- ""
a <- lapply(x, function(x) regmatches(x, regexpr('[a-zA-Z]+=".*?"', x)))
names <- lapply(a, function(xml) regmatches(xml, regexpr('[a-zA-Z]+(?=\\=".*?")', xml, perl = TRUE)))
vals <- lapply(a, function(xml) regmatches(xml, regexpr('(?<=").*?(?=")', xml, perl = TRUE)))
vals <- lapply(vals, function(x) {
Encoding(x) <- "UTF-8"
x
})
names(vals) <- names
return(vals)
}
buildFontList <- function(fonts) {
sz <- getAttrs(fonts, "sz")
colour <- getAttrsFont(fonts, "color")
name <- getAttrs(fonts, tag = "name")
family <- getAttrs(fonts, "family")
scheme <- getAttrs(fonts, "scheme")
italic <- lapply(fonts, getChildlessNode, tag = "i")
bold <- lapply(fonts, getChildlessNode, tag = "b")
underline <- lapply(fonts, getChildlessNode, tag = "u")
strikeout <- lapply(fonts, getChildlessNode, tag = "strike")
## Build font objects
ft <- replicate(list(), n = length(fonts))
for (i in seq_along(fonts)) {
f <- NULL
nms <- NULL
if (length(unlist(sz[i])) > 0) {
f <- c(f, sz[i])
nms <- c(nms, "sz")
}
if (length(unlist(colour[i])) > 0) {
f <- c(f, colour[i])
nms <- c(nms, "color")
}
if (length(unlist(name[i])) > 0) {
f <- c(f, name[i])
nms <- c(nms, "name")
}
if (length(unlist(family[i])) > 0) {
f <- c(f, family[i])
nms <- c(nms, "family")
}
if (length(unlist(scheme[i])) > 0) {
f <- c(f, scheme[i])
nms <- c(nms, "scheme")
}
if (length(italic[[i]]) > 0) {
f <- c(f, "italic")
nms <- c(nms, "italic")
}
if (length(bold[[i]]) > 0) {
f <- c(f, "bold")
nms <- c(nms, "bold")
}
if (length(underline[[i]]) > 0) {
f <- c(f, "underline")
nms <- c(nms, "underline")
}
if (length(unlist(strikeout[i])) > 0) {
f <- c(f, strikeout[i])
nms <- c(nms, "strikeout")
}
f <- lapply(seq_along(f), function(i) unlist(f[i]))
names(f) <- nms
ft[[i]] <- f
}
ft
}
get_named_regions_from_string <- function(dn) {
dn <- gsub("", "", dn, fixed = TRUE)
dn <- gsub("", "", dn, fixed = TRUE)
dn <- unique(unlist(strsplit(dn, split = "", fixed = TRUE)))
dn <- grep("
).*", dn, perl = TRUE))
dn_pos <- gsub("[$']", "", dn_pos)
has_bang <- grepl("!", dn_pos, fixed = TRUE)
dn_sheets <- ifelse(has_bang,
gsub("^(.*)!.*$", "\\1", dn_pos),
""
)
dn_coords <- ifelse(has_bang,
gsub("^.*!(.*)$", "\\1", dn_pos),
""
)
attr(dn_names, "sheet") <- dn_sheets
attr(dn_names, "position") <- dn_coords
return(dn_names)
}
nodeAttributes <- function(x) {
x <- paste0("<", unlist(strsplit(x, split = "<")))
x <- grep(" 1) tmp <- tmp[[1]]
if (length(tmp) == 1) {
sideBorder[[i]] <- tmp
}
}
sideBorder <- sideBorder[sideBorder != ""]
x <- x[sideBorder != ""]
if (length(sideBorder) == 0) {
return(NULL)
}
## style
weight <- gsub('style=|"', "", regmatches(x, regexpr('style="[a-z]+"', x, perl = TRUE, ignore.case = TRUE)))
## Colours
cols <- replicate(n = length(sideBorder), list(rgb = "FF000000"))
colNodes <- unlist(sapply(x, getChildlessNode, tag = "color", USE.NAMES = FALSE))
if (length(colNodes) > 0) {
attrs <- regmatches(colNodes, regexpr('(theme|indexed|rgb|auto)=".+"', colNodes))
} else {
attrs <- NULL
}
if (length(attrs) != length(x)) {
return(
list(
"borders" = paste(sideBorder, collapse = ""),
"colour" = cols
)
)
}
attrs <- strsplit(attrs, split = "=")
cols <- sapply(attrs, function(attr) {
if (length(attr) == 2) {
y <- list(gsub('"', "", attr[2]))
names(y) <- gsub(" ", "", attr[[1]])
} else {
tmp <- paste(attr[-1], collapse = "=")
y <- gsub('^"|"$', "", tmp)
names(y) <- gsub(" ", "", attr[[1]])
}
return(y)
})
## sideBorder & cols
if ("LEFT" %in% sideBorder) {
style$borderLeft <- weight[which(sideBorder == "LEFT")]
style$borderLeftColour <- cols[which(sideBorder == "LEFT")]
}
if ("RIGHT" %in% sideBorder) {
style$borderRight <- weight[which(sideBorder == "RIGHT")]
style$borderRightColour <- cols[which(sideBorder == "RIGHT")]
}
if ("TOP" %in% sideBorder) {
style$borderTop <- weight[which(sideBorder == "TOP")]
style$borderTopColour <- cols[which(sideBorder == "TOP")]
}
if ("BOTTOM" %in% sideBorder) {
style$borderBottom <- weight[which(sideBorder == "BOTTOM")]
style$borderBottomColour <- cols[which(sideBorder == "BOTTOM")]
}
if ("DIAGONAL" %in% sideBorder) {
style$borderDiagonal <- weight[which(sideBorder == "DIAGONAL")]
style$borderDiagonalColour <- cols[which(sideBorder == "DIAGONAL")]
}
return(style)
}
genHeaderFooterNode <- function(x) {
#
# &Lfirst L&CfC&RfR
# &LfFootL&CfFootC&RfFootR
# <IS&CIS&REVEN H
# &LEVEN L F&CEVEN C F&REVEN RIGHT F
# &L&P&Cfirst C&Rfirst R
# &Lfirst L Foot&Cfirst C Foot&Rfirst R Foot
#
## ODD
if (length(x$oddHeader) > 0) {
oddHeader <- paste0(
"",
sprintf("&L%s", x$oddHeader[[1]]),
sprintf("&C%s", x$oddHeader[[2]]),
sprintf("&R%s", x$oddHeader[[3]]),
"",
collapse = ""
)
} else {
oddHeader <- NULL
}
if (length(x$oddFooter) > 0) {
oddFooter <- paste0(
"",
sprintf("&L%s", x$oddFooter[[1]]),
sprintf("&C%s", x$oddFooter[[2]]),
sprintf("&R%s", x$oddFooter[[3]]),
"",
collapse = ""
)
} else {
oddFooter <- NULL
}
## EVEN
if (length(x$evenHeader) > 0) {
evenHeader <- paste0(
"",
sprintf("&L%s", x$evenHeader[[1]]),
sprintf("&C%s", x$evenHeader[[2]]),
sprintf("&R%s", x$evenHeader[[3]]),
"",
collapse = ""
)
} else {
evenHeader <- NULL
}
if (length(x$evenFooter) > 0) {
evenFooter <- paste0(
"",
sprintf("&L%s", x$evenFooter[[1]]),
sprintf("&C%s", x$evenFooter[[2]]),
sprintf("&R%s", x$evenFooter[[3]]),
"",
collapse = ""
)
} else {
evenFooter <- NULL
}
## FIRST
if (length(x$firstHeader) > 0) {
firstHeader <- paste0(
"",
sprintf("&L%s", x$firstHeader[[1]]),
sprintf("&C%s", x$firstHeader[[2]]),
sprintf("&R%s", x$firstHeader[[3]]),
"",
collapse = ""
)
} else {
firstHeader <- NULL
}
if (length(x$firstFooter) > 0) {
firstFooter <- paste0(
"",
sprintf("&L%s", x$firstFooter[[1]]),
sprintf("&C%s", x$firstFooter[[2]]),
sprintf("&R%s", x$firstFooter[[3]]),
"",
collapse = ""
)
} else {
firstFooter <- NULL
}
headTag <- sprintf(
'',
as.integer(!(is.null(evenHeader) & is.null(evenFooter))),
as.integer(!(is.null(firstHeader) & is.null(firstFooter)))
)
paste0(
headTag,
oddHeader,
oddFooter,
evenHeader,
evenFooter,
firstHeader,
firstFooter,
""
)
}
buildFillList <- function(fills) {
fillAttrs <- rep(list(list()), length(fills))
## patternFill
inds <- grepl("patternFill", fills)
fillAttrs[inds] <- lapply(fills[inds], nodeAttributes)
## gradientFill
inds <- grepl("gradientFill", fills)
fillAttrs[inds] <- fills[inds]
return(fillAttrs)
}
# Can test with below:
# x <- "'A & B < D > D'!$A$1:$A$10"
getDefinedNamesSheet <- function(x) {
sub("'?\\!.*", "", sub("^.*>'", "", x))
}
# Not used but kepted in case fix above isn't correct
getDefinedNamedSheet_ <- function(x) {
belongTo <- unlist(lapply(strsplit(x, split = ">|<"), "[[", 3))
quoted <- grepl("^'", belongTo)
belongTo[quoted] <- regmatches(belongTo[quoted], regexpr("(?<=').*(?='!)", belongTo[quoted], perl = TRUE))
belongTo[!quoted] <- gsub("!\\$[A-Z0-9].*", "", belongTo[!quoted])
belongTo[!quoted] <- gsub("!#REF!.*", "", belongTo[!quoted])
return(belongTo)
}
getSharedStringsFromFile <- function(sharedStringsFile, isFile) {
## read in, get si tags, get t tag value and pull out all string nodes
sharedStrings <- get_shared_strings(xmlFile = sharedStringsFile, isFile = isFile) ## read from file
Encoding(sharedStrings) <- "UTF-8"
z <- tolower(sharedStrings)
sharedStrings[z == "true"] <- "TRUE"
sharedStrings[z == "false"] <- "FALSE"
z <- NULL ## effectivel remove z
## XML replacements
sharedStrings <- replaceXMLEntities(sharedStrings)
return(sharedStrings)
}
clean_names <- function(x, schar) {
x <- gsub("^[[:space:]]+|[[:space:]]+$", "", x)
x <- gsub("[[:space:]]+", schar, x)
return(x)
}
mergeCell2mapping <- function(x) {
refs <- regmatches(x, regexpr("(?<=ref=\")[A-Z0-9:]+", x, perl = TRUE))
refs <- strsplit(refs, split = ":")
rows <- lapply(refs, function(r) {
r <- as.integer(gsub(pattern = "[A-Z]", replacement = "", r, perl = TRUE))
seq(from = r[1], to = r[2], by = 1)
})
cols <- lapply(refs, function(r) {
r <- convertFromExcelRef(r)
seq(from = r[1], to = r[2], by = 1)
})
## for each we grid.expand
refs <- do.call("rbind", lapply(seq_along(rows), function(i) {
tmp <- expand.grid("cols" = cols[[i]], "rows" = rows[[i]])
tmp$ref <- paste0(convert_to_excel_ref(cols = tmp$cols, LETTERS = LETTERS), tmp$rows)
tmp$anchor_cell <- tmp$ref[1]
return(tmp[, c("anchor_cell", "ref", "rows")])
}))
refs <- refs[refs$anchor_cell != refs$ref, ]
return(refs)
}
getFile <- function(xlsxFile) {
## Is this a file or URL (code taken from read.table())
on.exit(try(close(fl), silent = TRUE), add = TRUE)
fl <- file(description = xlsxFile)
## If URL download
if ("url" %in% class(fl)) {
tmpFile <- tempfile(fileext = ".xlsx")
download.file(url = xlsxFile, destfile = tmpFile, cacheOK = FALSE, mode = "wb", quiet = TRUE)
xlsxFile <- tmpFile
}
return(xlsxFile)
}
#' @name get_worksheet_entries
#' @title Get entries from workbook worksheet
#' @description Get all entries from workbook worksheet without xml tags
#' @param wb workbook
#' @param sheet worksheet
#' @author David Breuer
#' @return vector of strings
#' @export
#' @examples
#' ## Create new workbook
#' wb <- createWorkbook()
#' addWorksheet(wb, "Sheet")
#' sheet <- 1
#'
#' ## Write dummy data
#' writeData(wb, sheet, c("A", "BB", "CCC"), startCol = 2, startRow = 3)
#' writeData(wb, sheet, c(4, 5), startCol = 4, startRow = 3)
#'
#' ## Get text entries
#' get_worksheet_entries(wb, sheet)
#'
get_worksheet_entries <- function(wb, sheet) {
# get worksheet data
dat <- wb$worksheets[[sheet]]$sheet_data
# get vector of entries
val <- dat$v
# get boolean vector of text entries
typ <- (dat$t == 1) & !is.na(dat$t)
# get text entry strings
str <- unlist(wb$sharedStrings[as.numeric(val[typ]) + 1])
# remove xml tags
str <- gsub("<.*?>", "", str)
# write strings to vector of entries
val[typ] <- str
# return vector of entries
val
}
#' @name auto_heights
#' @title Compute optimal row heights
#' @description Compute optimal row heights for cell with fixed with and
#' enabled automatic row heights parameter
#' @param wb workbook
#' @param sheet worksheet
#' @param selected selected rows
#' @param fontsize font size, optional (get base font size by default)
#' @param factor factor to manually adjust font width, e.g., for bold fonts,
#' optional
#' @param base_height basic row height, optional
#' @param extra_height additional row height per new line of text, optional
#' @author David Breuer
#' @return list of indices of columns with fixed widths and optimal row heights
#' @export
#' @examples
#' ## Create new workbook
#' wb <- createWorkbook()
#' addWorksheet(wb, "Sheet")
#' sheet <- 1
#'
#' ## Write dummy data
#' long_string <- "ABC ABC ABC ABC ABC ABC ABC ABC ABC ABC ABC"
#' writeData(wb, sheet, c("A", long_string, "CCC"), startCol = 2, startRow = 3)
#' writeData(wb, sheet, c(4, 5), startCol = 4, startRow = 3)
#'
#' ## Set column widths and get optimal row heights
#' setColWidths(wb, sheet, c(1,2,3,4), c(10,20,10,20))
#' auto_heights(wb, sheet, 1:5)
#'
auto_heights <- function(wb, sheet, selected, fontsize = NULL, factor = 1.0,
base_height = 15, extra_height = 12) {
# get base font size
if (is.null(fontsize)) {
fontsize <- as.integer(openxlsx::getBaseFont(wb)$size$val)
}
# set factor to adjust font width (empiricially found scale factor 4 here)
factor <- 4 * factor / fontsize
# get worksheet data
dat <- wb$worksheets[[sheet]]$sheet_data
# get columns widths
colWidths <- wb$colWidths[[sheet]]
# select fixed (non-auto) and visible (non-hidden) columns only
specified <- (colWidths != "auto") & (attr(colWidths, "hidden") == "0")
# return default row heights if no column widths are fixed
if (length(specified) == 0) {
# message("No column widths specified, returning default row heights.")
cols <- integer(0)
heights <- rep(base_height, length(selected))
return(list(cols, heights))
}
# get fixed column indices
cols <- as.integer(names(specified)[specified])
# get fixed column widths
widths <- as.numeric(colWidths[specified])
# get all worksheet entries
val <- get_worksheet_entries(wb, sheet)
# compute optimal height per selected row
heights <- sapply(selected, function(row) {
# select entries in given row and columns of fixed widths
index <- (dat$rows == row) & (dat$cols %in% cols)
# remove line break characters
chr <- gsub("\\r|\\n", "", val[index])
# measure width of entry (in pixels)
wdt <- graphics::strwidth(chr, unit = "in") * 20 / 1.43 # 20 px = 1.43 in
# compute optimal height
if (length(wdt) == 0) {
base_height
} else {
base_height + extra_height * as.integer(max(wdt / widths * factor))
}
})
# return list of indices of columns with fixed widths and optimal row heights
list(cols, heights)
}
# Rotate the 15-bit integer by n bits to the
hashPassword <- function(password) {
# password limited to 15 characters
chars <- head(strsplit(password, "")[[1]], 15)
# See OpenOffice's documentation of the Excel format: http://www.openoffice.org/sc/excelfileformat.pdf
# Start from the last character and for each character
# - XOR hash with the ASCII character code
# - rotate hash (16 bits) one bit to the left
# Finally, XOR hash with 0xCE4B and XOR with password length
# Output as hex (uppercase)
rotate16bit <- function(hash, n = 1) {
bitwOr(bitwAnd(bitwShiftR(hash, 15 - n), 0x01), bitwAnd(bitwShiftL(hash, n), 0x7fff))
}
hash <- Reduce(function(char, h) {
h <- bitwXor(h, as.integer(charToRaw(char)))
rotate16bit(h, 1)
}, chars, 0, right = TRUE)
hash <- bitwXor(bitwXor(hash, length(chars)), 0xCE4B)
format(as.hexmode(hash), upper.case = TRUE)
}
readUTF8 <- function(x) {
readLines(x, warn = FALSE, encoding = "UTF-8")
}
openxlsx/R/writeData.R 0000644 0001762 0000144 00000043016 14656134061 014414 0 ustar ligges users #' @name writeData
#' @title Write an object to a worksheet
#' @author Alexander Walker
#' @import stringi
#' @description Write an object to worksheet with optional styling.
#' @param wb A Workbook object containing a worksheet.
#' @param sheet The worksheet to write to. Can be the worksheet index or name.
#' @param x Object to be written. For classes supported look at the examples.
#' @param startCol A vector specifying the starting column to write to.
#' @param startRow A vector specifying the starting row to write to.
#' @param array A bool if the function written is of type array
#' @param xy An alternative to specifying `startCol` and
#' `startRow` individually. A vector of the form
#' `c(startCol, startRow)`.
#' @param colNames If `TRUE`, column names of x are written.
#' @param rowNames If `TRUE`, data.frame row names of x are written.
#' @param row.names,col.names Deprecated, please use `rowNames`, `colNames` instead
#' @param headerStyle Custom style to apply to column names.
#' @param borders Either "`none`" (default), "`surrounding`",
#' "`columns`", "`rows`" or *respective abbreviations*. If
#' "`surrounding`", a border is drawn around the data. If "`rows`",
#' a surrounding border is drawn with a border around each row. If
#' "`columns`", a surrounding border is drawn with a border between
#' each column. If "`all`" all cell borders are drawn.
#' @param borderColour Colour of cell border. A valid colour (belonging to `colours()` or a hex colour code, eg see [here](https://www.w3schools.com/colors/colors_picker.asp)).
#' @param borderStyle Border line style
#' \describe{
#' \item{**none**}{ no border}
#' \item{**thin**}{ thin border}
#' \item{**medium**}{ medium border}
#' \item{**dashed**}{ dashed border}
#' \item{**dotted**}{ dotted border}
#' \item{**thick**}{ thick border}
#' \item{**double**}{ double line border}
#' \item{**hair**}{ hairline border}
#' \item{**mediumDashed**}{ medium weight dashed border}
#' \item{**dashDot**}{ dash-dot border}
#' \item{**mediumDashDot**}{ medium weight dash-dot border}
#' \item{**dashDotDot**}{ dash-dot-dot border}
#' \item{**mediumDashDotDot**}{ medium weight dash-dot-dot border}
#' \item{**slantDashDot**}{ slanted dash-dot border}
#' }
#' @param withFilter If `TRUE` or `NA`, add filters to the column name row. NOTE can only have one filter per worksheet.
#' @param keepNA If `TRUE`, NA values are converted to #N/A (or `na.string`, if not NULL) in Excel, else NA cells will be empty.
#' @param na.string If not NULL, and if `keepNA` is `TRUE`, NA values are converted to this string in Excel.
#' @param name If not NULL, a named region is defined.
#' @param 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).
#' @seealso [writeDataTable()]
#' @export writeData
#' @details Formulae written using writeFormula to a Workbook object will not get picked up by read.xlsx().
#' This is because only the formula is written and left to Excel to evaluate the formula when the file is opened in Excel.
#' @rdname writeData
#' @return invisible(0)
#' @examples
#'
#' ## See formatting vignette for further examples.
#'
#' ## Options for default styling (These are the defaults)
#' options("openxlsx.borderColour" = "black")
#' options("openxlsx.borderStyle" = "thin")
#' options("openxlsx.dateFormat" = "mm/dd/yyyy")
#' options("openxlsx.datetimeFormat" = "yyyy-mm-dd hh:mm:ss")
#' options("openxlsx.numFmt" = NULL)
#'
#' ## Change the default border colour to #4F81BD
#' options("openxlsx.borderColour" = "#4F81BD")
#'
#'
#' #####################################################################################
#' ## Create Workbook object and add worksheets
#' wb <- createWorkbook()
#'
#' ## Add worksheets
#' addWorksheet(wb, "Cars")
#' addWorksheet(wb, "Formula")
#'
#'
#' x <- mtcars[1:6, ]
#' writeData(wb, "Cars", x, startCol = 2, startRow = 3, rowNames = TRUE)
#'
#' #####################################################################################
#' ## Bordering
#'
#' writeData(wb, "Cars", x,
#' rowNames = TRUE, startCol = "O", startRow = 3,
#' borders = "surrounding", borderColour = "black"
#' ) ## black border
#'
#' writeData(wb, "Cars", x,
#' rowNames = TRUE,
#' startCol = 2, startRow = 12, borders = "columns"
#' )
#'
#' writeData(wb, "Cars", x,
#' rowNames = TRUE,
#' startCol = "O", startRow = 12, borders = "rows"
#' )
#'
#'
#' #####################################################################################
#' ## Header Styles
#'
#' hs1 <- createStyle(
#' fgFill = "#DCE6F1", halign = "CENTER", textDecoration = "italic",
#' border = "Bottom"
#' )
#'
#' writeData(wb, "Cars", x,
#' colNames = TRUE, rowNames = TRUE, startCol = "B",
#' startRow = 23, borders = "rows", headerStyle = hs1, borderStyle = "dashed"
#' )
#'
#'
#' hs2 <- createStyle(
#' fontColour = "#ffffff", fgFill = "#4F80BD",
#' halign = "center", valign = "center", textDecoration = "bold",
#' border = "TopBottomLeftRight"
#' )
#'
#' writeData(wb, "Cars", x,
#' colNames = TRUE, rowNames = TRUE,
#' startCol = "O", startRow = 23, borders = "columns", headerStyle = hs2
#' )
#'
#'
#'
#'
#' #####################################################################################
#' ## Hyperlinks
#' ## - vectors/columns with class 'hyperlink' are written as hyperlinks'
#'
#' v <- rep("https://CRAN.R-project.org/", 4)
#' names(v) <- paste0("Hyperlink", 1:4) # Optional: names will be used as display text
#' class(v) <- "hyperlink"
#' writeData(wb, "Cars", x = v, xy = c("B", 32))
#'
#'
#' #####################################################################################
#' ## Formulas
#' ## - vectors/columns with class 'formula' are written as formulas'
#'
#' df <- data.frame(
#' x = 1:3, y = 1:3,
#' z = paste0(paste0("A", 1:3 + 1L), paste0("B", 1:3 + 1L), sep = " + "),
#' stringsAsFactors = FALSE
#' )
#'
#' class(df$z) <- c(class(df$z), "formula")
#'
#' writeData(wb, sheet = "Formula", x = df)
#'
#'
#' #####################################################################################
#' ## Save workbook
#' ## Open in excel without saving file: openXL(wb)
#' \dontrun{
#' saveWorkbook(wb, "writeDataExample.xlsx", overwrite = TRUE)
#' }
writeData <- function(
wb,
sheet,
x,
startCol = 1,
startRow = 1,
array = FALSE,
xy = NULL,
colNames = TRUE,
rowNames = FALSE,
headerStyle = openxlsx_getOp("headerStyle"),
borders = openxlsx_getOp("borders", "none"),
borderColour = openxlsx_getOp("borderColour", "black"),
borderStyle = openxlsx_getOp("borderStyle", "thin"),
withFilter = openxlsx_getOp("withFilter", FALSE),
keepNA = openxlsx_getOp("keepNA", FALSE),
na.string = openxlsx_getOp("na.string"),
name = NULL,
sep = ", ",
col.names,
row.names
) {
x <- force(x)
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"
borderStyle <- borderStyle %||% "thin"
withFilter <- withFilter %||% FALSE
keepNA <- keepNA %||% FALSE
if (is.null(x)) {
return(invisible(0))
}
## All input conversions/validations
if (!is.null(xy)) {
if (length(xy) != 2) {
stop("xy parameter must have length 2")
}
startCol <- xy[[1]]
startRow <- xy[[2]]
}
## convert startRow and startCol
if (!is.numeric(startCol)) {
startCol <- convertFromExcelRef(startCol)
}
startRow <- as.integer(startRow)
assert_class(wb, "Workbook")
assert_true_false(colNames)
assert_true_false(rowNames)
assert_character1(sep)
assert_class(headerStyle, "Style", or_null = TRUE)
## borderColours validation
borderColour <- validateColour(borderColour, "Invalid border colour")
borderStyle <- validateBorderStyle(borderStyle)[[1]]
## special case - vector of hyperlinks
hlinkNames <- NULL
if (inherits(x, "hyperlink")) {
hlinkNames <- names(x)
colNames <- FALSE
}
## special case - formula
if (inherits(x, "formula")) {
x <- data.frame("X" = x, stringsAsFactors = FALSE)
class(x[[1]]) <- ifelse(array, "array_formula", "formula")
colNames <- FALSE
}
## named region
if (!is.null(name)) { ## validate name
ex_names <- regmatches(wb$workbook$definedNames, regexpr('(?<=name=")[^"]+', wb$workbook$definedNames, perl = TRUE))
ex_names <- replaceXMLEntities(ex_names)
if (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.")
}
}
if (is.vector(x) || is.factor(x) || inherits(x, "Date")) {
colNames <- FALSE
} ## this will go to coerce.default and rowNames will be ignored
## Coerce to data.frame
x <- openxlsxCoerce(x = x, rowNames = rowNames)
nCol <- ncol(x)
nRow <- nrow(x)
## If no rows and not writing column names return as nothing to write
if (nRow == 0 && !colNames) {
return(invisible(0))
}
## If no columns and not writing row names return as nothing to write
if (nCol == 0 && !rowNames) {
return(invisible(0))
}
colClasses <- lapply(x, function(x) tolower(class(x)))
colClasss2 <- colClasses
colClasss2[vapply(
colClasses,
function(i) inherits(i, "formula") & inherits(i, "hyperlink"),
NA
)] <- "formula"
if (is.numeric(sheet)) {
sheetX <- wb$validateSheet(sheet)
} else {
sheetX <- wb$validateSheet(replaceXMLEntities(sheet))
sheet <- replaceXMLEntities(sheet)
}
if (wb$isChartSheet[[sheetX]]) {
stop("Cannot write to chart sheet.")
}
## 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),
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."
)
## 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)
)
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 = ":"))
dn <- sprintf('%s', sheetX - 1L, dfn)
if (length(wb$workbook$definedNames) > 0) {
ind <- grepl('name="_xlnm._FilterDatabase"', wb$workbook$definedNames)
if (length(ind) > 0) {
wb$workbook$definedNames[ind] <- dn
}
} else {
wb$workbook$definedNames <- dn
}
}
## write data.frame
wb$writeData(
df = x,
colNames = colNames,
sheet = sheet,
startCol = startCol,
startRow = startRow,
colClasses = colClasss2,
hlinkNames = hlinkNames,
keepNA = keepNA,
na.string = na.string,
list_sep = sep
)
## header style
if (inherits(headerStyle, "Style") && colNames) {
addStyle(
wb = wb,
sheet = sheet,
style = headerStyle,
rows = startRow,
cols = 0:(nCol - 1) + startCol,
gridExpand = TRUE,
stack = TRUE
)
}
## If we don't have any rows to write return
if (nRow == 0) {
return(invisible(0))
}
## named region
if (!is.null(name)) {
ref1 <- stri_join("$", convert_to_excel_ref(cols = startCol, LETTERS = LETTERS), "$", startRow)
ref2 <- stri_join("$", convert_to_excel_ref(cols = startCol + nCol - 1L, LETTERS = LETTERS), "$", startRow + nRow - 1L + colNames)
wb$createNamedRegion(ref1 = ref1, ref2 = ref2, name = name, sheet = wb$sheet_names[wb$validateSheet(sheet)])
}
## hyperlink style, if no borders
borders <- match.arg(borders, c("none", "surrounding", "rows", "columns", "all"))
if (borders == "none") {
invisible(
classStyles(
wb,
sheet = sheet,
startRow = startRow,
startCol = startCol,
colNames = colNames,
nRow = nrow(x),
colClasses = colClasses,
stack = TRUE
)
)
} else if (borders == "surrounding") {
wb$surroundingBorders(
colClasses,
sheet = sheet,
startRow = startRow + colNames,
startCol = startCol,
nRow = nRow, nCol = nCol,
borderColour = list("rgb" = borderColour),
borderStyle = borderStyle
)
} else if (borders == "rows") {
wb$rowBorders(
colClasses,
sheet = sheet,
startRow = startRow + colNames,
startCol = startCol,
nRow = nRow, nCol = nCol,
borderColour = list("rgb" = borderColour),
borderStyle = borderStyle
)
} else if (borders == "columns") {
wb$columnBorders(
colClasses,
sheet = sheet,
startRow = startRow + colNames,
startCol = startCol,
nRow = nRow, nCol = nCol,
borderColour = list("rgb" = borderColour),
borderStyle = borderStyle
)
} else if (borders == "all") {
wb$allBorders(
colClasses,
sheet = sheet,
startRow = startRow + colNames,
startCol = startCol,
nRow = nRow, nCol = nCol,
borderColour = list("rgb" = borderColour),
borderStyle = borderStyle
)
}
invisible(0)
}
#' @name writeFormula
#' @title Write a character vector as an Excel Formula
#' @author Alexander Walker
#' @description Write a a character vector containing Excel formula to a worksheet.
#' @details Currently only the english version of functions are supported. Please don't use the local translation.
#' The examples below show a small list of possible formulas:
#' \itemize{
#' \item{SUM(B2:B4)}
#' \item{AVERAGE(B2:B4)}
#' \item{MIN(B2:B4)}
#' \item{MAX(B2:B4)}
#' \item{...}
#'
#' }
#' @param wb A Workbook object containing a worksheet.
#' @param sheet The worksheet to write to. Can be the worksheet index or name.
#' @param x A character vector.
#' @param startCol A vector specifying the starting column to write to.
#' @param startRow A vector specifying the starting row to write to.
#' @param array A bool if the function written is of type array
#' @param xy An alternative to specifying `startCol` and
#' `startRow` individually. A vector of the form
#' `c(startCol, startRow)`.
#' @seealso [writeData()] [makeHyperlinkString()]
#' @export writeFormula
#' @rdname writeFormula
#' @examples
#'
#' ## There are 3 ways to write a formula
#'
#' wb <- createWorkbook()
#' addWorksheet(wb, "Sheet 1")
#' writeData(wb, "Sheet 1", x = iris)
#'
#' ## SEE int2col() to convert int to Excel column label
#'
#' ## 1. - As a character vector using writeFormula
#'
#' v <- c("SUM(A2:A151)", "AVERAGE(B2:B151)") ## skip header row
#' writeFormula(wb, sheet = 1, x = v, startCol = 10, startRow = 2)
#' writeFormula(wb, 1, x = "A2 + B2", startCol = 10, startRow = 10)
#'
#'
#' ## 2. - As a data.frame column with class "formula" using writeData
#'
#' df <- data.frame(
#' x = 1:3,
#' y = 1:3,
#' z = paste(paste0("A", 1:3 + 1L), paste0("B", 1:3 + 1L), sep = " + "),
#' z2 = sprintf("ADDRESS(1,%s)", 1:3),
#' stringsAsFactors = FALSE
#' )
#'
#' class(df$z) <- c(class(df$z), "formula")
#' class(df$z2) <- c(class(df$z2), "formula")
#'
#' addWorksheet(wb, "Sheet 2")
#' writeData(wb, sheet = 2, x = df)
#'
#'
#'
#' ## 3. - As a vector with class "formula" using writeData
#'
#' v2 <- c("SUM(A2:A4)", "AVERAGE(B2:B4)", "MEDIAN(C2:C4)")
#' class(v2) <- c(class(v2), "formula")
#'
#' writeData(wb, sheet = 2, x = v2, startCol = 10, startRow = 2)
#'
#' ## Save workbook
#' \dontrun{
#' saveWorkbook(wb, "writeFormulaExample.xlsx", overwrite = TRUE)
#' }
#'
#'
#' ## 4. - Writing internal hyperlinks
#'
#' wb <- createWorkbook()
#' addWorksheet(wb, "Sheet1")
#' addWorksheet(wb, "Sheet2")
#' writeFormula(wb, "Sheet1", x = '=HYPERLINK("#Sheet2!B3", "Text to Display - Link to Sheet2")')
#'
#' ## Save workbook
#' \dontrun{
#' saveWorkbook(wb, "writeFormulaHyperlinkExample.xlsx", overwrite = TRUE)
#' }
#'
writeFormula <- function(
wb,
sheet,
x,
startCol = 1,
startRow = 1,
array = FALSE,
xy = NULL
) {
if (!is.character(x)) {
stop("x must be a character vector.")
}
dfx <- data.frame("X" = x, stringsAsFactors = FALSE)
class(dfx$X) <- c("character", ifelse(array, "array_formula", "formula"))
if (any(grepl("^(=|)HYPERLINK\\(", x, ignore.case = TRUE))) {
class(dfx$X) <- c("character", "formula", "hyperlink")
}
writeData(
wb = wb,
sheet = sheet,
x = dfx,
startCol = startCol,
startRow = startRow,
array = array,
xy = xy,
colNames = FALSE,
rowNames = FALSE
)
invisible(0)
}
#' `as.character.formula()`
#'
#' This function exists to prevent conflicts with `as.character.formula` methods
#' from other packages
#'
#' @inheritParams base::as.character
#' @param ... Not implemented
#' @returns `base::as.character.default(x)`
#' @export
as.character.formula <- function(x, ...) {
base::as.character.default(x)
}
openxlsx/R/readWorkbook.R 0000644 0001762 0000144 00000045401 14656134061 015121 0 ustar ligges users
#' @name read.xlsx
#' @title Read from an Excel file or Workbook object
#' @description Read data from an Excel file or Workbook object into a data.frame
#' @param xlsxFile An xlsx file, Workbook object or URL to xlsx file.
#' @param sheet The name or index of the sheet to read data from.
#' @param startRow first row to begin looking for data. Empty rows at the top of a file are always skipped,
#' regardless of the value of startRow.
#' @param colNames If `TRUE`, the first row of data will be used as column names.
#' @param skipEmptyRows If `TRUE`, empty rows are skipped else empty rows after the first row containing data
#' will return a row of NAs.
#' @param rowNames If `TRUE`, first column of data will be used as row names.
#' @param detectDates If `TRUE`, attempt to recognise dates and perform conversion.
#' @param cols A numeric vector specifying which columns in the Excel file to read.
#' If NULL, all columns are read.
#' @param rows A numeric vector specifying which rows in the Excel file to read.
#' If NULL, all rows are read.
#' @param check.names logical. If TRUE then the names of the variables in the data frame
#' are checked to ensure that they are syntactically valid variable names
#' @param sep.names One character which substitutes blanks in column names. By default, "."
#' @param namedRegion A named region in the Workbook. If not NULL startRow, rows and cols parameters are ignored.
#' @param na.strings A character vector of strings which are to be interpreted as NA. Blank cells will be returned as NA.
#' @param fillMergedCells If TRUE, the value in a merged cell is given to all cells within the merge.
#' @param skipEmptyCols If `TRUE`, empty columns are skipped.
#' @seealso [getNamedRegions()]
#' @details Formulae written using writeFormula to a Workbook object will not get picked up by read.xlsx().
#' This is because only the formula is written and left to be evaluated when the file is opened in Excel.
#' Opening, saving and closing the file with Excel will resolve this.
#' @author Alexander Walker
#' @return data.frame
#' @export
#' @examples
#'
#' xlsxFile <- system.file("extdata", "readTest.xlsx", package = "openxlsx")
#' df1 <- read.xlsx(xlsxFile = xlsxFile, sheet = 1, skipEmptyRows = FALSE)
#' sapply(df1, class)
#'
#' df2 <- read.xlsx(xlsxFile = xlsxFile, sheet = 3, skipEmptyRows = TRUE)
#' df2$Date <- convertToDate(df2$Date)
#' sapply(df2, class)
#' head(df2)
#'
#' df2 <- read.xlsx(
#' xlsxFile = xlsxFile, sheet = 3, skipEmptyRows = TRUE,
#' detectDates = TRUE
#' )
#' sapply(df2, class)
#' head(df2)
#'
#' wb <- loadWorkbook(system.file("extdata", "readTest.xlsx", package = "openxlsx"))
#' df3 <- read.xlsx(wb, sheet = 2, skipEmptyRows = FALSE, colNames = TRUE)
#' df4 <- read.xlsx(xlsxFile, sheet = 2, skipEmptyRows = FALSE, colNames = TRUE)
#' all.equal(df3, df4)
#'
#' wb <- loadWorkbook(system.file("extdata", "readTest.xlsx", package = "openxlsx"))
#' df3 <- read.xlsx(wb,
#' sheet = 2, skipEmptyRows = FALSE,
#' cols = c(1, 4), rows = c(1, 3, 4)
#' )
#'
#' ## URL
#' ##
#' \dontrun{
#' xlsxFile <- "https://github.com/awalker89/openxlsx/raw/master/inst/readTest.xlsx"
#' head(read.xlsx(xlsxFile))
#' }
#'
#' @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
) {
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
) {
## Validate inputs and get files
xlsxFile <- getFile(xlsxFile)
if (!file.exists(xlsxFile)) {
stop("File does not exist.")
}
sheetselected <- TRUE
if (missing(sheet)) {
sheet <- 1
sheetselected <- FALSE
}
if (!grepl("\\.xlsx|\\.xlsm$", xlsxFile)) {
stop("openxlsx can only read .xlsx or .xlsm 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) > 1L) {
rows <- as.integer(sort(rows))
}
xmlDir <- paste0(tempfile(), "_excelXMLRead")
xmlFiles <- unzip(xlsxFile, exdir = xmlDir)
on.exit(unlink(xmlDir, recursive = TRUE), add = 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))
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)
## make sure sheetId is 1 based
sheetrId <- unlist(getRId(sheets))
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)) {
dn <- getNodes(xml = workbook, tagIn = "")
dn <- unlist(regmatches(dn, gregexpr("' and '!'
dn_sheetNames <- gsub(".*[>]([^.]+)[!].*", "\\1", dn)
# Check if there are any whitespaces in dn_sheetNames.
# Hint: sheet names must not contain: \ / ? * [ ]
wsp <- grepl(pattern = "'", dn_sheetNames)
if (any(wsp)) {
# sheetNames in between ''' and '''. If there is a whitespace in a sheet
# 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=\"([[:graph:]_]+)\".*", "\\1", dn)
if (length(dn) == 0) {
warning("Workbook has no named region.")
return(invisible(NULL))
}
if (all(dn_namedRegion != namedRegion)) {
warning("Workbook has no such named region.")
return(invisible(NULL))
}
idx <- match(dn_namedRegion, namedRegion)
# make sure that the length of both vectors is identical
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) {
idx <- match(dn_sheetNames, sheetNames)
if (is.numeric(sheet)) {
idx <- which(idx == sheet)
} else {
idx <- which(dn_sheetNames == sheet)
}
dn <- dn[idx]
if (length(dn) > 1) {
warning("unexpectedly found more than one dn.")
print(dn)
return(invisible(NULL))
}
if ( identical(dn, character(0)) ) {
warning("Workbook has no such named region on this sheet.")
return(invisible(NULL))
}
}
# 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.")
message(msg)
dn <- dn[1]
dn_namedRegion <- dn_namedRegion[1]
dn_sheetNames <- dn_sheetNames[1]
}
# 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))
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.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 <- grep(sprintf('Id="%s"', rId), workbookRelsXML, fixed = TRUE, value = TRUE)
regmatches(txt, regexpr('(?<=Target=").+xml(?=")', txt, perl = TRUE))
})
## get the correct sheets
if (is.character(sheet)) {
sheetNames <- replaceXMLEntities(sheetNames)
sheetInd <- which(sheetNames == sheet)
if (length(sheetInd) == 0) {
stop(sprintf('Cannot find sheet named "%s"', sheet))
}
sheet <- file_name[sheetInd]
} else {
if (nSheets < sheet) {
stop(sprintf("sheet %s does not exist.", sheet))
}
sheet <- file_name[sheet]
}
if (length(sheet) == 0) {
stop("Length of sheet is 0", call. = FALSE)
}
## get file
worksheet <- xmlFiles[grepl(tolower(sheet), tolower(xmlFiles), fixed = TRUE)]
if (length(worksheet) == 0) {
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"
}
} else {
sharedStrings <- ""
}
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,
sharedStrings = sharedStrings,
skipEmptyRows = skipEmptyRows,
startRow = startRow,
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]
cell_info$v <- cell_info$v[!to_remove_inds]
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]
cell_info$string_refs <-
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)),
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("[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_rows <- as.integer(gsub("[A-Z]", "", cell_info$r, perl = TRUE))
cell_cols <- convert_from_excel_ref(x = cell_info$r)
## 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) {
## keep region the correct size
nRows <- max(rows) - min(rows) + 1
} 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 <- 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]]
if (toKeep > 1) {
toRemove <- 1:(toKeep - 1)
string_refs <- string_refs[!string_refs %in% r[toRemove]]
v <- v[-toRemove]
r <- r[-toRemove]
nRows <-
calc_number_rows(x = r, skipEmptyRows = skipEmptyRows)
}
}
}
## Determine date cells (if required)
origin <- 25569L
if (detectDates) {
## get date origin
if (grepl('date1904="1"|date1904="true"', workbook, ignore.case = TRUE)) {
origin <- 24107L
}
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)
## this regex defines what "looks" like a date
dateIds <- numFmtsIds[!grepl("[^mdyhsapAMP[:punct:] ]", formatCodes) &
nchar(formatCodes > 3)]
}
dateIds <- c(dateIds, 14)
## which styles are using these dateIds
cellXfs <- getNodes(xml = styles, tagIn = "