diff --git a/R/write.R b/R/write.R index 78496516b..3e4b24ed6 100644 --- a/R/write.R +++ b/R/write.R @@ -1,281 +1,724 @@ -#' 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() -) { - - # 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("") - } - - if (is_na_strings(na.strings)) { - na.strings <- NULL - } - - if (removeCellStyle) { - cell_style <- "c_s" - } else { - cell_style <- NULL - } - - replacement <- c("r", cell_style, "c_t", "c_cm", "c_ph", "c_vm", "v", - "f", "f_t", "f_ref", "f_ca", "f_si", "is", "typ") - - sel <- match(x$r, cc$r) - cc[sel, replacement] <- x[replacement] - - # avoid missings in cc - if (any(is.na(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) - - # create artificial cc for the missing cells - x <- empty_sheet_data_cc(n = length(new_cells)) - x$r <- new_cells - x$row_r <- gsub("[[:upper:]]", "", new_cells) - x$c_r <- gsub("[[:digit:]]", "", new_cells) - - rows <- x$row_r - cells_needed <- new_cells - - inner_update(wb, sheet_id, x, rows, cells_needed) -} -#' Replace data cell(s) +# `write_data()` --------------------------------------------------------------- +#' Write an object to a worksheet #' -#' Minimal invasive update of cell(s) inside of imported workbooks. +#' Write an object to worksheet with optional styling. #' -#' @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) +#' Formulae written using write_formula to a Workbook object will not get picked up by read_xlsx(). +#' This is because only the formula is written and left to Excel to evaluate the formula when the file is opened in Excel. +#' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame contains this string, the output will be broken. #' -#' @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 wb A Workbook object containing a worksheet. +#' @param sheet The worksheet to write to. Can be the worksheet index or name. +#' @param x Object to be written. For classes supported look at the examples. +#' @param start_col A vector specifying the starting column to write to. +#' @param start_row A vector specifying the starting row to write to. +#' @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 col_names If `TRUE`, column names of x are written. +#' @param row_names If `TRUE`, data.frame row names of x are written. +#' @param with_filter If `TRUE`, add filters to the column name row. NOTE can only have one filter per worksheet. +#' @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 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 apply_cell_style apply styles when writing on the sheet +#' @param remove_cell_style if writing into existing cells, should the cell style be removed? #' @param na.strings Value used for replacing `NA` values from `x`. Default #' `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 -#' @details -#' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame -#' contains this string, the output will be broken. -#' +#' @param ... additional arguments +#' @seealso [write_datatable()] +#' @return invisible(0) #' @examples -#' # create a workbook and add some sheets +#' ## See formatting vignette for further examples. +#' +#' ## Options for default styling (These are the defaults) +#' options("openxlsx2.dateFormat" = "mm/dd/yyyy") +#' options("openxlsx2.datetimeFormat" = "yyyy-mm-dd hh:mm:ss") +#' options("openxlsx2.numFmt" = NULL) +#' +#' ############################################################################# +#' ## Create Workbook object and add worksheets #' wb <- wb_workbook() #' -#' wb$add_worksheet("sheet1") -#' write_data2(wb, "sheet1", mtcars, colNames = TRUE, rowNames = TRUE) +#' ## Add worksheets +#' wb$add_worksheet("Cars") +#' wb$add_worksheet("Formula") #' -#' wb$add_worksheet("sheet2") -#' write_data2(wb, "sheet2", cars, colNames = FALSE) +#' x <- mtcars[1:6, ] +#' wb$add_data("Cars", x, startCol = 2, startRow = 3, rowNames = TRUE) #' -#' wb$add_worksheet("sheet3") -#' write_data2(wb, "sheet3", letters) +#' ############################################################################# +#' ## Hyperlinks +#' ## - vectors/columns with class 'hyperlink' are written as hyperlinks' #' -#' wb$add_worksheet("sheet4") -#' write_data2(wb, "sheet4", as.data.frame(Titanic), startRow = 2, startCol = 2) -#' @keywords internal -#' @noRd -write_data2 <- function( +#' v <- rep("https://CRAN.R-project.org/", 4) +#' names(v) <- paste0("Hyperlink", 1:4) # Optional: names will be used as display text +#' class(v) <- "hyperlink" +#' wb$add_data("Cars", x = v, dims = c("B32")) +#' +#' ############################################################################# +#' ## Formulas +#' ## - vectors/columns with class 'formula' are written as formulas' +#' +#' df <- data.frame( +#' x = 1:3, y = 1:3, +#' z = paste(paste0("A", 1:3 + 1L), paste0("B", 1:3 + 1L), sep = "+"), +#' stringsAsFactors = FALSE +#' ) +#' +#' class(df$z) <- c(class(df$z), "formula") +#' +#' wb$add_data(sheet = "Formula", x = df) +#' +#' ############################################################################# +#' # update cell range and add mtcars +#' xlsxFile <- system.file("extdata", "openxlsx2_example.xlsx", package = "openxlsx2") +#' wb2 <- wb_load(xlsxFile) +#' +#' # read dataset with inlinestr +#' wb_to_df(wb2) +#' write_data(wb2, 1, mtcars, startCol = 4, startRow = 4) +#' wb_to_df(wb2) +#' @export +write_data <- 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 + x, + dims = rowcol_to_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, + ... ) { - is_data_frame <- FALSE - #### prepare the correct data formats for openxml - dc <- openxlsx2_type(data) - - # convert factor to character - if (any(dc == openxlsx2_celltype[["factor"]])) { - is_factor <- dc == openxlsx2_celltype[["factor"]] - fcts <- names(dc[is_factor]) - data[fcts] <- lapply(data[fcts], to_string) - # dc <- openxlsx2_type(data) - } + standardize_case_names(...) - hconvert_date1904 <- grepl('date1904="1"|date1904="true"', - stri_join(unlist(wb$workbook), collapse = ""), - ignore.case = TRUE) + 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 + ) +} - # 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) +# write_formula() ------------------------------------------- +#' Write a character vector as an Excel Formula +#' +#' Write a a character vector containing Excel formula to a worksheet. +#' +#' @details +#' Currently only the English version of functions are supported. Please don't use the local translation. +#' The examples below show a small list of possible formulas: +#' * SUM(B2:B4) +#' * AVERAGE(B2:B4) +#' * MIN(B2:B4) +#' * MAX(B2:B4) +#' * ... +#' +#' @param wb A Workbook object containing a worksheet. +#' @param sheet The worksheet to write to. Can be the worksheet index or name. +#' @param x A character vector. +#' @param dims Spreadsheet dimensions that will determine startCol and startRow: "A1", "A1:B2", "A:B" +#' @param start_col A vector specifying the starting column to write to. +#' @param start_row A vector specifying the starting row to write to. +#' @param array A bool if the function written is of type array +#' @param cm A bool if the function is of type cm (array with hidden curly braces) +#' @param apply_cell_style apply styles when writing on the sheet +#' @param remove_cell_style if writing into existing cells, should the cell style be removed? +#' @param ... additional arguments +#' @seealso [write_data()] +#' @examples +#' ## There are 3 ways to write a formula +#' +#' wb <- wb_workbook() +#' wb$add_worksheet("Sheet 1") +#' wb$add_data("Sheet 1", x = iris) +#' +#' ## SEE `int2col()` to convert int to Excel column label +#' +#' ## 1. - As a character vector using write_formula +#' +#' v <- c("SUM(A2:A151)", "AVERAGE(B2:B151)") ## skip header row +#' write_formula(wb, sheet = 1, x = v, startCol = 10, startRow = 2) +#' write_formula(wb, 1, x = "A2 + B2", startCol = 10, startRow = 10) +#' +#' +#' ## 2. - As a data.frame column with class "formula" using write_data +#' +#' df <- data.frame( +#' x = 1:3, +#' y = 1:3, +#' z = paste(paste0("A", 1:3 + 1L), paste0("B", 1:3 + 1L), sep = " + "), +#' z2 = sprintf("ADDRESS(1,%s)", 1:3), +#' stringsAsFactors = FALSE +#' ) +#' +#' class(df$z) <- c(class(df$z), "formula") +#' class(df$z2) <- c(class(df$z2), "formula") +#' +#' wb$add_worksheet("Sheet 2") +#' wb$add_data(sheet = 2, x = df) +#' +#' +#' ## 3. - As a vector with class "formula" using write_data +#' +#' v2 <- c("SUM(A2:A4)", "AVERAGE(B2:B4)", "MEDIAN(C2:C4)") +#' class(v2) <- c(class(v2), "formula") +#' +#' wb$add_data(sheet = 2, x = v2, startCol = 10, startRow = 2) +#' +#' +#' ## 4. - Writing internal hyperlinks +#' +#' wb <- wb_workbook() +#' wb$add_worksheet("Sheet1") +#' wb$add_worksheet("Sheet2") +#' write_formula(wb, "Sheet1", x = '=HYPERLINK("#Sheet2!B3", "Text to Display - Link to Sheet2")') +#' +#' +#' ## 5. - Writing array formulas +#' +#' set.seed(123) +#' df <- data.frame(C = rnorm(10), D = rnorm(10)) +#' +#' wb <- wb_workbook() +#' wb <- wb_add_worksheet(wb, "df") +#' +#' wb$add_data("df", df, startCol = "C") +#' +#' write_formula(wb, "df", startCol = "E", startRow = "2", +#' x = "SUM(C2:C11*D2:D11)", +#' array = TRUE) +#' @export +write_formula <- function( + wb, + sheet, + x, + dims = rowcol_to_dims(start_row, start_col), + start_col = 1, + start_row = 1, + array = FALSE, + cm = FALSE, + apply_cell_style = TRUE, + remove_cell_style = FALSE, + ... +) { - # backward compatible - if (!inherits(data, "data.frame") || inherits(data, "matrix")) { - data <- as.data.frame(data) - colNames <- FALSE - } + standardize_case_names(...) - if (inherits(data, "data.frame") || inherits(data, "matrix")) { - is_data_frame <- TRUE + assert_class(x, "character") + # remove xml encoding and reapply it afterwards. until v0.3 encoding was not enforced + x <- replaceXMLEntities(x) + x <- vapply(x, function(val) xml_value(xml_node_create("fml", val, escapes = TRUE), "fml"), NA_character_) + dfx <- data.frame("X" = x, stringsAsFactors = FALSE) - if (is.data.frame(data)) data <- as.data.frame(data) + formula <- "formula" + if (array) formula <- "array_formula" + if (cm) { + # need to set cell metadata in wb$metadata + if (is.null(wb$metadata)) { - sel <- !dc %in% c(4, 5, 10) - data[sel] <- lapply(data[sel], as.character) + wb$append("Content_Types", "") - # add rownames - if (rowNames) { - data <- cbind("_rowNames_" = rownames(data), data) - dc <- c(c("_rowNames_" = openxlsx2_celltype[["character"]]), dc) + 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( + " + + + + + + + + + + + , + ", + pointer = FALSE + ) + ) } - # add colnames - if (colNames) - data <- rbind(colnames(data), data) - } + ## 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 = "") + # 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)) - sheetno <- wb_validate_sheet(wb, sheet) - # message("sheet no: ", sheetno) + # remove current cellMetadata update new + wb$metadata <- xml_rm_child(wb$metadata, "cellMetadata") + wb$metadata <- xml_add_child(wb$metadata, cM) - # create a data frame - if (!is_data_frame) - data <- as.data.frame(t(data)) + attr(dfx, "c_cm") <- cnt + formula <- "cm_formula" + } - data_nrow <- NROW(data) - data_ncol <- NCOL(data) + class(dfx$X) <- c("character", formula) + if (!is.null(dims)) { + if (array || cm) { + attr(dfx, "f_ref") <- dims + } + } - endRow <- (startRow - 1) + data_nrow - endCol <- (startCol - 1) + data_ncol + if (any(grepl("=([\\s]*?)HYPERLINK\\(", x, perl = TRUE))) { + class(dfx$X) <- c("character", "formula", "hyperlink") + } - dims <- paste0( - int2col(startCol), startRow, + 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, + apply_cell_style = apply_cell_style, + remove_cell_style = remove_cell_style + ) + +} + +# `write_datatable()` ---------------------- +#' 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 start_col A vector specifying the starting column to write df +#' @param start_row 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 col_names If `TRUE`, column names of x are written. +#' @param row_names If `TRUE`, row names of x are written. +#' @param table_style Any excel table style name or "none" (see "formatting" vignette). +#' @param table_name name of table in workbook. The table name must be unique. +#' @param with_filter 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). +#' \cr\cr +#' \cr**The below options correspond to Excel table options:** +#' \cr +#' \if{html}{\figure{tableoptions.png}{options: width="40\%" alt="Figure: table_options.png"}} +#' \if{latex}{\figure{tableoptions.pdf}{options: width=7cm}} +#' +#' @param first_column logical. If TRUE, the first column is bold +#' @param last_column logical. If TRUE, the last column is bold +#' @param banded_rows logical. If TRUE, rows are color banded +#' @param banded_cols logical. If TRUE, the columns are color banded +#' @param apply_cell_style apply styles when writing on the sheet +#' @param remove_cell_style if writing into existing cells, should the cell style be removed? +#' @param na.strings Value used for replacing `NA` values from `x`. Default +#' `na_strings()` uses the special `#N/A` value within the workbook. +#' @param inline_strings write characters as inline strings +#' @param ... additional arguments +#' @details columns of x with class Date/POSIXt, currency, accounting, +#' hyperlink, percentage are automatically styled as dates, currency, accounting, +#' hyperlinks, percentages respectively. +#' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame +#' contains this string, the output will be broken. +#' @seealso +#' [wb_add_worksheet()] +#' [write_data()] +#' [wb_remove_tables()] +#' [wb_get_tables()] +#' @examples +#' ## see package vignettes for further examples. +#' +#' ##################################################################################### +#' ## Create Workbook object and add worksheets +#' wb <- wb_workbook() +#' wb$add_worksheet("S1") +#' wb$add_worksheet("S2") +#' wb$add_worksheet("S3") +#' +#' ##################################################################################### +#' ## -- write data.frame as an Excel table with column filters +#' ## -- default table style is "TableStyleMedium2" +#' +#' wb$add_data_table("S1", x = iris) +#' +#' wb$add_data_table("S2", +#' x = mtcars, dims = c("B3"), rowNames = TRUE, +#' tableStyle = "TableStyleLight9" +#' ) +#' +#' df <- data.frame( +#' "Date" = Sys.Date() - 0:19, +#' "T" = TRUE, "F" = FALSE, +#' "Time" = Sys.time() - 0:19 * 60 * 60, +#' "Cash" = paste("$", 1:20), "Cash2" = 31:50, +#' "hLink" = "https://CRAN.R-project.org/", +#' "Percentage" = seq(0, 1, length.out = 20), +#' "TinyNumbers" = runif(20) / 1E9, stringsAsFactors = FALSE +#' ) +#' +#' ## openxlsx will apply default Excel styling for these classes +#' class(df$Cash) <- c(class(df$Cash), "currency") +#' class(df$Cash2) <- c(class(df$Cash2), "accounting") +#' class(df$hLink) <- "hyperlink" +#' class(df$Percentage) <- c(class(df$Percentage), "percentage") +#' class(df$TinyNumbers) <- c(class(df$TinyNumbers), "scientific") +#' +#' wb$add_data_table("S3", x = df, startRow = 4, rowNames = TRUE, tableStyle = "TableStyleMedium9") +#' +#' ##################################################################################### +#' ## Additional Header Styling and remove column filters +#' +#' write_datatable(wb, +#' sheet = 1, +#' x = iris, +#' startCol = 7, +#' withFilter = FALSE, +#' firstColumn = TRUE, +#' lastColumn = TRUE, +#' bandedRows = TRUE, +#' bandedCols = TRUE +#' ) +#' +#' ##################################################################################### +#' ## Pre-defined table styles gallery +#' +#' wb <- wb_workbook(paste0("tableStylesGallery.xlsx")) +#' wb$add_worksheet("Style Samples") +#' for (i in 1:21) { +#' style <- paste0("TableStyleLight", i) +#' write_datatable(wb, +#' x = data.frame(style), sheet = 1, +#' tableStyle = style, startRow = 1, startCol = i * 3 - 2 +#' ) +#' } +#' +#' for (i in 1:28) { +#' style <- paste0("TableStyleMedium", i) +#' write_datatable(wb, +#' x = data.frame(style), sheet = 1, +#' tableStyle = style, startRow = 4, startCol = i * 3 - 2 +#' ) +#' } +#' +#' for (i in 1:11) { +#' style <- paste0("TableStyleDark", i) +#' write_datatable(wb, +#' x = data.frame(style), sheet = 1, +#' tableStyle = style, startRow = 7, startCol = i * 3 - 2 +#' ) +#' } +#' @export +write_datatable <- function( + wb, + sheet, + x, + dims = rowcol_to_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, + ... +) { + + 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 + ) +} +# Internal helpers of `write_data*` -------------------------------------------- +#' 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. +#' @noRd +inner_update <- function( + wb, + sheet_id, + x, + rows, + cells_needed, + colNames = FALSE, + removeCellStyle = FALSE, + na.strings = na_strings() +) { + + # 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("") + } + + if (is_na_strings(na.strings)) { + na.strings <- NULL + } + + if (removeCellStyle) { + cell_style <- "c_s" + } else { + cell_style <- NULL + } + + replacement <- c("r", cell_style, "c_t", "c_cm", "c_ph", "c_vm", "v", + "f", "f_t", "f_ref", "f_ca", "f_si", "is", "typ") + + sel <- match(x$r, cc$r) + cc[sel, replacement] <- x[replacement] + + # avoid missings in cc + if (any(is.na(cc))) + cc[is.na(cc)] <- "" + + # push everything back to workbook + wb$worksheets[[sheet_id]]$sheet_data$cc <- cc + + wb +} +# `write_data2()` ------------------------------------- +#' 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 +#' `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 +#' @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 +) { + + is_data_frame <- FALSE + #### prepare the correct data formats for openxml + dc <- openxlsx2_type(data) + + # convert factor to character + if (any(dc == openxlsx2_celltype[["factor"]])) { + is_factor <- dc == openxlsx2_celltype[["factor"]] + fcts <- names(dc[is_factor]) + data[fcts] <- lapply(data[fcts], to_string) + # dc <- openxlsx2_type(data) + } + + hconvert_date1904 <- grepl('date1904="1"|date1904="true"', + 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) + colNames <- FALSE + } + + if (inherits(data, "data.frame") || inherits(data, "matrix")) { + is_data_frame <- TRUE + + if (is.data.frame(data)) data <- as.data.frame(data) + + sel <- !dc %in% c(4, 5, 10) + data[sel] <- lapply(data[sel], as.character) + + # add rownames + if (rowNames) { + data <- cbind("_rowNames_" = rownames(data), data) + dc <- c(c("_rowNames_" = openxlsx2_celltype[["character"]]), dc) + } + + # add colnames + if (colNames) + data <- rbind(colnames(data), data) + } + + + sheetno <- wb_validate_sheet(wb, sheet) + # message("sheet no: ", sheetno) + + # create a data frame + if (!is_data_frame) + data <- as.data.frame(t(data)) + + data_nrow <- NROW(data) + data_ncol <- NCOL(data) + + endRow <- (startRow - 1) + data_nrow + endCol <- (startCol - 1) + data_ncol + + dims <- paste0( + int2col(startCol), startRow, ":", int2col(endCol), endRow ) @@ -353,1089 +796,644 @@ write_data2 <- function( 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") - } - } - - string_nums <- getOption("openxlsx2.string_nums", default = 0) - - 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 - } - - wide_to_long( - data, - dc, - cc, - ColNames = colNames, - start_col = startCol, - start_row = startRow, - ref = 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 - ) - - # if rownames = TRUE and data_table = FALSE, remove "_rownames_" - if (!data_table && rowNames && colNames) { - cc <- cc[cc$r != rtyp[1, 1], ] - } - - if (is.null(wb$worksheets[[sheetno]]$sheet_data$cc)) { - - wb$worksheets[[sheetno]]$dimension <- paste0("") - - 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_cols <- names(rtyp[sel == TRUE]) - 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) - - wb$add_font( - sheet = sheetno, - dim = dim_sel, - color = wb_color(hex = "FF0000FF"), - name = wb_get_base_font(wb)$name$val, - u = "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, - dim = dim_sel, - applyNumberFormat = "1", - quotePrefix = "1", - numFmtId = "49" - ) - } - } - - # options("openxlsx2.numFmt" = NULL) - if (any(dc == openxlsx2_celltype[["numeric"]])) { # numeric or integer - if (!is.null(unlist(options("openxlsx2.numFmt")))) { - - numfmt_numeric <- unlist(options("openxlsx2.numFmt")) - - dim_sel <- get_data_class_dims("numeric") - # message("numeric: ", dim_sel) - - wb$add_numfmt( - sheet = sheetno, - dim = dim_sel, - numfmt = numfmt_numeric - ) - } - } - if (any(dc == openxlsx2_celltype[["short_date"]])) { # Date - if (is.null(unlist(options("openxlsx2.dateFormat")))) { - numfmt_dt <- 14 - } else { - numfmt_dt <- unlist(options("openxlsx2.dateFormat")) - } - - dim_sel <- get_data_class_dims("short_date") - # message("short_date: ", dim_sel) - - wb$add_numfmt( - sheet = sheetno, - dim = dim_sel, - numfmt = numfmt_dt - ) - } - if (any(dc == openxlsx2_celltype[["long_date"]])) { - if (is.null(unlist(options("openxlsx2.datetimeFormat")))) { - numfmt_posix <- 22 - } else { - numfmt_posix <- unlist(options("openxlsx2.datetimeFormat")) - } - - dim_sel <- get_data_class_dims("long_date") - # message("long_date: ", dim_sel) - - wb$add_numfmt( - sheet = sheetno, - dim = dim_sel, - numfmt = numfmt_posix - ) - } - if (any(dc == openxlsx2_celltype[["hms_time"]])) { - if (is.null(unlist(options("openxlsx2.hmsFormat")))) { - numfmt_hms <- 21 - } else { - numfmt_hms <- unlist(options("openxlsx2.hmsFormat")) - } - - dim_sel <- get_data_class_dims("hms_time") - # message("hms: ", dim_sel) - - wb$add_numfmt( - sheet = sheetno, - dim = dim_sel, - numfmt = numfmt_hms - ) - } - if (any(dc == openxlsx2_celltype[["accounting"]])) { # accounting - if (is.null(unlist(options("openxlsx2.accountingFormat")))) { - numfmt_accounting <- 4 - } else { - numfmt_accounting <- unlist(options("openxlsx2.accountingFormat")) - } - - dim_sel <- get_data_class_dims("accounting") - # message("accounting: ", dim_sel) - - wb$add_numfmt( - dim = dim_sel, - numfmt = numfmt_accounting - ) - } - if (any(dc == openxlsx2_celltype[["percentage"]])) { # percentage - if (is.null(unlist(options("openxlsx2.percentageFormat")))) { - numfmt_percentage <- 10 - } else { - numfmt_percentage <- unlist(options("openxlsx2.percentageFormat")) - } - - dim_sel <- get_data_class_dims("percentage") - # message("percentage: ", dim_sel) - - wb$add_numfmt( - sheet = sheetno, - dim = dim_sel, - numfmt = numfmt_percentage - ) - } - if (any(dc == openxlsx2_celltype[["scientific"]])) { - if (is.null(unlist(options("openxlsx2.scientificFormat")))) { - numfmt_scientific <- 48 - } else { - numfmt_scientific <- unlist(options("openxlsx2.scientificFormat")) - } - - dim_sel <- get_data_class_dims("scientific") - # message("scientific: ", dim_sel) - - wb$add_numfmt( - sheet = sheetno, - dim = dim_sel, - numfmt = numfmt_scientific - ) - } - if (any(dc == openxlsx2_celltype[["comma"]])) { - if (is.null(unlist(options("openxlsx2.comma")))) { - numfmt_comma <- 3 - } else { - numfmt_comma <- unlist(options("openxlsx2.commaFormat")) - } - - dim_sel <- get_data_class_dims("comma") - # message("comma: ", dim_sel) - - wb$add_numfmt( - sheet = sheetno, - dim = dim_sel, - numfmt = numfmt_comma - ) + from_enc <- getOption("openxlsx2.native_encoding") + data[sel] <- lapply(data[sel], stringi::stri_encode, from = from_enc, to = "UTF-8") } } - ### End styles - - # update shared strings if we use shared strings - if (!inline_strings) { - cc <- wb$worksheets[[sheetno]]$sheet_data$cc + string_nums <- getOption("openxlsx2.string_nums", default = 0) - sel <- grepl("", cc$v) - cc_sst <- stringi::stri_unique(cc[sel, "v"]) + na_missing <- FALSE + na_null <- FALSE - wb$sharedStrings <- stringi::stri_unique(c(wb$sharedStrings, cc_sst)) + if (is_na_strings(na.strings)) { + na.strings <- "" + na_missing <- TRUE + } else if (is.null(na.strings)) { + na.strings <- "" + na_null <- TRUE + } - sel <- grepl("", cc$v) - cc$v[sel] <- as.character(match(cc$v[sel], wb$sharedStrings) - 1L) + wide_to_long( + data, + dc, + cc, + ColNames = colNames, + start_col = startCol, + start_row = startRow, + ref = 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 + ) - text <- si_to_txt(wb$sharedStrings) - uniqueCount <- length(wb$sharedStrings) + # if rownames = TRUE and data_table = FALSE, remove "_rownames_" + if (!data_table && rowNames && colNames) { + cc <- cc[cc$r != rtyp[1, 1], ] + } - attr(wb$sharedStrings, "uniqueCount") <- uniqueCount - attr(wb$sharedStrings, "text") <- text + if (is.null(wb$worksheets[[sheetno]]$sheet_data$cc)) { - wb$worksheets[[sheetno]]$sheet_data$cc <- cc + wb$worksheets[[sheetno]]$dimension <- paste0("") - if (!any(grepl("sharedStrings", wb$workbook.xml.rels))) { - wb$append( - "workbook.xml.rels", - "" - ) - } - } + wb$worksheets[[sheetno]]$sheet_data$row_attr <- rows_attr - ### Update calcChain - if (length(wb$calcChain)) { + wb$worksheets[[sheetno]]$sheet_data$cc <- cc - # 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% rtyp & 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 - } + } 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 + ) } - ### 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 -#' `na_strings()` uses the special `#N/A` value within the workbook. -#' @param inline_strings optional write strings as inline strings -#' @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 -) { + ### Begin styles - ## Input validating - assert_workbook(wb) - if (missing(x)) stop("`x` is missing") - 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") + if (applyCellStyle) { - # force with globalenv() options - x <- force(x) + ## 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_cols <- names(rtyp[sel == TRUE]) + sel_rows <- rownames(rtyp) - op <- openxlsx2_options() - on.exit(options(op), add = TRUE) + # ignore first row if colNames + if (colNames) sel_rows <- sel_rows[-1] - if (!is.null(dims)) { - dims <- dims_to_rowcol(dims, as_integer = TRUE) - startCol <- min(dims[[1]]) - startRow <- min(dims[[2]]) - } + dataframe_to_dims(rtyp[rownames(rtyp) %in% sel_rows, sel_cols, drop = FALSE]) + } - if (data_table && nrow(x) < 1) { - warning("Found data table with zero rows, adding one.", - " Modify na with na.strings") - x[1, ] <- NA - } + # if hyperlinks are found, Excel sets something like the following font + # blue with underline + if (any(dc == openxlsx2_celltype[["hyperlink"]])) { - ## common part --------------------------------------------------------------- - if ((!is.character(sep)) || (length(sep) != 1)) - stop("sep must be a character vector of length 1") + dim_sel <- get_data_class_dims("hyperlink") + # message("hyperlink: ", dim_sel) - # TODO clean up when moved into wbWorkbook - sheet <- wb$.__enclos_env__$private$get_sheet_index(sheet) - # sheet <- wb$validate_sheet(sheet) + wb$add_font( + sheet = sheetno, + dim = dim_sel, + color = wb_color(hex = "FF0000FF"), + name = wb_get_base_font(wb)$name$val, + u = "single" + ) + } - if (wb$is_chartsheet[[sheet]]) stop("Cannot write to chart sheet.") + if (any(dc == openxlsx2_celltype[["character"]])) { + if (any(sel <- cc$typ == openxlsx2_celltype[["string_nums"]])) { - ## convert startRow and startCol - if (!is.numeric(startCol)) { - startCol <- col2int(startCol) - } - startRow <- as.integer(startRow) + # # 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) - ## special case - vector of hyperlinks - is_hyperlink <- FALSE - if (applyCellStyle) { - if (is.null(dim(x))) { - is_hyperlink <- inherits(x, "hyperlink") - } else { - is_hyperlink <- vapply(x, inherits, what = "hyperlink", FALSE) + wb$add_cell_style( + sheet = sheetno, + dim = dim_sel, + applyNumberFormat = "1", + quotePrefix = "1", + numFmtId = "49" + ) + } } - 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))) { - x[is_hyperlink] <- create_hyperlink(text = x[is_hyperlink]) - } - class(x[is_hyperlink]) <- c("character", "hyperlink") - } else { - # 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") + # options("openxlsx2.numFmt" = NULL) + if (any(dc == openxlsx2_celltype[["numeric"]])) { # numeric or integer + if (!is.null(unlist(options("openxlsx2.numFmt")))) { + + numfmt_numeric <- unlist(options("openxlsx2.numFmt")) + + dim_sel <- get_data_class_dims("numeric") + # message("numeric: ", dim_sel) + + wb$add_numfmt( + sheet = sheetno, + dim = dim_sel, + numfmt = numfmt_numeric + ) } } - } - - ### Create data frame -------------------------------------------------------- + if (any(dc == openxlsx2_celltype[["short_date"]])) { # Date + if (is.null(unlist(options("openxlsx2.dateFormat")))) { + numfmt_dt <- 14 + } else { + numfmt_dt <- unlist(options("openxlsx2.dateFormat")) + } - ## 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 - } + dim_sel <- get_data_class_dims("short_date") + # message("short_date: ", dim_sel) - if (is.vector(x) || is.factor(x) || inherits(x, "Date") || inherits(x, "POSIXt")) { - colNames <- FALSE - } ## this will go to coerce.default and rowNames will be ignored + wb$add_numfmt( + sheet = sheetno, + dim = dim_sel, + numfmt = numfmt_dt + ) + } + if (any(dc == openxlsx2_celltype[["long_date"]])) { + if (is.null(unlist(options("openxlsx2.datetimeFormat")))) { + numfmt_posix <- 22 + } else { + numfmt_posix <- unlist(options("openxlsx2.datetimeFormat")) + } - ## Coerce to data.frame - if (inherits(x, "hyperlink")) { - ## vector of hyperlinks - class(x) <- c("character", "hyperlink") - x <- as.data.frame(x, stringsAsFactors = FALSE) - } else if (!inherits(x, "data.frame")) { - x <- as.data.frame(x, stringsAsFactors = FALSE) - } + dim_sel <- get_data_class_dims("long_date") + # message("long_date: ", dim_sel) - nCol <- ncol(x) - nRow <- nrow(x) + wb$add_numfmt( + sheet = sheetno, + dim = dim_sel, + numfmt = numfmt_posix + ) + } + if (any(dc == openxlsx2_celltype[["hms_time"]])) { + if (is.null(unlist(options("openxlsx2.hmsFormat")))) { + numfmt_hms <- 21 + } else { + numfmt_hms <- unlist(options("openxlsx2.hmsFormat")) + } - ### Beg: Only in data -------------------------------------------------------- - if (!data_table) { + dim_sel <- get_data_class_dims("hms_time") + # message("hms: ", dim_sel) - ## write autoFilter, can only have a single filter per worksheet - if (withFilter) { - coords <- data.frame("x" = c(startRow, startRow + nRow + colNames - 1L), "y" = c(startCol, startCol + nCol - 1L)) - ref <- stri_join(get_cell_refs(coords), collapse = ":") + wb$add_numfmt( + sheet = sheetno, + dim = dim_sel, + numfmt = numfmt_hms + ) + } + if (any(dc == openxlsx2_celltype[["accounting"]])) { # accounting + if (is.null(unlist(options("openxlsx2.accountingFormat")))) { + numfmt_accounting <- 4 + } else { + numfmt_accounting <- unlist(options("openxlsx2.accountingFormat")) + } - wb$worksheets[[sheet]]$autoFilter <- sprintf('', ref) + dim_sel <- get_data_class_dims("accounting") + # message("accounting: ", dim_sel) - l <- int2col(unlist(coords[, 2])) - dfn <- sprintf("'%s'!%s", wb$get_sheet_names()[sheet], stri_join("$", l, "$", coords[, 1], collapse = ":")) + wb$add_numfmt( + dim = dim_sel, + numfmt = numfmt_accounting + ) + } + if (any(dc == openxlsx2_celltype[["percentage"]])) { # percentage + if (is.null(unlist(options("openxlsx2.percentageFormat")))) { + numfmt_percentage <- 10 + } else { + numfmt_percentage <- unlist(options("openxlsx2.percentageFormat")) + } - dn <- sprintf('', sheet - 1L, dfn) + dim_sel <- get_data_class_dims("percentage") + # message("percentage: ", dim_sel) - if (length(wb$workbook$definedNames) > 0) { - ind <- grepl('name="_xlnm._FilterDatabase"', wb$workbook$definedNames) - if (length(ind) > 0) { - wb$workbook$definedNames[ind] <- dn - } + wb$add_numfmt( + sheet = sheetno, + dim = dim_sel, + numfmt = numfmt_percentage + ) + } + if (any(dc == openxlsx2_celltype[["scientific"]])) { + if (is.null(unlist(options("openxlsx2.scientificFormat")))) { + numfmt_scientific <- 48 } else { - wb$workbook$definedNames <- dn + numfmt_scientific <- unlist(options("openxlsx2.scientificFormat")) } + + dim_sel <- get_data_class_dims("scientific") + # message("scientific: ", dim_sel) + + wb$add_numfmt( + sheet = sheetno, + dim = dim_sel, + numfmt = numfmt_scientific + ) } - } - ### End: Only in data -------------------------------------------------------- + if (any(dc == openxlsx2_celltype[["comma"]])) { + if (is.null(unlist(options("openxlsx2.comma")))) { + numfmt_comma <- 3 + } else { + numfmt_comma <- unlist(options("openxlsx2.commaFormat")) + } - 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." + dim_sel <- get_data_class_dims("comma") + # message("comma: ", dim_sel) + + wb$add_numfmt( + sheet = sheetno, + dim = dim_sel, + numfmt = numfmt_comma + ) + } } + ### End styles - ## 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 - ) + # update shared strings if we use shared strings + if (!inline_strings) { - ## 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 - ) + cc <- wb$worksheets[[sheetno]]$sheet_data$cc - ### Beg: Only in datatable --------------------------------------------------- + sel <- grepl("", cc$v) + cc_sst <- stringi::stri_unique(cc[sel, "v"]) - # 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) { + wb$sharedStrings <- stringi::stri_unique(c(wb$sharedStrings, cc_sst)) - ## replace invalid XML characters - col_names <- replace_legal_chars(colnames(x)) - if (rowNames) col_names <- c("_rowNames_", col_names) + sel <- grepl("", cc$v) + cc$v[sel] <- as.character(match(cc$v[sel], wb$sharedStrings) - 1L) - ## Table name validation - if (is.null(tableName)) { - tableName <- paste0("Table", as.character(NROW(wb$tables) + 1L)) - } else { - tableName <- wb_validate_table_name(wb, tableName) - } + text <- si_to_txt(wb$sharedStrings) + uniqueCount <- length(wb$sharedStrings) - ## 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) - } + attr(wb$sharedStrings, "uniqueCount") <- uniqueCount + attr(wb$sharedStrings, "text") <- text - tableStyle <- tableStyle[!is.na(tableStyle)] - if (length(tableStyle) == 0) { - stop("Unknown table style.") - } + wb$worksheets[[sheetno]]$sheet_data$cc <- cc - ## If zero rows, append an empty row (prevent XML from corrupting) - if (nrow(x) == 0) { - x <- rbind(as.data.frame(x), matrix("", nrow = 1, ncol = nCol, dimnames = list(character(), colnames(x)))) - names(x) <- colNames + if (!any(grepl("sharedStrings", wb$workbook.xml.rels))) { + wb$append( + "workbook.xml.rels", + "" + ) } + } - ref1 <- paste0(int2col(startCol), startRow) - ref2 <- paste0(int2col(startCol + nCol - !rowNames), startRow + nRow) - ref <- paste(ref1, ref2, sep = ":") + ### Update calcChain + if (length(wb$calcChain)) { - ## 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, - withFilter = withFilter, - totalsRowCount = 0L, - showFirstColumn = firstColumn, - showLastColumn = lastColumn, - showRowStripes = bandedRows, - showColumnStripes = bandedCols - ) - } + # 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% rtyp & 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: Only in datatable --------------------------------------------------- + } + ### End update calcChain return(wb) } - -# `write_data()` --------------------------------------------------------------- -#' Write an object to a worksheet -#' -#' Write an object to worksheet with optional styling. +# `write_data_table()` --------------------------------------------------------- +#' Write to a worksheet as an Excel table #' -#' Formulae written using write_formula to a Workbook object will not get picked up by read_xlsx(). -#' This is because only the formula is written and left to Excel to evaluate the formula when the file is opened in Excel. -#' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame contains this string, the output will be broken. +#' `write_data_table()` an internal driver function to `write_data` and `write_datatable` +#' 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 Object to be written. For classes supported look at the examples. -#' @param start_col A vector specifying the starting column to write to. -#' @param start_row A vector specifying the starting row to write to. +#' @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 col_names If `TRUE`, column names of x are written. -#' @param row_names If `TRUE`, data.frame row names of x are written. -#' @param with_filter If `TRUE`, add filters to the column name row. NOTE can only have one filter per worksheet. +#' @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 apply_cell_style apply styles when writing on the sheet -#' @param remove_cell_style if writing into existing cells, should the cell style be removed? +#' @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 #' `na_strings()` uses the special `#N/A` value within the workbook. -#' @param inline_strings write characters as inline strings -#' @param ... additional arguments -#' @seealso [write_datatable()] -#' @return invisible(0) -#' @examples -#' ## See formatting vignette for further examples. -#' -#' ## Options for default styling (These are the defaults) -#' options("openxlsx2.dateFormat" = "mm/dd/yyyy") -#' options("openxlsx2.datetimeFormat" = "yyyy-mm-dd hh:mm:ss") -#' options("openxlsx2.numFmt" = NULL) -#' -#' ############################################################################# -#' ## Create Workbook object and add worksheets -#' wb <- wb_workbook() -#' -#' ## Add worksheets -#' wb$add_worksheet("Cars") -#' wb$add_worksheet("Formula") -#' -#' x <- mtcars[1:6, ] -#' wb$add_data("Cars", x, startCol = 2, startRow = 3, rowNames = TRUE) -#' -#' ############################################################################# -#' ## Hyperlinks -#' ## - vectors/columns with class 'hyperlink' are written as hyperlinks' -#' -#' v <- rep("https://CRAN.R-project.org/", 4) -#' names(v) <- paste0("Hyperlink", 1:4) # Optional: names will be used as display text -#' class(v) <- "hyperlink" -#' wb$add_data("Cars", x = v, dims = c("B32")) -#' -#' ############################################################################# -#' ## Formulas -#' ## - vectors/columns with class 'formula' are written as formulas' -#' -#' df <- data.frame( -#' x = 1:3, y = 1:3, -#' z = paste(paste0("A", 1:3 + 1L), paste0("B", 1:3 + 1L), sep = "+"), -#' stringsAsFactors = FALSE -#' ) -#' -#' class(df$z) <- c(class(df$z), "formula") -#' -#' wb$add_data(sheet = "Formula", x = df) -#' -#' ############################################################################# -#' # update cell range and add mtcars -#' xlsxFile <- system.file("extdata", "openxlsx2_example.xlsx", package = "openxlsx2") -#' wb2 <- wb_load(xlsxFile) -#' -#' # read dataset with inlinestr -#' wb_to_df(wb2) -#' write_data(wb2, 1, mtcars, startCol = 4, startRow = 4) -#' wb_to_df(wb2) -#' @export -write_data <- function( - wb, - sheet, - x, - dims = rowcol_to_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, - ... -) { - - 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 - ) -} - -# write_formula() ------------------------------------------- -#' Write a character vector as an Excel Formula -#' -#' Write a a character vector containing Excel formula to a worksheet. -#' -#' @details -#' Currently only the English version of functions are supported. Please don't use the local translation. -#' The examples below show a small list of possible formulas: -#' * SUM(B2:B4) -#' * AVERAGE(B2:B4) -#' * MIN(B2:B4) -#' * MAX(B2:B4) -#' * ... -#' -#' @param wb A Workbook object containing a worksheet. -#' @param sheet The worksheet to write to. Can be the worksheet index or name. -#' @param x A character vector. -#' @param dims Spreadsheet dimensions that will determine startCol and startRow: "A1", "A1:B2", "A:B" -#' @param start_col A vector specifying the starting column to write to. -#' @param start_row A vector specifying the starting row to write to. -#' @param array A bool if the function written is of type array -#' @param cm A bool if the function is of type cm (array with hidden curly braces) -#' @param apply_cell_style apply styles when writing on the sheet -#' @param remove_cell_style if writing into existing cells, should the cell style be removed? -#' @param ... additional arguments -#' @seealso [write_data()] -#' @examples -#' ## There are 3 ways to write a formula -#' -#' wb <- wb_workbook() -#' wb$add_worksheet("Sheet 1") -#' wb$add_data("Sheet 1", x = iris) -#' -#' ## SEE `int2col()` to convert int to Excel column label -#' -#' ## 1. - As a character vector using write_formula -#' -#' v <- c("SUM(A2:A151)", "AVERAGE(B2:B151)") ## skip header row -#' write_formula(wb, sheet = 1, x = v, startCol = 10, startRow = 2) -#' write_formula(wb, 1, x = "A2 + B2", startCol = 10, startRow = 10) -#' -#' -#' ## 2. - As a data.frame column with class "formula" using write_data -#' -#' df <- data.frame( -#' x = 1:3, -#' y = 1:3, -#' z = paste(paste0("A", 1:3 + 1L), paste0("B", 1:3 + 1L), sep = " + "), -#' z2 = sprintf("ADDRESS(1,%s)", 1:3), -#' stringsAsFactors = FALSE -#' ) -#' -#' class(df$z) <- c(class(df$z), "formula") -#' class(df$z2) <- c(class(df$z2), "formula") -#' -#' wb$add_worksheet("Sheet 2") -#' wb$add_data(sheet = 2, x = df) -#' -#' -#' ## 3. - As a vector with class "formula" using write_data -#' -#' v2 <- c("SUM(A2:A4)", "AVERAGE(B2:B4)", "MEDIAN(C2:C4)") -#' class(v2) <- c(class(v2), "formula") -#' -#' wb$add_data(sheet = 2, x = v2, startCol = 10, startRow = 2) -#' -#' -#' ## 4. - Writing internal hyperlinks -#' -#' wb <- wb_workbook() -#' wb$add_worksheet("Sheet1") -#' wb$add_worksheet("Sheet2") -#' write_formula(wb, "Sheet1", x = '=HYPERLINK("#Sheet2!B3", "Text to Display - Link to Sheet2")') -#' -#' -#' ## 5. - Writing array formulas -#' -#' set.seed(123) -#' df <- data.frame(C = rnorm(10), D = rnorm(10)) -#' -#' wb <- wb_workbook() -#' wb <- wb_add_worksheet(wb, "df") -#' -#' wb$add_data("df", df, startCol = "C") -#' -#' write_formula(wb, "df", startCol = "E", startRow = "2", -#' x = "SUM(C2:C11*D2:D11)", -#' array = TRUE) -#' @export -write_formula <- function( +#' @param inline_strings optional write strings as inline strings +#' @noRd +write_data_table <- function( wb, sheet, x, - dims = rowcol_to_dims(start_row, start_col), - start_col = 1, - start_row = 1, - array = FALSE, - cm = FALSE, - apply_cell_style = TRUE, - remove_cell_style = FALSE, - ... + 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 ) { - standardize_case_names(...) + ## Input validating + assert_workbook(wb) + if (missing(x)) stop("`x` is missing") + 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") - assert_class(x, "character") - # remove xml encoding and reapply it afterwards. until v0.3 encoding was not enforced - x <- replaceXMLEntities(x) - x <- vapply(x, function(val) xml_value(xml_node_create("fml", val, escapes = TRUE), "fml"), NA_character_) - dfx <- data.frame("X" = x, stringsAsFactors = FALSE) + # force with globalenv() options + x <- force(x) - formula <- "formula" - if (array) formula <- "array_formula" - if (cm) { - # need to set cell metadata in wb$metadata - if (is.null(wb$metadata)) { + op <- openxlsx2_options() + on.exit(options(op), add = TRUE) - wb$append("Content_Types", "") + if (!is.null(dims)) { + dims <- dims_to_rowcol(dims, as_integer = TRUE) + startCol <- min(dims[[1]]) + startRow <- min(dims[[2]]) + } - 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( - " - - - - - - - - - - - , - ", - pointer = FALSE + if (data_table && nrow(x) < 1) { + warning("Found data table with zero rows, adding one.", + " Modify na with na.strings") + x[1, ] <- NA + } + + ## 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 + is_hyperlink <- FALSE + if (applyCellStyle) { + if (is.null(dim(x))) { + is_hyperlink <- inherits(x, "hyperlink") + } else { + 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))) { + x[is_hyperlink] <- create_hyperlink(text = x[is_hyperlink]) + } + class(x[is_hyperlink]) <- c("character", "hyperlink") + } else { + # 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") + } } + } - ## 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 = "") + ### Create data frame -------------------------------------------------------- - # 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)) + ## 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 + } - # remove current cellMetadata update new - wb$metadata <- xml_rm_child(wb$metadata, "cellMetadata") - wb$metadata <- xml_add_child(wb$metadata, cM) + if (is.vector(x) || is.factor(x) || inherits(x, "Date") || inherits(x, "POSIXt")) { + colNames <- FALSE + } ## this will go to coerce.default and rowNames will be ignored - attr(dfx, "c_cm") <- cnt - formula <- "cm_formula" + ## Coerce to data.frame + if (inherits(x, "hyperlink")) { + ## vector of hyperlinks + class(x) <- c("character", "hyperlink") + x <- as.data.frame(x, stringsAsFactors = FALSE) + } else if (!inherits(x, "data.frame")) { + x <- as.data.frame(x, stringsAsFactors = FALSE) } - class(dfx$X) <- c("character", formula) - if (!is.null(dims)) { - if (array || cm) { - attr(dfx, "f_ref") <- dims + 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) { + coords <- data.frame("x" = c(startRow, startRow + nRow + colNames - 1L), "y" = c(startCol, startCol + nCol - 1L)) + ref <- stri_join(get_cell_refs(coords), collapse = ":") + + wb$worksheets[[sheet]]$autoFilter <- sprintf('', ref) + + l <- int2col(unlist(coords[, 2])) + dfn <- sprintf("'%s'!%s", wb$get_sheet_names()[sheet], stri_join("$", l, "$", coords[, 1], collapse = ":")) + + dn <- sprintf('', sheet - 1L, dfn) + + if (length(wb$workbook$definedNames) > 0) { + ind <- grepl('name="_xlnm._FilterDatabase"', wb$workbook$definedNames) + if (length(ind) > 0) { + wb$workbook$definedNames[ind] <- dn + } + } else { + wb$workbook$definedNames <- dn + } + } + } + ### 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 + ) + + ### 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", as.character(NROW(wb$tables) + 1L)) + } else { + tableName <- wb_validate_table_name(wb, tableName) + } + + ## 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), matrix("", nrow = 1, ncol = nCol, dimnames = list(character(), colnames(x)))) + names(x) <- colNames } - } - if (any(grepl("=([\\s]*?)HYPERLINK\\(", x, perl = TRUE))) { - class(dfx$X) <- c("character", "formula", "hyperlink") + 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, + withFilter = withFilter, + totalsRowCount = 0L, + showFirstColumn = firstColumn, + showLastColumn = lastColumn, + showRowStripes = bandedRows, + showColumnStripes = bandedCols + ) } - 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, - apply_cell_style = apply_cell_style, - remove_cell_style = remove_cell_style - ) + ### End: Only in datatable --------------------------------------------------- + return(wb) } - -# `write_datatable()` ---------------------- -#' 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 start_col A vector specifying the starting column to write df -#' @param start_row 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 col_names If `TRUE`, column names of x are written. -#' @param row_names If `TRUE`, row names of x are written. -#' @param table_style Any excel table style name or "none" (see "formatting" vignette). -#' @param table_name name of table in workbook. The table name must be unique. -#' @param with_filter 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). -#' \cr\cr -#' \cr**The below options correspond to Excel table options:** -#' \cr -#' \if{html}{\figure{tableoptions.png}{options: width="40\%" alt="Figure: table_options.png"}} -#' \if{latex}{\figure{tableoptions.pdf}{options: width=7cm}} -#' -#' @param first_column logical. If TRUE, the first column is bold -#' @param last_column logical. If TRUE, the last column is bold -#' @param banded_rows logical. If TRUE, rows are color banded -#' @param banded_cols logical. If TRUE, the columns are color banded -#' @param apply_cell_style apply styles when writing on the sheet -#' @param remove_cell_style if writing into existing cells, should the cell style be removed? -#' @param na.strings Value used for replacing `NA` values from `x`. Default -#' `na_strings()` uses the special `#N/A` value within the workbook. -#' @param inline_strings write characters as inline strings -#' @param ... additional arguments -#' @details columns of x with class Date/POSIXt, currency, accounting, -#' hyperlink, percentage are automatically styled as dates, currency, accounting, -#' hyperlinks, percentages respectively. -#' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame -#' contains this string, the output will be broken. -#' @seealso -#' [wb_add_worksheet()] -#' [write_data()] -#' [wb_remove_tables()] -#' [wb_get_tables()] -#' @examples -#' ## see package vignettes for further examples. -#' -#' ##################################################################################### -#' ## Create Workbook object and add worksheets -#' wb <- wb_workbook() -#' wb$add_worksheet("S1") -#' wb$add_worksheet("S2") -#' wb$add_worksheet("S3") -#' -#' ##################################################################################### -#' ## -- write data.frame as an Excel table with column filters -#' ## -- default table style is "TableStyleMedium2" -#' -#' wb$add_data_table("S1", x = iris) -#' -#' wb$add_data_table("S2", -#' x = mtcars, dims = c("B3"), rowNames = TRUE, -#' tableStyle = "TableStyleLight9" -#' ) -#' -#' df <- data.frame( -#' "Date" = Sys.Date() - 0:19, -#' "T" = TRUE, "F" = FALSE, -#' "Time" = Sys.time() - 0:19 * 60 * 60, -#' "Cash" = paste("$", 1:20), "Cash2" = 31:50, -#' "hLink" = "https://CRAN.R-project.org/", -#' "Percentage" = seq(0, 1, length.out = 20), -#' "TinyNumbers" = runif(20) / 1E9, stringsAsFactors = FALSE -#' ) -#' -#' ## openxlsx will apply default Excel styling for these classes -#' class(df$Cash) <- c(class(df$Cash), "currency") -#' class(df$Cash2) <- c(class(df$Cash2), "accounting") -#' class(df$hLink) <- "hyperlink" -#' class(df$Percentage) <- c(class(df$Percentage), "percentage") -#' class(df$TinyNumbers) <- c(class(df$TinyNumbers), "scientific") -#' -#' wb$add_data_table("S3", x = df, startRow = 4, rowNames = TRUE, tableStyle = "TableStyleMedium9") +# Cell(s) helpers -------------------------------------------- +#' Initialize data cell(s) #' -#' ##################################################################################### -#' ## Additional Header Styling and remove column filters +#' Create a cell in the workbook #' -#' write_datatable(wb, -#' sheet = 1, -#' x = iris, -#' startCol = 7, -#' withFilter = FALSE, -#' firstColumn = TRUE, -#' lastColumn = TRUE, -#' bandedRows = TRUE, -#' bandedCols = TRUE -#' ) +#' @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" #' -#' ##################################################################################### -#' ## Pre-defined table styles gallery +#' @noRd +initialize_cell <- function(wb, sheet, new_cells) { + + sheet_id <- wb$validate_sheet(sheet) + + # create artificial cc for the missing cells + x <- empty_sheet_data_cc(n = length(new_cells)) + x$r <- new_cells + x$row_r <- gsub("[[:upper:]]", "", new_cells) + x$c_r <- gsub("[[:digit:]]", "", new_cells) + + rows <- x$row_r + cells_needed <- new_cells + + inner_update(wb, sheet_id, x, rows, cells_needed) +} + +#' Replace data cell(s) #' -#' wb <- wb_workbook(paste0("tableStylesGallery.xlsx")) -#' wb$add_worksheet("Style Samples") -#' for (i in 1:21) { -#' style <- paste0("TableStyleLight", i) -#' write_datatable(wb, -#' x = data.frame(style), sheet = 1, -#' tableStyle = style, startRow = 1, startCol = i * 3 - 2 -#' ) -#' } +#' Minimal invasive update of cell(s) inside of imported workbooks. #' -#' for (i in 1:28) { -#' style <- paste0("TableStyleMedium", i) -#' write_datatable(wb, -#' x = data.frame(style), sheet = 1, -#' tableStyle = style, startRow = 4, startCol = i * 3 - 2 -#' ) -#' } +#' @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) #' -#' for (i in 1:11) { -#' style <- paste0("TableStyleDark", i) -#' write_datatable(wb, -#' x = data.frame(style), sheet = 1, -#' tableStyle = style, startRow = 7, startCol = i * 3 - 2 -#' ) -#' } -#' @export -write_datatable <- function( - wb, - sheet, - x, - dims = rowcol_to_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, - ... -) { +#' @noRd +update_cell <- function(x, wb, sheet, cell, colNames = FALSE, + removeCellStyle = FALSE, na.strings) { - standardize_case_names(...) + if (missing(na.strings)) + na.strings <- substitute() - 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 - ) + 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) }