R/write.R
In JanMarvin/openxlsx2: Read, Write and Edit 'xlsx' Files
Defines functions
do_write_datatable
do_write_formula
do_write_data
write_data_table
write_data2
update_cell
initialize_cell
inner_update
#' function to add missing cells to cc and rows
#'
#' Create a cell in the workbook
#'
#' @param wb the workbook update
#' @param sheet_id the sheet to update
#' @param x the newly filled cc frame
#' @param rows the rows needed
#' @param cells_needed the cells needed
#' @param colNames has colNames (only in update_cell)
#' @param removeCellStyle remove the cell style (only in update_cell)
#' @param na.strings Value used for replacing `NA` values from `x`. Default
#' `na_strings()` uses the special `#N/A` value within the workbook.
#' @keywords internal
#' @noRd
inner_update <- function(
wb,
sheet_id,
x,
rows,
cells_needed,
colNames = FALSE,
removeCellStyle = FALSE,
na.strings = na_strings()
) {
cells_needed <- cells_needed[cells_needed != ""]
if (length(cells_needed) == 0) return(wb)
# 1) pull sheet to modify from workbook; 2) modify it; 3) push it back
cc <- wb$worksheets[[sheet_id]]$sheet_data$cc
row_attr <- wb$worksheets[[sheet_id]]$sheet_data$row_attr
# workbooks contain only entries for values currently present.
# if A1 is filled, B1 is not filled and C1 is filled the sheet will only
# contain fields A1 and C1.
cells_in_wb <- cc$r
rows_in_wb <- row_attr$r
# check if there are rows not available
if (!all(rows %in% rows_in_wb)) {
# message("row(s) not in workbook")
missing_rows <- rows[!rows %in% rows_in_wb]
# new row_attr
row_attr_missing <- empty_row_attr(n = length(missing_rows))
row_attr_missing$r <- missing_rows
row_attr <- rbind(row_attr, row_attr_missing)
# order
row_attr <- row_attr[order(as.numeric(row_attr$r)), ]
wb$worksheets[[sheet_id]]$sheet_data$row_attr <- row_attr
# provide output
rows_in_wb <- row_attr$r
}
if (!all(cells_needed %in% cells_in_wb)) {
# message("cell(s) not in workbook")
missing_cells <- cells_needed[!cells_needed %in% cells_in_wb]
# create missing cells
cc_missing <- create_char_dataframe(names(cc), length(missing_cells))
cc_missing$r <- missing_cells
cc_missing$row_r <- gsub("[[:upper:]]", "", cc_missing$r)
cc_missing$c_r <- gsub("[[:digit:]]", "", cc_missing$r)
# assign to cc
cc <- rbind(cc, cc_missing)
# order cc (not really necessary, will be done when saving)
cc <- cc[order(as.integer(cc[, "row_r"]), col2int(cc[, "c_r"])), ]
# update dimensions (only required if new cols and rows are added) ------
all_rows <- as.numeric(unique(cc$row_r))
all_cols <- col2int(unique(cc$c_r))
min_cell <- trimws(paste0(int2col(min(all_cols, na.rm = TRUE)), min(all_rows, na.rm = TRUE)))
max_cell <- trimws(paste0(int2col(max(all_cols, na.rm = TRUE)), max(all_rows, na.rm = TRUE)))
# i know, i know, i'm lazy
wb$worksheets[[sheet_id]]$dimension <- paste0("<dimension ref=\"", min_cell, ":", max_cell, "\"/>")
}
if (is_na_strings(na.strings)) {
na.strings <- NULL
}
# prepare required columns
all_cols <- unique(names(x), names(cc))
if (any("c_cm" %in% all_cols)) has_cm <- "c_cm" else has_cm <- NULL
if (any("c_ph" %in% all_cols)) has_ph <- "c_ph" else has_ph <- NULL
if (any("c_vm" %in% all_cols)) has_vm <- "c_vm" else has_vm <- NULL
replacement <- c("r", "row_r", "c_r", "c_s", "c_t", has_cm, has_ph, has_vm,
"v", "f", "f_attr", "is")
if (removeCellStyle) {
# use c_s from cc
replacementX <- replacement
} else {
# use c_s from x
replacementX <- replacement[-which(replacement == "c_s")]
}
sel <- match(x$r, cc$r)
# to avoid bricking the worksheet, we make sure that we do not overwrite the
# reference cell of a shared formula. To be on the save side, we replace all
# values with the formula. If the entire cc is replaced with x, we can skip.
ff <- rbindlist(xml_attr(paste0("<f ", cc$f_attr, "/>"), "f"))
if (length(sf <- ff$si[sel & ff$t[sel] == "shared" & ff$ref[sel] != ""]) && !all(cc$r %in% x$r)) {
# collect all the shared formulas that we have to convert
sel_fsi <- ff$si %in% unique(sf)
cc_shared <- cc[sel_fsi, , drop = FALSE]
cc <- shared_as_fml(cc, cc_shared)
msg <- paste0(
"A shared formula reference cell was overwritten. To protect the",
" spreadsheet formulas, the impacted cells were converted from shared",
" formulas to normal formulas."
)
warning(msg, call. = FALSE)
}
# columns in cc and x can differ make sure that all elements are available
if (any(!replacement %in% names(x))) {
mss <- replacement[!replacement %in% names(x)]
for (ms in mss) x[ms] <- rep("", nrow(x))
x <- x[replacement]
}
if (any(!replacement %in% names(cc))) {
mss <- replacement[!replacement %in% names(cc)]
for (ms in mss) cc[ms] <- rep("", nrow(cc))
cc <- cc[replacement]
}
# c_s is either used from X or from cc
cc[sel, replacementX] <- x[replacementX]
# avoid missings in cc
if (anyNA(cc))
cc[is.na(cc)] <- ""
# push everything back to workbook
wb$worksheets[[sheet_id]]$sheet_data$cc <- cc
wb
}
#' Initialize data cell(s)
#'
#' Create a cell in the workbook
#'
#' @param wb the workbook you want to update
#' @param sheet the sheet you want to update
#' @param new_cells the cell you want to update in Excel connotation e.g. "A1"
#'
#' @keywords internal
#' @noRd
initialize_cell <- function(wb, sheet, new_cells) {
sheet_id <- wb$validate_sheet(sheet)
nms <- names(wb$worksheets[[sheet_id]]$sheet_data$cc)
# create artificial cc for the missing cells
x <- create_char_dataframe(n = length(new_cells), colnames = nms)
x$r <- new_cells
x$row_r <- gsub("[[:upper:]]", "", new_cells)
x$c_r <- gsub("[[:digit:]]", "", new_cells)
rows <- unique(x$row_r)
cells_needed <- new_cells
inner_update(wb, sheet_id, x, rows, cells_needed)
}
#' Replace data cell(s)
#'
#' Minimal invasive update of cell(s) inside of imported workbooks.
#'
#' @param x cc dataframe of the updated cells
#' @param wb the workbook you want to update
#' @param sheet the sheet you want to update
#' @param cell the cell you want to update in Excel connotation e.g. "A1"
#' @param colNames if TRUE colNames are passed down
#' @param removeCellStyle keep the cell style?
#' @param na.strings optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data)
#'
#' @keywords internal
#' @noRd
update_cell <- function(x, wb, sheet, cell, colNames = FALSE,
removeCellStyle = FALSE, na.strings) {
if (missing(na.strings))
na.strings <- substitute()
sheet_id <- wb$validate_sheet(sheet)
dims <- dims_to_dataframe(cell, fill = TRUE)
rows <- rownames(dims)
cells_needed <- unname(unlist(dims))
inner_update(wb, sheet_id, x, rows, cells_needed, colNames, removeCellStyle, na.strings)
}
#' dummy function to write data
#' @param wb workbook
#' @param sheet sheet
#' @param data data to export
#' @param name If not NULL, a named region is defined.
#' @param colNames include colnames?
#' @param rowNames include rownames?
#' @param startRow row to place it
#' @param startCol col to place it
#' @param applyCellStyle apply styles when writing on the sheet
#' @param removeCellStyle keep the cell style?
#' @param na.strings Value used for replacing `NA` values from `x`. Default
#' looks if `options(openxlsx2.na.strings)` is set. Otherwise [na_strings()]
#' uses the special `#N/A` value within the workbook.
#' @param data_table logical. if `TRUE` and `rowNames = TRUE`, do not write the cell containing `"_rowNames_"`
#' @param inline_strings write characters as inline strings
#' @param dims worksheet dimensions
#' @param enforce enforce dims
#' @param shared shared formula
#' @param sep the separator string used in collapse
#' @details
#' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame
#' contains this string, the output will be broken.
#'
#' @examples
#' # create a workbook and add some sheets
#' wb <- wb_workbook()
#'
#' wb$add_worksheet("sheet1")
#' write_data2(wb, "sheet1", mtcars, colNames = TRUE, rowNames = TRUE)
#'
#' wb$add_worksheet("sheet2")
#' write_data2(wb, "sheet2", cars, colNames = FALSE)
#'
#' wb$add_worksheet("sheet3")
#' write_data2(wb, "sheet3", letters)
#'
#' wb$add_worksheet("sheet4")
#' write_data2(wb, "sheet4", as.data.frame(Titanic), startRow = 2, startCol = 2)
#' @noRd
write_data2 <- function(
wb,
sheet,
data,
name = NULL,
colNames = TRUE,
rowNames = FALSE,
startRow = 1,
startCol = 1,
applyCellStyle = TRUE,
removeCellStyle = FALSE,
na.strings = na_strings(),
data_table = FALSE,
inline_strings = TRUE,
dims = NULL,
enforce = FALSE,
shared = FALSE,
sep = ", "
) {
dim_sep <- ";"
if (any(grepl(";|,", dims))) {
if (any(grepl(";", dims))) dim_sep <- ";"
if (any(grepl(",", dims))) dim_sep <- ","
}
is_data_frame <- FALSE
#### prepare the correct data formats for openxml
dc <- openxlsx2_type(data)
# convert factor to character
is_factor <- dc == openxlsx2_celltype[["factor"]]
if (any(is_factor)) {
fcts <- names(dc[is_factor])
data[fcts] <- lapply(data[fcts], to_string)
}
# convert list to character
is_list <- dc == openxlsx2_celltype[["list"]]
if (any(is_list)) {
lsts <- names(dc[is_list])
data[lsts] <- lapply(data[lsts], function(col) {
vapply(col, FUN = stringi::stri_join, collapse = sep, FUN.VALUE = NA_character_)
})
dc[is_list] <- openxlsx2_celltype[["character"]]
}
# remove xml encoding and reapply it afterwards. until v0.3 encoding was not enforced.
# until 1.1 formula encoding was applied in write_formula() and missed formulas written
# as data frames with class formula
is_fml <- dc %in% c(
openxlsx2_celltype[["formula"]], openxlsx2_celltype[["array_formula"]],
openxlsx2_celltype[["cm_formula"]], openxlsx2_celltype[["hyperlink"]]
)
if (any(is_fml)) {
fmls <- names(dc[is_fml])
data[fmls] <- lapply(
data[fmls],
function(val) {
val <- replaceXMLEntities(val)
# replace localized separators ";" used e.g. in German formulas must be ","
# otherwise the semicolon will interfere with the XML formulas
val <- gsub('(;)(?=(?:[^"\']*(["\'])[^"\']*\\2)*[^"\']*$)', ',', val, perl = TRUE)
vapply(val, function(x) xml_value(xml_node_create("fml", x, escapes = TRUE), "fml"), "")
}
)
}
hconvert_date1904 <- grepl('date1904="1"|date1904="true"',
stringi::stri_join(unlist(wb$workbook), collapse = ""),
ignore.case = TRUE)
# TODO need to tell excel that we have a date, apply some kind of numFmt
data <- convert_to_excel_date(df = data, date1904 = hconvert_date1904)
# backward compatible
if (!inherits(data, "data.frame") || inherits(data, "matrix")) {
data <- as.data.frame(data, stringsAsFactors = FALSE)
colNames <- FALSE
}
if (inherits(data, "data.frame") || inherits(data, "matrix")) {
is_data_frame <- TRUE
if (is.data.frame(data)) data <- as.data.frame(data, stringsAsFactors = FALSE)
sel <- !dc %in% c(4, 5, 10)
data[sel] <- lapply(data[sel], as.character)
# add rownames
if (rowNames) {
data <- cbind("_rowNames_" = rownames(data), data, stringsAsFactors = FALSE)
dc <- c(c("_rowNames_" = openxlsx2_celltype[["character"]]), dc)
}
if (nrow(data) == 0) applyCellStyle <- FALSE
# add colnames
if (colNames) {
# its quicker to convert data to character and append the colnames
# then to create a data frame from colnames, construct the required
# length and copy the converted to character data into it.
# data <- rbind(data, colnames(data))
# out <- c(nrow(data), seq_len(nrow(data))[-nrow(data)])
# data <- data[out, , drop = FALSE]
# this is painfully slow, but still somehow the fastest way.
data[nrow(data) + 1L, ] <- colnames(data)
data <- data[c(nrow(data), seq_len(nrow(data) - 1L)), , drop = FALSE]
}
}
sheetno <- wb_validate_sheet(wb, sheet)
# message("sheet no: ", sheetno)
# create a data frame
if (!is_data_frame) {
data <- as.data.frame(t(data), stringsAsFactors = FALSE)
}
# TODO fits_in_dims does not handle "A1,B2" and instead converts it to the
# outer range "A1:B2"
if (!enforce) {
dims <- fits_in_dims(x = data, dims = dims, startCol = startCol, startRow = startRow)
}
if (!is.null(attr(data, "f_ref"))) {
ref <- attr(data, "f_ref")
} else {
ref <- NULL
}
if (!is.null(attr(data, "c_cm"))) {
warning("modifications with cm formulas are experimental. use at own risk")
c_cm <- attr(data, "c_cm")
} else {
c_cm <- ""
}
# TODO writing defined name should handle global and local: localSheetId
# this requires access to wb$workbook.
# TODO The check for existing names is in write_data()
# TODO use wb$add_named_region()
if (!is.null(name) && !any(grepl(dim_sep, dims))) {
## named region
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.")
}
sheet_name <- wb$get_sheet_names(escape = TRUE)[[sheetno]]
if (grepl("[^A-Za-z0-9]", sheet_name)) sheet_name <- shQuote(sheet_name, "sh")
sheet_dim <- paste0(sheet_name, "!", dims)
def_name <- xml_node_create("definedName",
xml_children = sheet_dim,
xml_attributes = c(name = name))
wb$workbook$definedNames <- c(wb$workbook$definedNames, def_name)
}
# from here on only wb$worksheets is required
# rtyp character vector per row
# list(c("A1, ..., "k1"), ..., c("An", ..., "kn"))
rtyp <- dims_to_dataframe(dims, fill = enforce)
rows_attr <- vector("list", nrow(rtyp))
# create <rows ...>
want_rows <- as.integer(dims_to_rowcol(dims)[["row"]])
rows_attr <- empty_row_attr(n = length(want_rows))
# number of rows might differ
if (enforce) rows_attr <- empty_row_attr(n = nrow(rtyp))
rows_attr$r <- rownames(rtyp)
string_nums <- getOption("openxlsx2.string_nums", default = 0)
# original cc data frame
has_cm <- if (any(dc == openxlsx2_celltype[["cm_formula"]])) "c_cm" else NULL
has_typ <- if (string_nums) "typ" else NULL
nms <- c(
"r", "row_r", "c_r", "c_s", "c_t", has_cm,
"v", "f", "f_attr", "is", has_typ
)
cc <- create_char_dataframe(
colnames = nms,
n = nrow(data) * ncol(data)
)
sel <- which(dc == openxlsx2_celltype[["logical"]])
for (i in sel) {
if (colNames) {
data[-1, i] <- as.integer(as.logical(data[-1, i]))
} else {
data[, i] <- as.integer(as.logical(data[, i]))
}
}
sel <- which(dc == openxlsx2_celltype[["character"]] | dc == openxlsx2_celltype[["factor"]]) # character
if (length(sel)) {
data[sel][is.na(data[sel])] <- "_openxlsx_NA"
if (getOption("openxlsx2.force_utf8_encoding", default = FALSE)) {
from_enc <- getOption("openxlsx2.native_encoding")
data[sel] <- lapply(data[sel], stringi::stri_encode, from = from_enc, to = "UTF-8")
}
}
na_missing <- FALSE
na_null <- FALSE
if (is_na_strings(na.strings)) {
na.strings <- ""
na_missing <- TRUE
} else if (is.null(na.strings)) {
na.strings <- ""
na_null <- TRUE
}
if (enforce) {
clls <- lapply(unlist(strsplit(dims, dim_sep)), FUN = function(x) {
nc <- needed_cells(x)
len <- length(unique(col2int(nc)))
if (length(nc) > 1) {
matrix(nc, ncol = len, byrow = FALSE)
} else {
nc
}
})
clls <- do.call("rbind", clls)
clls <- c(clls)
} else {
clls <- paste0(colnames(rtyp[1, 1]), rownames(rtyp[1, 1]))
}
wide_to_long(
data,
dc,
cc,
ColNames = colNames,
start_col = startCol,
start_row = startRow,
refed = ref,
string_nums = string_nums,
na_null = na_null,
na_missing = na_missing,
na_strings = na.strings,
inline_strings = inline_strings,
c_cm = c_cm,
dims = clls
)
if (enforce) {
# this is required for the worksheet dimension spanning the entire
# initialized worksheet from top left to bottom right
dims <- dataframe_to_dims(rtyp, dim_break = FALSE)
}
# if rownames = TRUE and data_table = FALSE, remove "_rownames_"
if (!data_table && rowNames && colNames) {
cc <- cc[cc$r != paste0(names(rtyp)[1], rownames(rtyp)[1]), ]
}
if (shared) {
# This cc contains only the formula range.
## the top left cell is the reference
## all have shared and all share the same f_si
## only the reference cell has a formula
## only the reference cell has the formula reference
uni_attrs <- unique(wb$worksheets[[sheetno]]$sheet_data$cc$f_attr)
f_xml <- paste0("<f ", uni_attrs, "/>")
uni_si <- unique(rbindlist(xml_attr(f_xml, "f"))$si)
int_si <- as.integer(
replace(
uni_si,
uni_si == "",
"-1"
)
)
int_si <- max(int_si, -1L) + 1L
cc[["f_attr"]] <- sprintf("t=\"%s\"", "shared")
cc[1, "f_attr"] <- paste(cc[1, "f_attr"], sprintf("ref=\"%s\"", dims))
cc[["f_attr"]] <- paste(cc[["f_attr"]], sprintf("si=\"%s\"", int_si))
cc[2:nrow(cc), "f"] <- ""
}
if (is.null(wb$worksheets[[sheetno]]$sheet_data$cc)) {
# message("write_cell()")
wb$worksheets[[sheetno]]$dimension <- paste0("<dimension ref=\"", dims, "\"/>")
wb$worksheets[[sheetno]]$sheet_data$row_attr <- rows_attr
wb$worksheets[[sheetno]]$sheet_data$cc <- cc
} else {
# update cell(s)
# message("update_cell()")
wb <- update_cell(
x = cc,
wb = wb,
sheet = sheetno,
cell = dims,
colNames = colNames,
removeCellStyle = removeCellStyle,
na.strings = na.strings
)
}
### Begin styles
if (applyCellStyle) {
## create a cell style format for specific types at the end of the existing
# styles. gets the reference an passes it on.
get_data_class_dims <- function(data_class) {
sel <- dc == openxlsx2_celltype[[data_class]]
# sel = TRUE
sel_cols <- names(rtyp[sel])
sel_rows <- rownames(rtyp)
# ignore first row if colNames
if (colNames) sel_rows <- sel_rows[-1]
dataframe_to_dims(rtyp[rownames(rtyp) %in% sel_rows, sel_cols, drop = FALSE])
}
# if hyperlinks are found, Excel sets something like the following font
# blue with underline
if (any(dc == openxlsx2_celltype[["hyperlink"]])) {
dim_sel <- get_data_class_dims("hyperlink")
# message("hyperlink: ", dim_sel)
# get hyperlink color from template
if (is.null(wb$theme)) {
has_hlink <- 11
} else {
clrs <- xml_node(wb$theme, "a:theme", "a:themeElements", "a:clrScheme")
has_hlink <- which(xml_node_name(clrs, "a:clrScheme") == "a:hlink")
}
if (has_hlink) {
hyperlink_col <- wb_color(theme = has_hlink - 1L)
} else {
hyperlink_col <- wb_color(hex = "FF0000FF")
}
wb$add_font(
sheet = sheetno,
dims = dim_sel,
color = hyperlink_col,
name = wb$get_base_font()$name$val,
size = wb$get_base_font()$size$val,
underline = "single"
)
}
if (any(dc == openxlsx2_celltype[["character"]])) {
if (any(sel <- cc$typ == openxlsx2_celltype[["string_nums"]])) {
# # we cannot select every cell like this, because it is terribly slow.
# dim_sel <- paste0(cc$r[sel], collapse = ";")
dim_sel <- get_data_class_dims("character")
# message("character: ", dim_sel)
wb$add_cell_style(
sheet = sheetno,
dims = dim_sel,
applyNumberFormat = "1",
quotePrefix = "1",
numFmtId = "49"
)
cc$typ <- NULL
}
}
# options("openxlsx2.numFmt" = NULL)
if (any(dc == openxlsx2_celltype[["numeric"]])) { # numeric or integer
if (!is.null(getOption("openxlsx2.numFmt"))) {
numfmt_numeric <- getOption("openxlsx2.numFmt")
dim_sel <- get_data_class_dims("numeric")
# message("numeric: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_numeric
)
}
}
if (any(dc == openxlsx2_celltype[["short_date"]])) { # Date
numfmt_dt <- getOption("openxlsx2.dateFormat", 14)
dim_sel <- get_data_class_dims("short_date")
# message("short_date: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_dt
)
}
if (any(dc == openxlsx2_celltype[["long_date"]])) {
numfmt_posix <- getOption("openxlsx2.datetimeFormat", default = 22)
dim_sel <- get_data_class_dims("long_date")
# message("long_date: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_posix
)
}
if (any(dc == openxlsx2_celltype[["hms_time"]])) {
numfmt_hms <- getOption("openxlsx2.hmsFormat", default = 21)
dim_sel <- get_data_class_dims("hms_time")
# message("hms: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_hms
)
}
if (any(dc == openxlsx2_celltype[["currency"]])) { # currency
numfmt_currency <- getOption("openxlsx2.currencyFormat", default = 44)
## For vignette: Builtin style for USD
#"_-[$$-409]* #,##0.00_ ;_-[$$-409]* \\-#,##0.00\\ ;_-[$$-409]* "-"??_ ;_-@_ "
dim_sel <- get_data_class_dims("currency")
# message("currency: ", dim_sel)
wb$add_numfmt(
dims = dim_sel,
numfmt = numfmt_currency
)
}
if (any(dc == openxlsx2_celltype[["accounting"]])) { # accounting
numfmt_accounting <- getOption("openxlsx2.accountingFormat", default = 4)
dim_sel <- get_data_class_dims("accounting")
# message("accounting: ", dim_sel)
wb$add_numfmt(
dims = dim_sel,
numfmt = numfmt_accounting
)
}
if (any(dc == openxlsx2_celltype[["percentage"]])) { # percentage
numfmt_percentage <- getOption("openxlsx2.percentageFormat", default = 10)
dim_sel <- get_data_class_dims("percentage")
# message("percentage: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_percentage
)
}
if (any(dc == openxlsx2_celltype[["scientific"]])) {
numfmt_scientific <- getOption("openxlsx2.scientificFormat", default = 48)
dim_sel <- get_data_class_dims("scientific")
# message("scientific: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_scientific
)
}
if (any(dc == openxlsx2_celltype[["comma"]])) {
numfmt_comma <- getOption("openxlsx2.commaFormat", default = 3)
dim_sel <- get_data_class_dims("comma")
# message("comma: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_comma
)
}
}
### End styles
# update shared strings if we use shared strings
if (!inline_strings) {
cc <- wb$worksheets[[sheetno]]$sheet_data$cc
sel <- grepl("<si>", cc$v)
cc_sst <- stringi::stri_unique(cc[sel, "v"])
wb$sharedStrings <- stringi::stri_unique(c(wb$sharedStrings, cc_sst))
sel <- grepl("<si>", cc$v)
cc$v[sel] <- as.character(match(cc$v[sel], wb$sharedStrings) - 1L)
text <- si_to_txt(wb$sharedStrings)
uniqueCount <- length(wb$sharedStrings)
attr(wb$sharedStrings, "uniqueCount") <- uniqueCount
attr(wb$sharedStrings, "text") <- text
wb$worksheets[[sheetno]]$sheet_data$cc <- cc
if (!any(grepl("sharedStrings", wb$workbook.xml.rels))) {
wb$append(
"workbook.xml.rels",
"<Relationship Id=\"rId1\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings\" Target=\"sharedStrings.xml\"/>"
)
}
}
### Update calcChain
if (length(wb$calcChain)) {
# if we overwrite a formula cell in the calculation chain, we have to update it
# At the moment we simply remove it from the calculation chain, in the future
# we might want to keep it if we write a formula.
xml <- wb$calcChain
calcChainR <- rbindlist(xml_attr(xml, "calcChain", "c"))
# according to the documentation there can be cases, without the sheetno reference
sel <- calcChainR$r %in% wb$worksheets[[sheetno]]$sheet_data$cc$r & calcChainR$i == sheetno
rmCalcChain <- as.integer(rownames(calcChainR[sel, , drop = FALSE]))
if (length(rmCalcChain)) {
xml <- xml_rm_child(xml, xml_child = "c", which = rmCalcChain)
# xml can not be empty, otherwise excel will complain. If xml is empty, remove all
# calcChain references from the workbook
if (length(xml_node_name(xml, "calcChain")) == 0) {
wb$Content_Types <- wb$Content_Types[-grep("/xl/calcChain", wb$Content_Types)]
wb$workbook.xml.rels <- wb$workbook.xml.rels[-grep("calcChain.xml", wb$workbook.xml.rels)]
wb$worksheets[[sheetno]]$sheetCalcPr <- character()
xml <- character()
}
wb$calcChain <- xml
}
}
### End update calcChain
return(wb)
}
# `write_data_table()` ---------------------------------------------------------
# `write_data_table()` an internal driver function to `write_data` and `write_data_table` ----
#' Write to a worksheet as an Excel table
#'
#' Write to a worksheet and format as an Excel table
#'
#' @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 data frame.
#' @param startCol A vector specifying the starting column to write df
#' @param startRow A vector specifying the starting row to write df
#' @param dims Spreadsheet dimensions that will determine startCol and startRow: "A1", "A1:B2", "A:B"
#' @param array A bool if the function written is of type array
#' @param colNames If `TRUE`, column names of x are written.
#' @param rowNames If `TRUE`, row names of x are written.
#' @param tableStyle Any excel table style name or "none" (see "formatting" vignette).
#' @param tableName name of table in workbook. The table name must be unique.
#' @param withFilter If `TRUE`, columns with have filters in the first row.
#' @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).
#' @param firstColumn logical. If TRUE, the first column is bold
#' @param lastColumn logical. If TRUE, the last column is bold
#' @param bandedRows logical. If TRUE, rows are color banded
#' @param bandedCols logical. If TRUE, the columns are color banded
#' @param bandedCols logical. If TRUE, a data table is created
#' @param name If not NULL, a named region is defined.
#' @param applyCellStyle apply styles when writing on the sheet
#' @param removeCellStyle if writing into existing cells, should the cell style be removed?
#' @param na.strings Value used for replacing `NA` values from `x`. Default
#' looks if `options(openxlsx2.na.strings)` is set. Otherwise [na_strings()]
#' uses the special `#N/A` value within the workbook.
#' @param inline_strings optional write strings as inline strings
#' @param total_row optional write total rows
#' @param shared shared formula
#' @noRd
#' @keywords internal
write_data_table <- function(
wb,
sheet,
x,
startCol = 1,
startRow = 1,
dims,
array = FALSE,
colNames = TRUE,
rowNames = FALSE,
tableStyle = "TableStyleLight9",
tableName = NULL,
withFilter = TRUE,
sep = ", ",
firstColumn = FALSE,
lastColumn = FALSE,
bandedRows = TRUE,
bandedCols = FALSE,
name = NULL,
applyCellStyle = TRUE,
removeCellStyle = FALSE,
data_table = FALSE,
na.strings = na_strings(),
inline_strings = TRUE,
total_row = FALSE,
enforce = FALSE,
shared = FALSE
) {
## Input validating
assert_workbook(wb)
assert_class(colNames, "logical")
assert_class(rowNames, "logical")
assert_class(withFilter, "logical")
if (data_table) assert_class(x, "data.frame")
assert_class(firstColumn, "logical")
assert_class(lastColumn, "logical")
assert_class(bandedRows, "logical")
assert_class(bandedCols, "logical")
# force with globalenv() options
x <- force(x)
op <- default_save_opt()
on.exit(options(op), add = TRUE)
odims <- dims
if (!is.null(dims)) {
dims <- dims_to_rowcol(dims, as_integer = TRUE)
# if dims = "K1,A1" startCol = "A" and startRow = "1" are selected
startCol <- min(dims[["col"]])
startRow <- min(dims[["row"]])
}
# avoid stoi error with NULL
if (is.null(x)) {
return(wb)
}
# overwrite na.strings if nothing was provided
# with whatever is in the option if not set to default
if (is_na_strings(na.strings) && !is.null(getOption("openxlsx2.na.strings"))) {
na.strings <- getOption("openxlsx2.na.strings")
}
if (data_table) {
if (nrow(x) < 1) {
warning("Found data table with zero rows, adding one.",
" Modify na with na.strings")
x[1, ] <- NA
}
if (any(duplicated(tolower(colnames(x))))) {
warning("tables cannot have duplicated column names")
colnames(x) <- fix_pt_names(colnames(x))
}
}
## common part ---------------------------------------------------------------
if ((!is.character(sep)) || (length(sep) != 1))
stop("sep must be a character vector of length 1")
# TODO clean up when moved into wbWorkbook
sheet <- wb$.__enclos_env__$private$get_sheet_index(sheet)
# sheet <- wb$validate_sheet(sheet)
if (wb$is_chartsheet[[sheet]]) stop("Cannot write to chart sheet.")
## convert startRow and startCol
if (!is.numeric(startCol)) {
startCol <- col2int(startCol)
}
startRow <- as.integer(startRow)
## special case - vector of hyperlinks
# TODO: replace the =HYPERLINK() with the relship hyperlinks
is_hyperlink <- FALSE
if (applyCellStyle) {
if (is.null(dim(x))) {
is_hyperlink <- inherits(x, "hyperlink")
} else if (is.data.frame(x)) { # dont check on a matrix
is_hyperlink <- vapply(x, inherits, what = "hyperlink", FALSE)
}
if (any(is_hyperlink)) {
# consider wbHyperlink?
# hlinkNames <- names(x)
if (is.null(dim(x))) {
colNames <- FALSE
if (!any(grepl("=([\\s]*?)HYPERLINK\\(", x[is_hyperlink], perl = TRUE))) {
if (length(names(x))) {
x[is_hyperlink] <- create_hyperlink(text = names(x[is_hyperlink]), file = x[is_hyperlink])
} else {
x[is_hyperlink] <- create_hyperlink(text = x[is_hyperlink])
}
}
class(x[is_hyperlink]) <- c("character", "hyperlink")
} else {
# workaround for tibbles that break with the class assignment below
if (inherits(x, "tbl_df")) x <- as.data.frame(x, stringsAsFactors = FALSE)
# check should be in create_hyperlink and that apply should not be required either
if (!any(grepl("=([\\s]*?)HYPERLINK\\(", x[is_hyperlink], perl = TRUE))) {
x[is_hyperlink] <- apply(
x[is_hyperlink], 1,
FUN = function(str) create_hyperlink(text = str)
)
}
class(x[, is_hyperlink]) <- c("character", "hyperlink")
}
}
}
### Create data frame --------------------------------------------------------
transpose <- FALSE
# do not transpose if input is a matrix or a data frame. assuming that such input
# is already transposed as required.
if (length(dims[[1]]) > length(dims[[2]]) &&
!inherits(x, "matrix") && !inherits(x, "data.frame"))
transpose <- TRUE
## special case - formula
# only for data frame case where a data frame is passed down containing formulas
if (inherits(x, "formula")) {
x <- data.frame("X" = x, stringsAsFactors = FALSE)
class(x[[1]]) <- if (array) "array_formula" else "formula"
colNames <- FALSE
if (transpose) x <- transpose_df(x)
}
if (is.vector(x) || is.factor(x) || inherits(x, "Date") || inherits(x, "POSIXt") || inherits(x, "character")) {
colNames <- FALSE
} ## this will go to coerce.default and rowNames will be ignored
## Coerce to data.frame
if (inherits(x, "hyperlink")) {
## vector of hyperlinks
class(x) <- c("character", "hyperlink")
x <- as.data.frame(x, stringsAsFactors = FALSE)
if (transpose) x <- transpose_df(x)
# colNames <- FALSE
} else if (!inherits(x, "data.frame")) {
x <- as.data.frame(x, stringsAsFactors = FALSE)
if (transpose) x <- transpose_df(x)
# colNames <- FALSE
}
nCol <- ncol(x)
nRow <- nrow(x)
### Beg: Only in data --------------------------------------------------------
if (!data_table) {
## write autoFilter, can only have a single filter per worksheet
if (withFilter) { # TODO: replace ref calculation with wb_dims()
coords <- data.frame("x" = c(startRow, startRow + nRow + colNames - 1L), "y" = c(startCol, startCol + nCol - 1L), stringsAsFactors = FALSE)
ref <- stringi::stri_join(get_cell_refs(coords), collapse = ":")
wb$worksheets[[sheet]]$autoFilter <- sprintf('<autoFilter ref="%s"/>', ref)
l <- int2col(unlist(coords[, 2]))
dfn <- sprintf("'%s'!%s", wb$get_sheet_names(escape = TRUE)[sheet], stringi::stri_join("$", l, "$", coords[, 1], collapse = ":"))
dn <- sprintf('<definedName name="_xlnm._FilterDatabase" localSheetId="%s" hidden="1">%s</definedName>', sheet - 1L, dfn)
if (!is.null(wbdn <- wb$get_named_regions())) {
ind <- wbdn$name == "_xlnm._FilterDatabase" & wbdn$localSheetId == sheet - 1L
if (any(ind)) {
wb$workbook$definedNames[ind] <- dn
} else {
wb$workbook$definedNames <- c(
wb$workbook$definedNames, dn
)
}
} else {
wb$workbook$definedNames <- dn
}
}
}
### End: Only in data --------------------------------------------------------
if (data_table) {
overwrite_nrows <- 1L
check_tab_head_only <- FALSE
error_msg <- "Cannot overwrite existing table with another table"
} else {
overwrite_nrows <- colNames
check_tab_head_only <- TRUE
error_msg <- "Cannot overwrite table headers. Avoid writing over the header row or see wb_get_tables() & wb_remove_tabless() to remove the table object."
}
## Check not overwriting existing table headers
wb_check_overwrite_tables(
wb = wb,
sheet = sheet,
new_rows = c(startRow, startRow + nRow - 1L + overwrite_nrows),
new_cols = c(startCol, startCol + nCol - 1L),
check_table_header_only = check_tab_head_only,
error_msg = error_msg
)
## actual driver, the rest should not create data used for writing
wb <- write_data2(
wb = wb,
sheet = sheet,
data = x,
name = name,
colNames = colNames,
rowNames = rowNames,
startRow = startRow,
startCol = startCol,
applyCellStyle = applyCellStyle,
removeCellStyle = removeCellStyle,
na.strings = na.strings,
data_table = data_table,
inline_strings = inline_strings,
dims = if (enforce) odims else dims,
enforce = enforce,
shared = shared,
sep = sep
)
### Beg: Only in datatable ---------------------------------------------------
# if rowNames is set, write_data2 has added a rowNames column to the sheet.
# This has to be handled in colnames and in ref.
if (data_table) {
## replace invalid XML characters
col_names <- replace_legal_chars(colnames(x))
if (rowNames) col_names <- c("_rowNames_", col_names)
## Table name validation
if (is.null(tableName)) {
tableName <- paste0("Table", last_table_id(wb) + 1L)
} else {
tableName <- wb_validate_table_name(wb, tableName)
}
## write total rows column. this is a formula and needs to be written separately
total_fml <- FALSE
total_lbl <- FALSE
if (!isFALSE(total_row)) {
total <- known_subtotal_funs(
x = x,
total = total_row,
table = tableName,
row_names = rowNames
)
total_row <- total[[1]]
total_fml <- total[[2]]
total_lbl <- total[[3]]
wb <- write_data2(
wb = wb,
sheet = sheet,
data = total_row,
name = name,
colNames = FALSE,
rowNames = FALSE,
startRow = startRow + nrow(x) + 1L,
startCol = startCol,
applyCellStyle = applyCellStyle,
removeCellStyle = removeCellStyle,
na.strings = na.strings,
data_table = data_table,
inline_strings = inline_strings,
dims = NULL,
enforce = FALSE,
sep = sep
)
}
## If 0 rows append a blank row
cstm_tableStyles <- wb$styles_mgr$tableStyle$name
validNames <- c("none", paste0("TableStyleLight", seq_len(21)), paste0("TableStyleMedium", seq_len(28)), paste0("TableStyleDark", seq_len(11)), cstm_tableStyles)
if (!tolower(tableStyle) %in% tolower(validNames)) {
stop("Invalid table style.")
} else {
tableStyle <- grep(paste0("^", tableStyle, "$"), validNames, ignore.case = TRUE, value = TRUE)
}
tableStyle <- tableStyle[!is.na(tableStyle)]
if (length(tableStyle) == 0) {
stop("Unknown table style.")
}
## If zero rows, append an empty row (prevent XML from corrupting)
if (nrow(x) == 0) {
x <- rbind(as.data.frame(x, stringsAsFactors = FALSE), matrix("", nrow = 1, ncol = nCol, dimnames = list(character(), colnames(x))))
names(x) <- colNames
}
ref1 <- paste0(int2col(startCol), startRow)
ref2 <- paste0(int2col(startCol + nCol - !rowNames), startRow + nRow)
ref <- paste(ref1, ref2, sep = ":")
## create table.xml and assign an id to worksheet tables
wb$buildTable(
sheet = sheet,
colNames = col_names,
ref = ref,
showColNames = colNames,
tableStyle = tableStyle,
tableName = tableName,
totalLabel = total_lbl,
withFilter = withFilter,
totalsRowCount = total_fml,
showFirstColumn = firstColumn,
showLastColumn = lastColumn,
showRowStripes = bandedRows,
showColumnStripes = bandedCols
)
}
### End: Only in datatable ---------------------------------------------------
return(wb)
}
# `do_write_data()` ---------------------------------------------------------------
do_write_data <- function(
wb,
sheet,
x,
dims = wb_dims(start_row, start_col),
start_col = 1,
start_row = 1,
array = FALSE,
col_names = TRUE,
row_names = FALSE,
with_filter = FALSE,
sep = ", ",
name = NULL,
apply_cell_style = TRUE,
remove_cell_style = FALSE,
na.strings = na_strings(),
inline_strings = TRUE,
enforce = FALSE,
shared = FALSE,
...
) {
standardize_case_names(...)
write_data_table(
wb = wb,
sheet = sheet,
x = x,
dims = dims,
startCol = start_col,
startRow = start_row,
array = array,
colNames = col_names,
rowNames = row_names,
tableStyle = NULL,
tableName = NULL,
withFilter = with_filter,
sep = sep,
firstColumn = FALSE,
lastColumn = FALSE,
bandedRows = FALSE,
bandedCols = FALSE,
name = name,
applyCellStyle = apply_cell_style,
removeCellStyle = remove_cell_style,
data_table = FALSE,
na.strings = na.strings,
inline_strings = inline_strings,
enforce = enforce,
shared = shared
)
}
# do_write_formula() -------------------------------------------
do_write_formula <- function(
wb,
sheet,
x,
dims = wb_dims(start_row, start_col),
start_col = 1,
start_row = 1,
array = FALSE,
cm = FALSE,
apply_cell_style = TRUE,
remove_cell_style = FALSE,
enforce = FALSE,
shared = FALSE,
name = NULL,
...
) {
standardize_case_names(...)
if (is.data.frame(x))
x <- unlist(x)
assert_class(x, "character")
x <- replace_waiver(x, wb = wb)
# detect array formulas
if (any(substr(x, 1, 1) == "{")) {
pattern <- "^\\{(.*)\\}$"
x <- gsub(pattern, "\\1", x)
array <- TRUE
}
if ((array || cm) && shared) stop("either array/cm or shared")
# we need to increase the data
if (shared) { # not sure if this applies to arrays as well
size <- dims_to_dataframe(dims)
x <- rep(x, ncol(size) * nrow(size))
}
if (is.null(dims)) {
dims <- wb_dims(start_row, start_col)
}
if ((array || cm) || enforce) {
dfx <- data.frame("X" = x, stringsAsFactors = FALSE)
} else {
# if dims a single cell and x > dfx, increase dfx
if (!grepl(":", dims) && (NROW(x) > 1 || NCOL(x) > 1)) {
dfx <- dims_to_dataframe(wb_dims(x = x, from_dims = dims))
} else {
dfx <- dims_to_dataframe(dims)
}
dfx[] <- x
}
formula <- "formula"
if (array) formula <- "array_formula"
if (cm) {
# need to set cell metadata in wb$metadata
if (is.null(wb$metadata)) {
wb$append("Content_Types", "<Override PartName=\"/xl/metadata.xml\" ContentType=\"application/vnd.openxmlformats-officedocument.spreadsheetml.sheetMetadata+xml\"/>")
wb$metadata <- # danger danger no clue what this means!
xml_node_create(
"metadata",
xml_attributes = c(
xmlns = "http://schemas.openxmlformats.org/spreadsheetml/2006/main",
"xmlns:xda" = "http://schemas.microsoft.com/office/spreadsheetml/2017/dynamicarray"
),
xml_children = read_xml(
"<metadataTypes count=\"1\">
<metadataType name=\"XLDAPR\" minSupportedVersion=\"120000\" copy=\"1\" pasteAll=\"1\" pasteValues=\"1\" merge=\"1\" splitFirst=\"1\" rowColShift=\"1\" clearFormats=\"1\" clearComments=\"1\" assign=\"1\" coerce=\"1\" cellMeta=\"1\"/>
</metadataTypes>
<futureMetadata name=\"XLDAPR\" count=\"1\">
<bk>
<extLst>
<ext uri=\"{bdbb8cdc-fa1e-496e-a857-3c3f30c029c3}\">
<xda:dynamicArrayProperties fDynamic=\"1\" fCollapsed=\"0\"/>
</ext>
</extLst>
</bk>
</futureMetadata>,
<cellMetadata/>",
pointer = FALSE
)
)
}
## TODO Not sure if there are more cases
# add new cell metadata record
cM <- xml_node(wb$metadata, "metadata", "cellMetadata")
cM <- xml_add_child(cM, xml_child = "<bk><rc t=\"1\" v=\"0\"/></bk>")
# we need to update count
cnt <- as_xml_attr(length(xml_node(cM, "cellMetadata", "bk")))
cM <- xml_attr_mod(cM, xml_attributes = c(count = cnt))
# remove current cellMetadata update new
wb$metadata <- xml_rm_child(wb$metadata, "cellMetadata")
wb$metadata <- xml_add_child(wb$metadata, cM)
attr(dfx, "c_cm") <- cnt
formula <- "cm_formula"
}
# class(dfx$X) <- c(formula, "character")
for (i in seq_along(dfx)) {
class(dfx[[i]]) <- c(formula, "character")
}
if (any(grepl("=([\\s]*?)HYPERLINK\\(", x, perl = TRUE))) {
# class(dfx$X) <- c("character", "formula", "hyperlink")
# TODO does not handle mixed types
for (i in seq_along(dfx)) {
class(dfx[[i]]) <- c("character", "formula", "hyperlink")
}
}
# transpose match write_data_table
if ((array || cm) || enforce) {
rc <- dims_to_rowcol(dims)
if (length(rc[["col"]]) > length(rc[["row"]])) {
dfx <- transpose_df(dfx)
}
}
if (array || cm) {
if (length(dfx$X) == 1) {
attr(dfx, "f_ref") <- dims
}
}
do_write_data(
wb = wb,
sheet = sheet,
x = dfx,
start_col = start_col,
start_row = start_row,
dims = dims,
array = array,
col_names = FALSE,
row_names = FALSE,
name = name,
apply_cell_style = apply_cell_style,
remove_cell_style = remove_cell_style,
enforce = enforce,
shared = shared
)
}
# `do_write_datatable()` ----------------------
do_write_datatable <- function(
wb,
sheet,
x,
dims = wb_dims(start_row, start_col),
start_col = 1,
start_row = 1,
col_names = TRUE,
row_names = FALSE,
table_style = "TableStyleLight9",
table_name = NULL,
with_filter = TRUE,
sep = ", ",
first_column = FALSE,
last_column = FALSE,
banded_rows = TRUE,
banded_cols = FALSE,
apply_cell_style = TRUE,
remove_cell_style = FALSE,
na.strings = na_strings(),
inline_strings = TRUE,
total_row = FALSE,
shared = FALSE,
...
) {
standardize_case_names(...)
write_data_table(
wb = wb,
sheet = sheet,
x = x,
startCol = start_col,
startRow = start_row,
dims = dims,
array = FALSE,
colNames = col_names,
rowNames = row_names,
tableStyle = table_style,
tableName = table_name,
withFilter = with_filter,
sep = sep,
firstColumn = first_column,
lastColumn = last_column,
bandedRows = banded_rows,
bandedCols = banded_cols,
name = NULL,
data_table = TRUE,
applyCellStyle = apply_cell_style,
removeCellStyle = remove_cell_style,
na.strings = na.strings,
inline_strings = inline_strings,
total_row = total_row,
shared = shared
)
}
JanMarvin/openxlsx2 documentation built on April 17, 2025, 6:12 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions do_write_datatable do_write_formula do_write_data write_data_table write_data2 update_cell initialize_cell inner_update
#' function to add missing cells to cc and rows
#'
#' Create a cell in the workbook
#'
#' @param wb the workbook update
#' @param sheet_id the sheet to update
#' @param x the newly filled cc frame
#' @param rows the rows needed
#' @param cells_needed the cells needed
#' @param colNames has colNames (only in update_cell)
#' @param removeCellStyle remove the cell style (only in update_cell)
#' @param na.strings Value used for replacing `NA` values from `x`. Default
#' `na_strings()` uses the special `#N/A` value within the workbook.
#' @keywords internal
#' @noRd
inner_update <- function(
wb,
sheet_id,
x,
rows,
cells_needed,
colNames = FALSE,
removeCellStyle = FALSE,
na.strings = na_strings()
) {
cells_needed <- cells_needed[cells_needed != ""]
if (length(cells_needed) == 0) return(wb)
# 1) pull sheet to modify from workbook; 2) modify it; 3) push it back
cc <- wb$worksheets[[sheet_id]]$sheet_data$cc
row_attr <- wb$worksheets[[sheet_id]]$sheet_data$row_attr
# workbooks contain only entries for values currently present.
# if A1 is filled, B1 is not filled and C1 is filled the sheet will only
# contain fields A1 and C1.
cells_in_wb <- cc$r
rows_in_wb <- row_attr$r
# check if there are rows not available
if (!all(rows %in% rows_in_wb)) {
# message("row(s) not in workbook")
missing_rows <- rows[!rows %in% rows_in_wb]
# new row_attr
row_attr_missing <- empty_row_attr(n = length(missing_rows))
row_attr_missing$r <- missing_rows
row_attr <- rbind(row_attr, row_attr_missing)
# order
row_attr <- row_attr[order(as.numeric(row_attr$r)), ]
wb$worksheets[[sheet_id]]$sheet_data$row_attr <- row_attr
# provide output
rows_in_wb <- row_attr$r
}
if (!all(cells_needed %in% cells_in_wb)) {
# message("cell(s) not in workbook")
missing_cells <- cells_needed[!cells_needed %in% cells_in_wb]
# create missing cells
cc_missing <- create_char_dataframe(names(cc), length(missing_cells))
cc_missing$r <- missing_cells
cc_missing$row_r <- gsub("[[:upper:]]", "", cc_missing$r)
cc_missing$c_r <- gsub("[[:digit:]]", "", cc_missing$r)
# assign to cc
cc <- rbind(cc, cc_missing)
# order cc (not really necessary, will be done when saving)
cc <- cc[order(as.integer(cc[, "row_r"]), col2int(cc[, "c_r"])), ]
# update dimensions (only required if new cols and rows are added) ------
all_rows <- as.numeric(unique(cc$row_r))
all_cols <- col2int(unique(cc$c_r))
min_cell <- trimws(paste0(int2col(min(all_cols, na.rm = TRUE)), min(all_rows, na.rm = TRUE)))
max_cell <- trimws(paste0(int2col(max(all_cols, na.rm = TRUE)), max(all_rows, na.rm = TRUE)))
# i know, i know, i'm lazy
wb$worksheets[[sheet_id]]$dimension <- paste0("<dimension ref=\"", min_cell, ":", max_cell, "\"/>")
}
if (is_na_strings(na.strings)) {
na.strings <- NULL
}
# prepare required columns
all_cols <- unique(names(x), names(cc))
if (any("c_cm" %in% all_cols)) has_cm <- "c_cm" else has_cm <- NULL
if (any("c_ph" %in% all_cols)) has_ph <- "c_ph" else has_ph <- NULL
if (any("c_vm" %in% all_cols)) has_vm <- "c_vm" else has_vm <- NULL
replacement <- c("r", "row_r", "c_r", "c_s", "c_t", has_cm, has_ph, has_vm,
"v", "f", "f_attr", "is")
if (removeCellStyle) {
# use c_s from cc
replacementX <- replacement
} else {
# use c_s from x
replacementX <- replacement[-which(replacement == "c_s")]
}
sel <- match(x$r, cc$r)
# to avoid bricking the worksheet, we make sure that we do not overwrite the
# reference cell of a shared formula. To be on the save side, we replace all
# values with the formula. If the entire cc is replaced with x, we can skip.
ff <- rbindlist(xml_attr(paste0("<f ", cc$f_attr, "/>"), "f"))
if (length(sf <- ff$si[sel & ff$t[sel] == "shared" & ff$ref[sel] != ""]) && !all(cc$r %in% x$r)) {
# collect all the shared formulas that we have to convert
sel_fsi <- ff$si %in% unique(sf)
cc_shared <- cc[sel_fsi, , drop = FALSE]
cc <- shared_as_fml(cc, cc_shared)
msg <- paste0(
"A shared formula reference cell was overwritten. To protect the",
" spreadsheet formulas, the impacted cells were converted from shared",
" formulas to normal formulas."
)
warning(msg, call. = FALSE)
}
# columns in cc and x can differ make sure that all elements are available
if (any(!replacement %in% names(x))) {
mss <- replacement[!replacement %in% names(x)]
for (ms in mss) x[ms] <- rep("", nrow(x))
x <- x[replacement]
}
if (any(!replacement %in% names(cc))) {
mss <- replacement[!replacement %in% names(cc)]
for (ms in mss) cc[ms] <- rep("", nrow(cc))
cc <- cc[replacement]
}
# c_s is either used from X or from cc
cc[sel, replacementX] <- x[replacementX]
# avoid missings in cc
if (anyNA(cc))
cc[is.na(cc)] <- ""
# push everything back to workbook
wb$worksheets[[sheet_id]]$sheet_data$cc <- cc
wb
}
#' Initialize data cell(s)
#'
#' Create a cell in the workbook
#'
#' @param wb the workbook you want to update
#' @param sheet the sheet you want to update
#' @param new_cells the cell you want to update in Excel connotation e.g. "A1"
#'
#' @keywords internal
#' @noRd
initialize_cell <- function(wb, sheet, new_cells) {
sheet_id <- wb$validate_sheet(sheet)
nms <- names(wb$worksheets[[sheet_id]]$sheet_data$cc)
# create artificial cc for the missing cells
x <- create_char_dataframe(n = length(new_cells), colnames = nms)
x$r <- new_cells
x$row_r <- gsub("[[:upper:]]", "", new_cells)
x$c_r <- gsub("[[:digit:]]", "", new_cells)
rows <- unique(x$row_r)
cells_needed <- new_cells
inner_update(wb, sheet_id, x, rows, cells_needed)
}
#' Replace data cell(s)
#'
#' Minimal invasive update of cell(s) inside of imported workbooks.
#'
#' @param x cc dataframe of the updated cells
#' @param wb the workbook you want to update
#' @param sheet the sheet you want to update
#' @param cell the cell you want to update in Excel connotation e.g. "A1"
#' @param colNames if TRUE colNames are passed down
#' @param removeCellStyle keep the cell style?
#' @param na.strings optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data)
#'
#' @keywords internal
#' @noRd
update_cell <- function(x, wb, sheet, cell, colNames = FALSE,
removeCellStyle = FALSE, na.strings) {
if (missing(na.strings))
na.strings <- substitute()
sheet_id <- wb$validate_sheet(sheet)
dims <- dims_to_dataframe(cell, fill = TRUE)
rows <- rownames(dims)
cells_needed <- unname(unlist(dims))
inner_update(wb, sheet_id, x, rows, cells_needed, colNames, removeCellStyle, na.strings)
}
#' dummy function to write data
#' @param wb workbook
#' @param sheet sheet
#' @param data data to export
#' @param name If not NULL, a named region is defined.
#' @param colNames include colnames?
#' @param rowNames include rownames?
#' @param startRow row to place it
#' @param startCol col to place it
#' @param applyCellStyle apply styles when writing on the sheet
#' @param removeCellStyle keep the cell style?
#' @param na.strings Value used for replacing `NA` values from `x`. Default
#' looks if `options(openxlsx2.na.strings)` is set. Otherwise [na_strings()]
#' uses the special `#N/A` value within the workbook.
#' @param data_table logical. if `TRUE` and `rowNames = TRUE`, do not write the cell containing `"_rowNames_"`
#' @param inline_strings write characters as inline strings
#' @param dims worksheet dimensions
#' @param enforce enforce dims
#' @param shared shared formula
#' @param sep the separator string used in collapse
#' @details
#' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame
#' contains this string, the output will be broken.
#'
#' @examples
#' # create a workbook and add some sheets
#' wb <- wb_workbook()
#'
#' wb$add_worksheet("sheet1")
#' write_data2(wb, "sheet1", mtcars, colNames = TRUE, rowNames = TRUE)
#'
#' wb$add_worksheet("sheet2")
#' write_data2(wb, "sheet2", cars, colNames = FALSE)
#'
#' wb$add_worksheet("sheet3")
#' write_data2(wb, "sheet3", letters)
#'
#' wb$add_worksheet("sheet4")
#' write_data2(wb, "sheet4", as.data.frame(Titanic), startRow = 2, startCol = 2)
#' @noRd
write_data2 <- function(
wb,
sheet,
data,
name = NULL,
colNames = TRUE,
rowNames = FALSE,
startRow = 1,
startCol = 1,
applyCellStyle = TRUE,
removeCellStyle = FALSE,
na.strings = na_strings(),
data_table = FALSE,
inline_strings = TRUE,
dims = NULL,
enforce = FALSE,
shared = FALSE,
sep = ", "
) {
dim_sep <- ";"
if (any(grepl(";|,", dims))) {
if (any(grepl(";", dims))) dim_sep <- ";"
if (any(grepl(",", dims))) dim_sep <- ","
}
is_data_frame <- FALSE
#### prepare the correct data formats for openxml
dc <- openxlsx2_type(data)
# convert factor to character
is_factor <- dc == openxlsx2_celltype[["factor"]]
if (any(is_factor)) {
fcts <- names(dc[is_factor])
data[fcts] <- lapply(data[fcts], to_string)
}
# convert list to character
is_list <- dc == openxlsx2_celltype[["list"]]
if (any(is_list)) {
lsts <- names(dc[is_list])
data[lsts] <- lapply(data[lsts], function(col) {
vapply(col, FUN = stringi::stri_join, collapse = sep, FUN.VALUE = NA_character_)
})
dc[is_list] <- openxlsx2_celltype[["character"]]
}
# remove xml encoding and reapply it afterwards. until v0.3 encoding was not enforced.
# until 1.1 formula encoding was applied in write_formula() and missed formulas written
# as data frames with class formula
is_fml <- dc %in% c(
openxlsx2_celltype[["formula"]], openxlsx2_celltype[["array_formula"]],
openxlsx2_celltype[["cm_formula"]], openxlsx2_celltype[["hyperlink"]]
)
if (any(is_fml)) {
fmls <- names(dc[is_fml])
data[fmls] <- lapply(
data[fmls],
function(val) {
val <- replaceXMLEntities(val)
# replace localized separators ";" used e.g. in German formulas must be ","
# otherwise the semicolon will interfere with the XML formulas
val <- gsub('(;)(?=(?:[^"\']*(["\'])[^"\']*\\2)*[^"\']*$)', ',', val, perl = TRUE)
vapply(val, function(x) xml_value(xml_node_create("fml", x, escapes = TRUE), "fml"), "")
}
)
}
hconvert_date1904 <- grepl('date1904="1"|date1904="true"',
stringi::stri_join(unlist(wb$workbook), collapse = ""),
ignore.case = TRUE)
# TODO need to tell excel that we have a date, apply some kind of numFmt
data <- convert_to_excel_date(df = data, date1904 = hconvert_date1904)
# backward compatible
if (!inherits(data, "data.frame") || inherits(data, "matrix")) {
data <- as.data.frame(data, stringsAsFactors = FALSE)
colNames <- FALSE
}
if (inherits(data, "data.frame") || inherits(data, "matrix")) {
is_data_frame <- TRUE
if (is.data.frame(data)) data <- as.data.frame(data, stringsAsFactors = FALSE)
sel <- !dc %in% c(4, 5, 10)
data[sel] <- lapply(data[sel], as.character)
# add rownames
if (rowNames) {
data <- cbind("_rowNames_" = rownames(data), data, stringsAsFactors = FALSE)
dc <- c(c("_rowNames_" = openxlsx2_celltype[["character"]]), dc)
}
if (nrow(data) == 0) applyCellStyle <- FALSE
# add colnames
if (colNames) {
# its quicker to convert data to character and append the colnames
# then to create a data frame from colnames, construct the required
# length and copy the converted to character data into it.
# data <- rbind(data, colnames(data))
# out <- c(nrow(data), seq_len(nrow(data))[-nrow(data)])
# data <- data[out, , drop = FALSE]
# this is painfully slow, but still somehow the fastest way.
data[nrow(data) + 1L, ] <- colnames(data)
data <- data[c(nrow(data), seq_len(nrow(data) - 1L)), , drop = FALSE]
}
}
sheetno <- wb_validate_sheet(wb, sheet)
# message("sheet no: ", sheetno)
# create a data frame
if (!is_data_frame) {
data <- as.data.frame(t(data), stringsAsFactors = FALSE)
}
# TODO fits_in_dims does not handle "A1,B2" and instead converts it to the
# outer range "A1:B2"
if (!enforce) {
dims <- fits_in_dims(x = data, dims = dims, startCol = startCol, startRow = startRow)
}
if (!is.null(attr(data, "f_ref"))) {
ref <- attr(data, "f_ref")
} else {
ref <- NULL
}
if (!is.null(attr(data, "c_cm"))) {
warning("modifications with cm formulas are experimental. use at own risk")
c_cm <- attr(data, "c_cm")
} else {
c_cm <- ""
}
# TODO writing defined name should handle global and local: localSheetId
# this requires access to wb$workbook.
# TODO The check for existing names is in write_data()
# TODO use wb$add_named_region()
if (!is.null(name) && !any(grepl(dim_sep, dims))) {
## named region
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.")
}
sheet_name <- wb$get_sheet_names(escape = TRUE)[[sheetno]]
if (grepl("[^A-Za-z0-9]", sheet_name)) sheet_name <- shQuote(sheet_name, "sh")
sheet_dim <- paste0(sheet_name, "!", dims)
def_name <- xml_node_create("definedName",
xml_children = sheet_dim,
xml_attributes = c(name = name))
wb$workbook$definedNames <- c(wb$workbook$definedNames, def_name)
}
# from here on only wb$worksheets is required
# rtyp character vector per row
# list(c("A1, ..., "k1"), ..., c("An", ..., "kn"))
rtyp <- dims_to_dataframe(dims, fill = enforce)
rows_attr <- vector("list", nrow(rtyp))
# create <rows ...>
want_rows <- as.integer(dims_to_rowcol(dims)[["row"]])
rows_attr <- empty_row_attr(n = length(want_rows))
# number of rows might differ
if (enforce) rows_attr <- empty_row_attr(n = nrow(rtyp))
rows_attr$r <- rownames(rtyp)
string_nums <- getOption("openxlsx2.string_nums", default = 0)
# original cc data frame
has_cm <- if (any(dc == openxlsx2_celltype[["cm_formula"]])) "c_cm" else NULL
has_typ <- if (string_nums) "typ" else NULL
nms <- c(
"r", "row_r", "c_r", "c_s", "c_t", has_cm,
"v", "f", "f_attr", "is", has_typ
)
cc <- create_char_dataframe(
colnames = nms,
n = nrow(data) * ncol(data)
)
sel <- which(dc == openxlsx2_celltype[["logical"]])
for (i in sel) {
if (colNames) {
data[-1, i] <- as.integer(as.logical(data[-1, i]))
} else {
data[, i] <- as.integer(as.logical(data[, i]))
}
}
sel <- which(dc == openxlsx2_celltype[["character"]] | dc == openxlsx2_celltype[["factor"]]) # character
if (length(sel)) {
data[sel][is.na(data[sel])] <- "_openxlsx_NA"
if (getOption("openxlsx2.force_utf8_encoding", default = FALSE)) {
from_enc <- getOption("openxlsx2.native_encoding")
data[sel] <- lapply(data[sel], stringi::stri_encode, from = from_enc, to = "UTF-8")
}
}
na_missing <- FALSE
na_null <- FALSE
if (is_na_strings(na.strings)) {
na.strings <- ""
na_missing <- TRUE
} else if (is.null(na.strings)) {
na.strings <- ""
na_null <- TRUE
}
if (enforce) {
clls <- lapply(unlist(strsplit(dims, dim_sep)), FUN = function(x) {
nc <- needed_cells(x)
len <- length(unique(col2int(nc)))
if (length(nc) > 1) {
matrix(nc, ncol = len, byrow = FALSE)
} else {
nc
}
})
clls <- do.call("rbind", clls)
clls <- c(clls)
} else {
clls <- paste0(colnames(rtyp[1, 1]), rownames(rtyp[1, 1]))
}
wide_to_long(
data,
dc,
cc,
ColNames = colNames,
start_col = startCol,
start_row = startRow,
refed = ref,
string_nums = string_nums,
na_null = na_null,
na_missing = na_missing,
na_strings = na.strings,
inline_strings = inline_strings,
c_cm = c_cm,
dims = clls
)
if (enforce) {
# this is required for the worksheet dimension spanning the entire
# initialized worksheet from top left to bottom right
dims <- dataframe_to_dims(rtyp, dim_break = FALSE)
}
# if rownames = TRUE and data_table = FALSE, remove "_rownames_"
if (!data_table && rowNames && colNames) {
cc <- cc[cc$r != paste0(names(rtyp)[1], rownames(rtyp)[1]), ]
}
if (shared) {
# This cc contains only the formula range.
## the top left cell is the reference
## all have shared and all share the same f_si
## only the reference cell has a formula
## only the reference cell has the formula reference
uni_attrs <- unique(wb$worksheets[[sheetno]]$sheet_data$cc$f_attr)
f_xml <- paste0("<f ", uni_attrs, "/>")
uni_si <- unique(rbindlist(xml_attr(f_xml, "f"))$si)
int_si <- as.integer(
replace(
uni_si,
uni_si == "",
"-1"
)
)
int_si <- max(int_si, -1L) + 1L
cc[["f_attr"]] <- sprintf("t=\"%s\"", "shared")
cc[1, "f_attr"] <- paste(cc[1, "f_attr"], sprintf("ref=\"%s\"", dims))
cc[["f_attr"]] <- paste(cc[["f_attr"]], sprintf("si=\"%s\"", int_si))
cc[2:nrow(cc), "f"] <- ""
}
if (is.null(wb$worksheets[[sheetno]]$sheet_data$cc)) {
# message("write_cell()")
wb$worksheets[[sheetno]]$dimension <- paste0("<dimension ref=\"", dims, "\"/>")
wb$worksheets[[sheetno]]$sheet_data$row_attr <- rows_attr
wb$worksheets[[sheetno]]$sheet_data$cc <- cc
} else {
# update cell(s)
# message("update_cell()")
wb <- update_cell(
x = cc,
wb = wb,
sheet = sheetno,
cell = dims,
colNames = colNames,
removeCellStyle = removeCellStyle,
na.strings = na.strings
)
}
### Begin styles
if (applyCellStyle) {
## create a cell style format for specific types at the end of the existing
# styles. gets the reference an passes it on.
get_data_class_dims <- function(data_class) {
sel <- dc == openxlsx2_celltype[[data_class]]
# sel = TRUE
sel_cols <- names(rtyp[sel])
sel_rows <- rownames(rtyp)
# ignore first row if colNames
if (colNames) sel_rows <- sel_rows[-1]
dataframe_to_dims(rtyp[rownames(rtyp) %in% sel_rows, sel_cols, drop = FALSE])
}
# if hyperlinks are found, Excel sets something like the following font
# blue with underline
if (any(dc == openxlsx2_celltype[["hyperlink"]])) {
dim_sel <- get_data_class_dims("hyperlink")
# message("hyperlink: ", dim_sel)
# get hyperlink color from template
if (is.null(wb$theme)) {
has_hlink <- 11
} else {
clrs <- xml_node(wb$theme, "a:theme", "a:themeElements", "a:clrScheme")
has_hlink <- which(xml_node_name(clrs, "a:clrScheme") == "a:hlink")
}
if (has_hlink) {
hyperlink_col <- wb_color(theme = has_hlink - 1L)
} else {
hyperlink_col <- wb_color(hex = "FF0000FF")
}
wb$add_font(
sheet = sheetno,
dims = dim_sel,
color = hyperlink_col,
name = wb$get_base_font()$name$val,
size = wb$get_base_font()$size$val,
underline = "single"
)
}
if (any(dc == openxlsx2_celltype[["character"]])) {
if (any(sel <- cc$typ == openxlsx2_celltype[["string_nums"]])) {
# # we cannot select every cell like this, because it is terribly slow.
# dim_sel <- paste0(cc$r[sel], collapse = ";")
dim_sel <- get_data_class_dims("character")
# message("character: ", dim_sel)
wb$add_cell_style(
sheet = sheetno,
dims = dim_sel,
applyNumberFormat = "1",
quotePrefix = "1",
numFmtId = "49"
)
cc$typ <- NULL
}
}
# options("openxlsx2.numFmt" = NULL)
if (any(dc == openxlsx2_celltype[["numeric"]])) { # numeric or integer
if (!is.null(getOption("openxlsx2.numFmt"))) {
numfmt_numeric <- getOption("openxlsx2.numFmt")
dim_sel <- get_data_class_dims("numeric")
# message("numeric: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_numeric
)
}
}
if (any(dc == openxlsx2_celltype[["short_date"]])) { # Date
numfmt_dt <- getOption("openxlsx2.dateFormat", 14)
dim_sel <- get_data_class_dims("short_date")
# message("short_date: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_dt
)
}
if (any(dc == openxlsx2_celltype[["long_date"]])) {
numfmt_posix <- getOption("openxlsx2.datetimeFormat", default = 22)
dim_sel <- get_data_class_dims("long_date")
# message("long_date: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_posix
)
}
if (any(dc == openxlsx2_celltype[["hms_time"]])) {
numfmt_hms <- getOption("openxlsx2.hmsFormat", default = 21)
dim_sel <- get_data_class_dims("hms_time")
# message("hms: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_hms
)
}
if (any(dc == openxlsx2_celltype[["currency"]])) { # currency
numfmt_currency <- getOption("openxlsx2.currencyFormat", default = 44)
## For vignette: Builtin style for USD
#"_-[$$-409]* #,##0.00_ ;_-[$$-409]* \\-#,##0.00\\ ;_-[$$-409]* "-"??_ ;_-@_ "
dim_sel <- get_data_class_dims("currency")
# message("currency: ", dim_sel)
wb$add_numfmt(
dims = dim_sel,
numfmt = numfmt_currency
)
}
if (any(dc == openxlsx2_celltype[["accounting"]])) { # accounting
numfmt_accounting <- getOption("openxlsx2.accountingFormat", default = 4)
dim_sel <- get_data_class_dims("accounting")
# message("accounting: ", dim_sel)
wb$add_numfmt(
dims = dim_sel,
numfmt = numfmt_accounting
)
}
if (any(dc == openxlsx2_celltype[["percentage"]])) { # percentage
numfmt_percentage <- getOption("openxlsx2.percentageFormat", default = 10)
dim_sel <- get_data_class_dims("percentage")
# message("percentage: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_percentage
)
}
if (any(dc == openxlsx2_celltype[["scientific"]])) {
numfmt_scientific <- getOption("openxlsx2.scientificFormat", default = 48)
dim_sel <- get_data_class_dims("scientific")
# message("scientific: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_scientific
)
}
if (any(dc == openxlsx2_celltype[["comma"]])) {
numfmt_comma <- getOption("openxlsx2.commaFormat", default = 3)
dim_sel <- get_data_class_dims("comma")
# message("comma: ", dim_sel)
wb$add_numfmt(
sheet = sheetno,
dims = dim_sel,
numfmt = numfmt_comma
)
}
}
### End styles
# update shared strings if we use shared strings
if (!inline_strings) {
cc <- wb$worksheets[[sheetno]]$sheet_data$cc
sel <- grepl("<si>", cc$v)
cc_sst <- stringi::stri_unique(cc[sel, "v"])
wb$sharedStrings <- stringi::stri_unique(c(wb$sharedStrings, cc_sst))
sel <- grepl("<si>", cc$v)
cc$v[sel] <- as.character(match(cc$v[sel], wb$sharedStrings) - 1L)
text <- si_to_txt(wb$sharedStrings)
uniqueCount <- length(wb$sharedStrings)
attr(wb$sharedStrings, "uniqueCount") <- uniqueCount
attr(wb$sharedStrings, "text") <- text
wb$worksheets[[sheetno]]$sheet_data$cc <- cc
if (!any(grepl("sharedStrings", wb$workbook.xml.rels))) {
wb$append(
"workbook.xml.rels",
"<Relationship Id=\"rId1\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings\" Target=\"sharedStrings.xml\"/>"
)
}
}
### Update calcChain
if (length(wb$calcChain)) {
# if we overwrite a formula cell in the calculation chain, we have to update it
# At the moment we simply remove it from the calculation chain, in the future
# we might want to keep it if we write a formula.
xml <- wb$calcChain
calcChainR <- rbindlist(xml_attr(xml, "calcChain", "c"))
# according to the documentation there can be cases, without the sheetno reference
sel <- calcChainR$r %in% wb$worksheets[[sheetno]]$sheet_data$cc$r & calcChainR$i == sheetno
rmCalcChain <- as.integer(rownames(calcChainR[sel, , drop = FALSE]))
if (length(rmCalcChain)) {
xml <- xml_rm_child(xml, xml_child = "c", which = rmCalcChain)
# xml can not be empty, otherwise excel will complain. If xml is empty, remove all
# calcChain references from the workbook
if (length(xml_node_name(xml, "calcChain")) == 0) {
wb$Content_Types <- wb$Content_Types[-grep("/xl/calcChain", wb$Content_Types)]
wb$workbook.xml.rels <- wb$workbook.xml.rels[-grep("calcChain.xml", wb$workbook.xml.rels)]
wb$worksheets[[sheetno]]$sheetCalcPr <- character()
xml <- character()
}
wb$calcChain <- xml
}
}
### End update calcChain
return(wb)
}
# `write_data_table()` ---------------------------------------------------------
# `write_data_table()` an internal driver function to `write_data` and `write_data_table` ----
#' Write to a worksheet as an Excel table
#'
#' Write to a worksheet and format as an Excel table
#'
#' @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 data frame.
#' @param startCol A vector specifying the starting column to write df
#' @param startRow A vector specifying the starting row to write df
#' @param dims Spreadsheet dimensions that will determine startCol and startRow: "A1", "A1:B2", "A:B"
#' @param array A bool if the function written is of type array
#' @param colNames If `TRUE`, column names of x are written.
#' @param rowNames If `TRUE`, row names of x are written.
#' @param tableStyle Any excel table style name or "none" (see "formatting" vignette).
#' @param tableName name of table in workbook. The table name must be unique.
#' @param withFilter If `TRUE`, columns with have filters in the first row.
#' @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).
#' @param firstColumn logical. If TRUE, the first column is bold
#' @param lastColumn logical. If TRUE, the last column is bold
#' @param bandedRows logical. If TRUE, rows are color banded
#' @param bandedCols logical. If TRUE, the columns are color banded
#' @param bandedCols logical. If TRUE, a data table is created
#' @param name If not NULL, a named region is defined.
#' @param applyCellStyle apply styles when writing on the sheet
#' @param removeCellStyle if writing into existing cells, should the cell style be removed?
#' @param na.strings Value used for replacing `NA` values from `x`. Default
#' looks if `options(openxlsx2.na.strings)` is set. Otherwise [na_strings()]
#' uses the special `#N/A` value within the workbook.
#' @param inline_strings optional write strings as inline strings
#' @param total_row optional write total rows
#' @param shared shared formula
#' @noRd
#' @keywords internal
write_data_table <- function(
wb,
sheet,
x,
startCol = 1,
startRow = 1,
dims,
array = FALSE,
colNames = TRUE,
rowNames = FALSE,
tableStyle = "TableStyleLight9",
tableName = NULL,
withFilter = TRUE,
sep = ", ",
firstColumn = FALSE,
lastColumn = FALSE,
bandedRows = TRUE,
bandedCols = FALSE,
name = NULL,
applyCellStyle = TRUE,
removeCellStyle = FALSE,
data_table = FALSE,
na.strings = na_strings(),
inline_strings = TRUE,
total_row = FALSE,
enforce = FALSE,
shared = FALSE
) {
## Input validating
assert_workbook(wb)
assert_class(colNames, "logical")
assert_class(rowNames, "logical")
assert_class(withFilter, "logical")
if (data_table) assert_class(x, "data.frame")
assert_class(firstColumn, "logical")
assert_class(lastColumn, "logical")
assert_class(bandedRows, "logical")
assert_class(bandedCols, "logical")
# force with globalenv() options
x <- force(x)
op <- default_save_opt()
on.exit(options(op), add = TRUE)
odims <- dims
if (!is.null(dims)) {
dims <- dims_to_rowcol(dims, as_integer = TRUE)
# if dims = "K1,A1" startCol = "A" and startRow = "1" are selected
startCol <- min(dims[["col"]])
startRow <- min(dims[["row"]])
}
# avoid stoi error with NULL
if (is.null(x)) {
return(wb)
}
# overwrite na.strings if nothing was provided
# with whatever is in the option if not set to default
if (is_na_strings(na.strings) && !is.null(getOption("openxlsx2.na.strings"))) {
na.strings <- getOption("openxlsx2.na.strings")
}
if (data_table) {
if (nrow(x) < 1) {
warning("Found data table with zero rows, adding one.",
" Modify na with na.strings")
x[1, ] <- NA
}
if (any(duplicated(tolower(colnames(x))))) {
warning("tables cannot have duplicated column names")
colnames(x) <- fix_pt_names(colnames(x))
}
}
## common part ---------------------------------------------------------------
if ((!is.character(sep)) || (length(sep) != 1))
stop("sep must be a character vector of length 1")
# TODO clean up when moved into wbWorkbook
sheet <- wb$.__enclos_env__$private$get_sheet_index(sheet)
# sheet <- wb$validate_sheet(sheet)
if (wb$is_chartsheet[[sheet]]) stop("Cannot write to chart sheet.")
## convert startRow and startCol
if (!is.numeric(startCol)) {
startCol <- col2int(startCol)
}
startRow <- as.integer(startRow)
## special case - vector of hyperlinks
# TODO: replace the =HYPERLINK() with the relship hyperlinks
is_hyperlink <- FALSE
if (applyCellStyle) {
if (is.null(dim(x))) {
is_hyperlink <- inherits(x, "hyperlink")
} else if (is.data.frame(x)) { # dont check on a matrix
is_hyperlink <- vapply(x, inherits, what = "hyperlink", FALSE)
}
if (any(is_hyperlink)) {
# consider wbHyperlink?
# hlinkNames <- names(x)
if (is.null(dim(x))) {
colNames <- FALSE
if (!any(grepl("=([\\s]*?)HYPERLINK\\(", x[is_hyperlink], perl = TRUE))) {
if (length(names(x))) {
x[is_hyperlink] <- create_hyperlink(text = names(x[is_hyperlink]), file = x[is_hyperlink])
} else {
x[is_hyperlink] <- create_hyperlink(text = x[is_hyperlink])
}
}
class(x[is_hyperlink]) <- c("character", "hyperlink")
} else {
# workaround for tibbles that break with the class assignment below
if (inherits(x, "tbl_df")) x <- as.data.frame(x, stringsAsFactors = FALSE)
# check should be in create_hyperlink and that apply should not be required either
if (!any(grepl("=([\\s]*?)HYPERLINK\\(", x[is_hyperlink], perl = TRUE))) {
x[is_hyperlink] <- apply(
x[is_hyperlink], 1,
FUN = function(str) create_hyperlink(text = str)
)
}
class(x[, is_hyperlink]) <- c("character", "hyperlink")
}
}
}
### Create data frame --------------------------------------------------------
transpose <- FALSE
# do not transpose if input is a matrix or a data frame. assuming that such input
# is already transposed as required.
if (length(dims[[1]]) > length(dims[[2]]) &&
!inherits(x, "matrix") && !inherits(x, "data.frame"))
transpose <- TRUE
## special case - formula
# only for data frame case where a data frame is passed down containing formulas
if (inherits(x, "formula")) {
x <- data.frame("X" = x, stringsAsFactors = FALSE)
class(x[[1]]) <- if (array) "array_formula" else "formula"
colNames <- FALSE
if (transpose) x <- transpose_df(x)
}
if (is.vector(x) || is.factor(x) || inherits(x, "Date") || inherits(x, "POSIXt") || inherits(x, "character")) {
colNames <- FALSE
} ## this will go to coerce.default and rowNames will be ignored
## Coerce to data.frame
if (inherits(x, "hyperlink")) {
## vector of hyperlinks
class(x) <- c("character", "hyperlink")
x <- as.data.frame(x, stringsAsFactors = FALSE)
if (transpose) x <- transpose_df(x)
# colNames <- FALSE
} else if (!inherits(x, "data.frame")) {
x <- as.data.frame(x, stringsAsFactors = FALSE)
if (transpose) x <- transpose_df(x)
# colNames <- FALSE
}
nCol <- ncol(x)
nRow <- nrow(x)
### Beg: Only in data --------------------------------------------------------
if (!data_table) {
## write autoFilter, can only have a single filter per worksheet
if (withFilter) { # TODO: replace ref calculation with wb_dims()
coords <- data.frame("x" = c(startRow, startRow + nRow + colNames - 1L), "y" = c(startCol, startCol + nCol - 1L), stringsAsFactors = FALSE)
ref <- stringi::stri_join(get_cell_refs(coords), collapse = ":")
wb$worksheets[[sheet]]$autoFilter <- sprintf('<autoFilter ref="%s"/>', ref)
l <- int2col(unlist(coords[, 2]))
dfn <- sprintf("'%s'!%s", wb$get_sheet_names(escape = TRUE)[sheet], stringi::stri_join("$", l, "$", coords[, 1], collapse = ":"))
dn <- sprintf('<definedName name="_xlnm._FilterDatabase" localSheetId="%s" hidden="1">%s</definedName>', sheet - 1L, dfn)
if (!is.null(wbdn <- wb$get_named_regions())) {
ind <- wbdn$name == "_xlnm._FilterDatabase" & wbdn$localSheetId == sheet - 1L
if (any(ind)) {
wb$workbook$definedNames[ind] <- dn
} else {
wb$workbook$definedNames <- c(
wb$workbook$definedNames, dn
)
}
} else {
wb$workbook$definedNames <- dn
}
}
}
### End: Only in data --------------------------------------------------------
if (data_table) {
overwrite_nrows <- 1L
check_tab_head_only <- FALSE
error_msg <- "Cannot overwrite existing table with another table"
} else {
overwrite_nrows <- colNames
check_tab_head_only <- TRUE
error_msg <- "Cannot overwrite table headers. Avoid writing over the header row or see wb_get_tables() & wb_remove_tabless() to remove the table object."
}
## Check not overwriting existing table headers
wb_check_overwrite_tables(
wb = wb,
sheet = sheet,
new_rows = c(startRow, startRow + nRow - 1L + overwrite_nrows),
new_cols = c(startCol, startCol + nCol - 1L),
check_table_header_only = check_tab_head_only,
error_msg = error_msg
)
## actual driver, the rest should not create data used for writing
wb <- write_data2(
wb = wb,
sheet = sheet,
data = x,
name = name,
colNames = colNames,
rowNames = rowNames,
startRow = startRow,
startCol = startCol,
applyCellStyle = applyCellStyle,
removeCellStyle = removeCellStyle,
na.strings = na.strings,
data_table = data_table,
inline_strings = inline_strings,
dims = if (enforce) odims else dims,
enforce = enforce,
shared = shared,
sep = sep
)
### Beg: Only in datatable ---------------------------------------------------
# if rowNames is set, write_data2 has added a rowNames column to the sheet.
# This has to be handled in colnames and in ref.
if (data_table) {
## replace invalid XML characters
col_names <- replace_legal_chars(colnames(x))
if (rowNames) col_names <- c("_rowNames_", col_names)
## Table name validation
if (is.null(tableName)) {
tableName <- paste0("Table", last_table_id(wb) + 1L)
} else {
tableName <- wb_validate_table_name(wb, tableName)
}
## write total rows column. this is a formula and needs to be written separately
total_fml <- FALSE
total_lbl <- FALSE
if (!isFALSE(total_row)) {
total <- known_subtotal_funs(
x = x,
total = total_row,
table = tableName,
row_names = rowNames
)
total_row <- total[[1]]
total_fml <- total[[2]]
total_lbl <- total[[3]]
wb <- write_data2(
wb = wb,
sheet = sheet,
data = total_row,
name = name,
colNames = FALSE,
rowNames = FALSE,
startRow = startRow + nrow(x) + 1L,
startCol = startCol,
applyCellStyle = applyCellStyle,
removeCellStyle = removeCellStyle,
na.strings = na.strings,
data_table = data_table,
inline_strings = inline_strings,
dims = NULL,
enforce = FALSE,
sep = sep
)
}
## If 0 rows append a blank row
cstm_tableStyles <- wb$styles_mgr$tableStyle$name
validNames <- c("none", paste0("TableStyleLight", seq_len(21)), paste0("TableStyleMedium", seq_len(28)), paste0("TableStyleDark", seq_len(11)), cstm_tableStyles)
if (!tolower(tableStyle) %in% tolower(validNames)) {
stop("Invalid table style.")
} else {
tableStyle <- grep(paste0("^", tableStyle, "$"), validNames, ignore.case = TRUE, value = TRUE)
}
tableStyle <- tableStyle[!is.na(tableStyle)]
if (length(tableStyle) == 0) {
stop("Unknown table style.")
}
## If zero rows, append an empty row (prevent XML from corrupting)
if (nrow(x) == 0) {
x <- rbind(as.data.frame(x, stringsAsFactors = FALSE), matrix("", nrow = 1, ncol = nCol, dimnames = list(character(), colnames(x))))
names(x) <- colNames
}
ref1 <- paste0(int2col(startCol), startRow)
ref2 <- paste0(int2col(startCol + nCol - !rowNames), startRow + nRow)
ref <- paste(ref1, ref2, sep = ":")
## create table.xml and assign an id to worksheet tables
wb$buildTable(
sheet = sheet,
colNames = col_names,
ref = ref,
showColNames = colNames,
tableStyle = tableStyle,
tableName = tableName,
totalLabel = total_lbl,
withFilter = withFilter,
totalsRowCount = total_fml,
showFirstColumn = firstColumn,
showLastColumn = lastColumn,
showRowStripes = bandedRows,
showColumnStripes = bandedCols
)
}
### End: Only in datatable ---------------------------------------------------
return(wb)
}
# `do_write_data()` ---------------------------------------------------------------
do_write_data <- function(
wb,
sheet,
x,
dims = wb_dims(start_row, start_col),
start_col = 1,
start_row = 1,
array = FALSE,
col_names = TRUE,
row_names = FALSE,
with_filter = FALSE,
sep = ", ",
name = NULL,
apply_cell_style = TRUE,
remove_cell_style = FALSE,
na.strings = na_strings(),
inline_strings = TRUE,
enforce = FALSE,
shared = FALSE,
...
) {
standardize_case_names(...)
write_data_table(
wb = wb,
sheet = sheet,
x = x,
dims = dims,
startCol = start_col,
startRow = start_row,
array = array,
colNames = col_names,
rowNames = row_names,
tableStyle = NULL,
tableName = NULL,
withFilter = with_filter,
sep = sep,
firstColumn = FALSE,
lastColumn = FALSE,
bandedRows = FALSE,
bandedCols = FALSE,
name = name,
applyCellStyle = apply_cell_style,
removeCellStyle = remove_cell_style,
data_table = FALSE,
na.strings = na.strings,
inline_strings = inline_strings,
enforce = enforce,
shared = shared
)
}
# do_write_formula() -------------------------------------------
do_write_formula <- function(
wb,
sheet,
x,
dims = wb_dims(start_row, start_col),
start_col = 1,
start_row = 1,
array = FALSE,
cm = FALSE,
apply_cell_style = TRUE,
remove_cell_style = FALSE,
enforce = FALSE,
shared = FALSE,
name = NULL,
...
) {
standardize_case_names(...)
if (is.data.frame(x))
x <- unlist(x)
assert_class(x, "character")
x <- replace_waiver(x, wb = wb)
# detect array formulas
if (any(substr(x, 1, 1) == "{")) {
pattern <- "^\\{(.*)\\}$"
x <- gsub(pattern, "\\1", x)
array <- TRUE
}
if ((array || cm) && shared) stop("either array/cm or shared")
# we need to increase the data
if (shared) { # not sure if this applies to arrays as well
size <- dims_to_dataframe(dims)
x <- rep(x, ncol(size) * nrow(size))
}
if (is.null(dims)) {
dims <- wb_dims(start_row, start_col)
}
if ((array || cm) || enforce) {
dfx <- data.frame("X" = x, stringsAsFactors = FALSE)
} else {
# if dims a single cell and x > dfx, increase dfx
if (!grepl(":", dims) && (NROW(x) > 1 || NCOL(x) > 1)) {
dfx <- dims_to_dataframe(wb_dims(x = x, from_dims = dims))
} else {
dfx <- dims_to_dataframe(dims)
}
dfx[] <- x
}
formula <- "formula"
if (array) formula <- "array_formula"
if (cm) {
# need to set cell metadata in wb$metadata
if (is.null(wb$metadata)) {
wb$append("Content_Types", "<Override PartName=\"/xl/metadata.xml\" ContentType=\"application/vnd.openxmlformats-officedocument.spreadsheetml.sheetMetadata+xml\"/>")
wb$metadata <- # danger danger no clue what this means!
xml_node_create(
"metadata",
xml_attributes = c(
xmlns = "http://schemas.openxmlformats.org/spreadsheetml/2006/main",
"xmlns:xda" = "http://schemas.microsoft.com/office/spreadsheetml/2017/dynamicarray"
),
xml_children = read_xml(
"<metadataTypes count=\"1\">
<metadataType name=\"XLDAPR\" minSupportedVersion=\"120000\" copy=\"1\" pasteAll=\"1\" pasteValues=\"1\" merge=\"1\" splitFirst=\"1\" rowColShift=\"1\" clearFormats=\"1\" clearComments=\"1\" assign=\"1\" coerce=\"1\" cellMeta=\"1\"/>
</metadataTypes>
<futureMetadata name=\"XLDAPR\" count=\"1\">
<bk>
<extLst>
<ext uri=\"{bdbb8cdc-fa1e-496e-a857-3c3f30c029c3}\">
<xda:dynamicArrayProperties fDynamic=\"1\" fCollapsed=\"0\"/>
</ext>
</extLst>
</bk>
</futureMetadata>,
<cellMetadata/>",
pointer = FALSE
)
)
}
## TODO Not sure if there are more cases
# add new cell metadata record
cM <- xml_node(wb$metadata, "metadata", "cellMetadata")
cM <- xml_add_child(cM, xml_child = "<bk><rc t=\"1\" v=\"0\"/></bk>")
# we need to update count
cnt <- as_xml_attr(length(xml_node(cM, "cellMetadata", "bk")))
cM <- xml_attr_mod(cM, xml_attributes = c(count = cnt))
# remove current cellMetadata update new
wb$metadata <- xml_rm_child(wb$metadata, "cellMetadata")
wb$metadata <- xml_add_child(wb$metadata, cM)
attr(dfx, "c_cm") <- cnt
formula <- "cm_formula"
}
# class(dfx$X) <- c(formula, "character")
for (i in seq_along(dfx)) {
class(dfx[[i]]) <- c(formula, "character")
}
if (any(grepl("=([\\s]*?)HYPERLINK\\(", x, perl = TRUE))) {
# class(dfx$X) <- c("character", "formula", "hyperlink")
# TODO does not handle mixed types
for (i in seq_along(dfx)) {
class(dfx[[i]]) <- c("character", "formula", "hyperlink")
}
}
# transpose match write_data_table
if ((array || cm) || enforce) {
rc <- dims_to_rowcol(dims)
if (length(rc[["col"]]) > length(rc[["row"]])) {
dfx <- transpose_df(dfx)
}
}
if (array || cm) {
if (length(dfx$X) == 1) {
attr(dfx, "f_ref") <- dims
}
}
do_write_data(
wb = wb,
sheet = sheet,
x = dfx,
start_col = start_col,
start_row = start_row,
dims = dims,
array = array,
col_names = FALSE,
row_names = FALSE,
name = name,
apply_cell_style = apply_cell_style,
remove_cell_style = remove_cell_style,
enforce = enforce,
shared = shared
)
}
# `do_write_datatable()` ----------------------
do_write_datatable <- function(
wb,
sheet,
x,
dims = wb_dims(start_row, start_col),
start_col = 1,
start_row = 1,
col_names = TRUE,
row_names = FALSE,
table_style = "TableStyleLight9",
table_name = NULL,
with_filter = TRUE,
sep = ", ",
first_column = FALSE,
last_column = FALSE,
banded_rows = TRUE,
banded_cols = FALSE,
apply_cell_style = TRUE,
remove_cell_style = FALSE,
na.strings = na_strings(),
inline_strings = TRUE,
total_row = FALSE,
shared = FALSE,
...
) {
standardize_case_names(...)
write_data_table(
wb = wb,
sheet = sheet,
x = x,
startCol = start_col,
startRow = start_row,
dims = dims,
array = FALSE,
colNames = col_names,
rowNames = row_names,
tableStyle = table_style,
tableName = table_name,
withFilter = with_filter,
sep = sep,
firstColumn = first_column,
lastColumn = last_column,
bandedRows = banded_rows,
bandedCols = banded_cols,
name = NULL,
data_table = TRUE,
applyCellStyle = apply_cell_style,
removeCellStyle = remove_cell_style,
na.strings = na.strings,
inline_strings = inline_strings,
total_row = total_row,
shared = shared
)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.