Nothing
#' @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 <- '<comments xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="xr" xmlns:xr="http://schemas.microsoft.com/office/spreadsheetml/2014/revision">'
xml <- c(xml, paste0("<authors>", paste(sprintf("<author>%s</author>", authors), collapse = ""), "</authors><commentList>"))
for (i in seq_along(comment_list)) {
authorInd <- which(authors == comment_list[[i]]$author) - 1L
xml <- c(xml, sprintf('<comment ref="%s" authorId="%s" shapeId="0"><text>', 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('<r>%s<t xml:space="preserve">%s</t></r>',
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('<t>%s</t>',
comment_list[[i]]$comment[[j]]))
}
}
xml <- c(xml, "</text></comment>")
}
write_file(body = paste(xml, collapse = ""), tail = "</commentList></comments>", 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("</definedNames>", "", dn, fixed = TRUE)
dn <- gsub("</workbook>", "", dn, fixed = TRUE)
dn <- unique(unlist(strsplit(dn, split = "</definedName>", fixed = TRUE)))
dn <- grep("<definedName", dn, fixed = TRUE, value = TRUE)
dn_names <- regmatches(dn, regexpr('(?<=name=")[^"]+', dn, perl = TRUE))
dn_pos <- regmatches(dn, regexpr("(?<=>).*", 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("<bgColor|<fgColor", x, value = TRUE)
if (length(x) == 0) {
return("")
}
attrs <- regmatches(x, gregexpr(' [a-zA-Z]+="[^"]*', x, perl = TRUE))
tags <- regmatches(x, gregexpr("<[a-zA-Z]+ ", x, perl = TRUE))
tags <- lapply(tags, gsub, pattern = "<| ", replacement = "")
attrs <- lapply(attrs, gsub, pattern = '"', replacement = "")
attrs <- lapply(attrs, strsplit, split = "=")
for (i in seq_along(attrs)) {
nms <- lapply(attrs[[i]], "[[", 1)
vals <- lapply(attrs[[i]], "[[", 2)
a <- unlist(vals)
names(a) <- unlist(nms)
attrs[[i]] <- a
}
names(attrs) <- unlist(tags)
attrs
}
buildBorder <- function(x) {
style <- list()
if (grepl('diagonalup="1"', tolower(x), fixed = TRUE)) {
style$borderDiagonalUp <- TRUE
}
if (grepl('diagonaldown="1"', tolower(x), fixed = TRUE)) {
style$borderDiagonalDown <- TRUE
}
## gets all borders that have children
x <- unlist(lapply(c("<left", "<right", "<top", "<bottom", "<diagonal"), function(tag) getNodes(xml = x, tagIn = tag)))
if (length(x) == 0) {
return(NULL)
}
sides <- c("TOP", "BOTTOM", "LEFT", "RIGHT", "DIAGONAL")
sideBorder <- character(length = length(x))
for (i in seq_along(x)) {
tmp <- sides[sapply(sides, function(s) grepl(s, x[[i]], ignore.case = TRUE))]
if (length(tmp) > 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) {
# <headerFooter differentOddEven="1" differentFirst="1" scaleWithDoc="0" alignWithMargins="0">
# <oddHeader>&Lfirst L&CfC&RfR</oddHeader>
# <oddFooter>&LfFootL&CfFootC&RfFootR</oddFooter>
# <evenHeader>&LTIS&CIS&REVEN H</evenHeader>
# <evenFooter>&LEVEN L F&CEVEN C F&REVEN RIGHT F</evenFooter>
# <firstHeader>&L&P&Cfirst C&Rfirst R</firstHeader>
# <firstFooter>&Lfirst L Foot&Cfirst C Foot&Rfirst R Foot</firstFooter>
# </headerFooter>
## ODD
if (length(x$oddHeader) > 0) {
oddHeader <- paste0(
"<oddHeader>",
sprintf("&L%s", x$oddHeader[[1]]),
sprintf("&C%s", x$oddHeader[[2]]),
sprintf("&R%s", x$oddHeader[[3]]),
"</oddHeader>",
collapse = ""
)
} else {
oddHeader <- NULL
}
if (length(x$oddFooter) > 0) {
oddFooter <- paste0(
"<oddFooter>",
sprintf("&L%s", x$oddFooter[[1]]),
sprintf("&C%s", x$oddFooter[[2]]),
sprintf("&R%s", x$oddFooter[[3]]),
"</oddFooter>",
collapse = ""
)
} else {
oddFooter <- NULL
}
## EVEN
if (length(x$evenHeader) > 0) {
evenHeader <- paste0(
"<evenHeader>",
sprintf("&L%s", x$evenHeader[[1]]),
sprintf("&C%s", x$evenHeader[[2]]),
sprintf("&R%s", x$evenHeader[[3]]),
"</evenHeader>",
collapse = ""
)
} else {
evenHeader <- NULL
}
if (length(x$evenFooter) > 0) {
evenFooter <- paste0(
"<evenFooter>",
sprintf("&L%s", x$evenFooter[[1]]),
sprintf("&C%s", x$evenFooter[[2]]),
sprintf("&R%s", x$evenFooter[[3]]),
"</evenFooter>",
collapse = ""
)
} else {
evenFooter <- NULL
}
## FIRST
if (length(x$firstHeader) > 0) {
firstHeader <- paste0(
"<firstHeader>",
sprintf("&L%s", x$firstHeader[[1]]),
sprintf("&C%s", x$firstHeader[[2]]),
sprintf("&R%s", x$firstHeader[[3]]),
"</firstHeader>",
collapse = ""
)
} else {
firstHeader <- NULL
}
if (length(x$firstFooter) > 0) {
firstFooter <- paste0(
"<firstFooter>",
sprintf("&L%s", x$firstFooter[[1]]),
sprintf("&C%s", x$firstFooter[[2]]),
sprintf("&R%s", x$firstFooter[[3]]),
"</firstFooter>",
collapse = ""
)
} else {
firstFooter <- NULL
}
headTag <- sprintf(
'<headerFooter differentOddEven="%s" differentFirst="%s" scaleWithDoc="0" alignWithMargins="0">',
as.integer(!(is.null(evenHeader) & is.null(evenFooter))),
as.integer(!(is.null(firstHeader) & is.null(firstFooter)))
)
paste0(
headTag,
oddHeader,
oddFooter,
evenHeader,
evenFooter,
firstHeader,
firstFooter,
"</headerFooter>"
)
}
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 <- "<definedName name=\"_xlnm._FilterDatabase\" localSheetId=\"0\" hidden=\"1\">'A & B < D > D'!$A$1:$A$10</definedName>"
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.integer(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")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.