diff --git a/DESCRIPTION b/DESCRIPTION index 9e79bfb41..7aedc3a04 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: openxlsx2 Title: Read, Write and Edit 'xlsx' Files -Version: 1.8 +Version: 1.8.0.9000 Language: en-US Authors@R: c( person("Jordan Mark", "Barbone", email = "jmbarbone@gmail.com", role = "aut", comment = c(ORCID = "0000-0001-9788-3628")), diff --git a/NEWS.md b/NEWS.md index 7e89f6641..db87774f7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,12 @@ +# openxlsx2 (development version) + +## New features + +* Experimental support for shared formulas. Similar to spreadsheet software, when a cell is dragged to horizontally or vertically. This requires the formula to be written only for a single cell and it is filled by spreadsheet software for the remaining dimensions. `wb_add_formula()` gained a new argument `shared`. [1074](https://github.com/JanMarvin/openxlsx2/pull/1074) + + +*************************************************************************** + # openxlsx2 1.8 ## Maintenance diff --git a/R/class-workbook-wrappers.R b/R/class-workbook-wrappers.R index 46e4f326e..73b04d105 100644 --- a/R/class-workbook-wrappers.R +++ b/R/class-workbook-wrappers.R @@ -685,6 +685,7 @@ wb_remove_timeline <- function( #' @param apply_cell_style Should we write cell styles to the workbook? #' @param remove_cell_style Should we keep the cell style? #' @param enforce enforce dims +#' @param shared shared formula #' @param ... additional arguments #' @return The workbook, invisibly. #' @family workbook wrappers @@ -705,6 +706,11 @@ wb_remove_timeline <- function( #' add_data(x = mm, dims = "A4:B5", col_names = FALSE)$ #' add_formula(x = "MMULT(A1:B2, A4:B5)", dims = "A7:B8", array = TRUE) #' +#' # add shared formula +#' wb$add_worksheet()$ +#' add_data(x = matrix(rnorm(5*5), ncol = 5, nrow = 5))$ +#' add_formula(x = "SUM($A2:A2)", dims = "A8:E12", shared = TRUE) +#' wb_add_formula <- function( wb, sheet = current_sheet(), @@ -717,6 +723,7 @@ wb_add_formula <- function( apply_cell_style = TRUE, remove_cell_style = FALSE, enforce = FALSE, + shared = FALSE, ... ) { assert_workbook(wb) @@ -731,6 +738,7 @@ wb_add_formula <- function( apply_cell_style = apply_cell_style, remove_cell_style = remove_cell_style, enforce = enforce, + shared = shared, ... = ... ) } diff --git a/R/class-workbook.R b/R/class-workbook.R index c48491ef1..5e5959f04 100644 --- a/R/class-workbook.R +++ b/R/class-workbook.R @@ -2384,6 +2384,7 @@ wbWorkbook <- R6::R6Class( #' @param apply_cell_style applyCellStyle #' @param remove_cell_style if writing into existing cells, should the cell style be removed? #' @param enforce enforce dims + #' @param shared shared formula #' @return The `wbWorkbook` object add_formula = function( sheet = current_sheet(), @@ -2396,6 +2397,7 @@ wbWorkbook <- R6::R6Class( apply_cell_style = TRUE, remove_cell_style = FALSE, enforce = FALSE, + shared = FALSE, ... ) { @@ -2411,7 +2413,8 @@ wbWorkbook <- R6::R6Class( cm = cm, applyCellStyle = apply_cell_style, removeCellStyle = remove_cell_style, - enforce = enforce + enforce = enforce, + shared = shared ) invisible(self) }, diff --git a/R/write.R b/R/write.R index 490dbf878..8a8748a63 100644 --- a/R/write.R +++ b/R/write.R @@ -186,6 +186,7 @@ update_cell <- function(x, wb, sheet, cell, colNames = FALSE, #' @param inline_strings write characters as inline strings #' @param dims worksheet dimensions #' @param enforce enforce dims +#' @param shared shared formula #' @details #' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame #' contains this string, the output will be broken. @@ -221,7 +222,8 @@ write_data2 <- function( data_table = FALSE, inline_strings = TRUE, dims = NULL, - enforce = FALSE + enforce = FALSE, + shared = FALSE ) { dim_sep <- ";" @@ -459,6 +461,28 @@ write_data2 <- function( 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_si <- unique(wb$worksheets[[sheetno]]$sheet_data$cc$f_si) + int_si <- as.integer( + replace( + uni_si, + uni_si == "", + "-1" + ) + ) + + cc$f_t <- "shared" + cc[1, "f_ref"] <- dims + cc[2:nrow(cc), "f"] <- "" + cc$f_si <- max(int_si) + 1L + } + if (is.null(wb$worksheets[[sheetno]]$sheet_data$cc)) { wb$worksheets[[sheetno]]$dimension <- paste0("") @@ -755,6 +779,7 @@ write_data2 <- function( #' 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( @@ -782,7 +807,8 @@ write_data_table <- function( na.strings = na_strings(), inline_strings = TRUE, total_row = FALSE, - enforce = FALSE + enforce = FALSE, + shared = FALSE ) { ## Input validating @@ -985,7 +1011,8 @@ write_data_table <- function( data_table = data_table, inline_strings = inline_strings, dims = if (enforce) odims else dims, - enforce = enforce + enforce = enforce, + shared = shared ) ### Beg: Only in datatable --------------------------------------------------- @@ -1107,6 +1134,7 @@ do_write_data <- function( na.strings = na_strings(), inline_strings = TRUE, enforce = FALSE, + shared = FALSE, ... ) { @@ -1136,7 +1164,8 @@ do_write_data <- function( data_table = FALSE, na.strings = na.strings, inline_strings = inline_strings, - enforce = enforce + enforce = enforce, + shared = shared ) } @@ -1153,10 +1182,14 @@ do_write_formula <- function( apply_cell_style = TRUE, remove_cell_style = FALSE, enforce = FALSE, + shared = FALSE, ... ) { standardize_case_names(...) + if (is.data.frame(x)) + x <- unlist(x) + assert_class(x, "character") # detect array formulas @@ -1166,7 +1199,24 @@ do_write_formula <- function( array <- TRUE } - dfx <- data.frame("X" = x, stringsAsFactors = FALSE) + 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 || enforce) { + dfx <- data.frame("X" = x, stringsAsFactors = FALSE) + } else { + dfx <- dims_to_dataframe(dims) + dfx[] <- x + } formula <- "formula" if (array) formula <- "array_formula" @@ -1219,20 +1269,26 @@ do_write_formula <- function( formula <- "cm_formula" } - class(dfx$X) <- c(formula, "character") + # 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") - } + # class(dfx$X) <- c("character", "formula", "hyperlink") - # transpose match write_data_table - rc <- dims_to_rowcol(dims) - if (length(rc[[1]]) > length(rc[[2]])) { - dfx <- transpose_df(dfx) + # TODO does not handle mixed types + for (i in seq_along(dfx)) { + class(dfx[[i]]) <- c("character", "formula", "hyperlink") + } } - if (is.null(dims)) { - dims <- wb_dims(start_row, start_col) + # transpose match write_data_table + if (array || enforce) { + rc <- dims_to_rowcol(dims) + if (length(rc[[1]]) > length(rc[[2]])) { + dfx <- transpose_df(dfx) + } } if (array || cm) { @@ -1253,7 +1309,8 @@ do_write_formula <- function( row_names = FALSE, apply_cell_style = apply_cell_style, remove_cell_style = remove_cell_style, - enforce = enforce + enforce = enforce, + shared = shared ) } @@ -1281,6 +1338,7 @@ do_write_datatable <- function( na.strings = na_strings(), inline_strings = TRUE, total_row = FALSE, + shared = FALSE, ... ) { @@ -1310,6 +1368,7 @@ do_write_datatable <- function( removeCellStyle = remove_cell_style, na.strings = na.strings, inline_strings = inline_strings, - total_row = total_row + total_row = total_row, + shared = shared ) } diff --git a/man/wbWorkbook.Rd b/man/wbWorkbook.Rd index fd80f3866..543259236 100644 --- a/man/wbWorkbook.Rd +++ b/man/wbWorkbook.Rd @@ -845,6 +845,7 @@ Add formula apply_cell_style = TRUE, remove_cell_style = FALSE, enforce = FALSE, + shared = FALSE, ... )}\if{html}{\out{}} } @@ -872,6 +873,8 @@ Add formula \item{\code{enforce}}{enforce dims} +\item{\code{shared}}{shared formula} + \item{\code{...}}{additional arguments} } \if{html}{\out{}} diff --git a/man/wb_add_formula.Rd b/man/wb_add_formula.Rd index f72be889a..dd9b38cae 100644 --- a/man/wb_add_formula.Rd +++ b/man/wb_add_formula.Rd @@ -16,6 +16,7 @@ wb_add_formula( apply_cell_style = TRUE, remove_cell_style = FALSE, enforce = FALSE, + shared = FALSE, ... ) } @@ -43,6 +44,8 @@ Add this, if you see "@" inserted into your formulas.} \item{enforce}{enforce dims} +\item{shared}{shared formula} + \item{...}{additional arguments} } \value{ @@ -88,6 +91,11 @@ wb$add_worksheet()$ add_data(x = mm, dims = "A4:B5", col_names = FALSE)$ add_formula(x = "MMULT(A1:B2, A4:B5)", dims = "A7:B8", array = TRUE) +# add shared formula +wb$add_worksheet()$ + add_data(x = matrix(rnorm(5*5), ncol = 5, nrow = 5))$ + add_formula(x = "SUM($A2:A2)", dims = "A8:E12", shared = TRUE) + } \seealso{ Other workbook wrappers: diff --git a/tests/testthat/test-formulas.R b/tests/testthat/test-formulas.R index d899f6f94..96c30b593 100644 --- a/tests/testthat/test-formulas.R +++ b/tests/testthat/test-formulas.R @@ -138,3 +138,49 @@ test_that("array formula detection works", { got <- cc[cc$f_t == "array", "f_ref"] expect_equal(exp, got) }) + +test_that("writing shared formulas works", { + df <- data.frame( + x = 1:5, + y = 1:5 * 2 + ) + + wb <- wb_workbook()$add_worksheet()$add_data(x = df) + + wb$add_formula( + x = "=A2/B2", + dims = "C2:C6", + array = FALSE, + shared = TRUE + ) + + cc <- wb$worksheets[[1]]$sheet_data$cc + cc <- cc[cc$c_r == "C", ] + + exp <- c("=A2/B2", "", "", "", "") + got <- cc$f + expect_equal(exp, got) + + exp <- c("shared") + got <- unique(cc$f_t) + expect_equal(exp, got) + + wb$add_formula( + x = "=A$2/B$2", + dims = "D2:D6", + array = FALSE, + shared = TRUE + ) + + cc <- wb$worksheets[[1]]$sheet_data$cc + cc <- cc[cc$c_r == "D", ] + + exp <- c("=A$2/B$2", "", "", "", "") + got <- cc$f + expect_equal(exp, got) + + exp <- c("1") + got <- unique(cc$f_si) + expect_equal(exp, got) + +}) diff --git a/tests/testthat/test-wb_functions.R b/tests/testthat/test-wb_functions.R index d48ea3995..5acaa7d78 100644 --- a/tests/testthat/test-wb_functions.R +++ b/tests/testthat/test-wb_functions.R @@ -478,3 +478,44 @@ test_that("improve non consecutive dims", { got <- wb4$worksheets[[1]]$sheet_data$cc$r[wb4$worksheets[[1]]$sheet_data$cc$c_s != ""] expect_contains(got, exp) }) + +test_that("creating a formula matrix works", { + + df <- matrix( + 1:100, ncol = 10, nrow = 10 + ) + + wb <- wb_workbook()$add_worksheet()$add_data(x = df) + + wb$add_formula( + x = "=$A2/B$2", + dims = wb_dims(x = df, from_row = 13, col_names = FALSE), + shared = TRUE + ) + + exp <- c(210, 16) + got <- dim(wb$worksheets[[1]]$sheet_data$cc) + expect_equal(exp, got) + +}) + +test_that("writing formula dataframes works", { + + df <- matrix( + 1:100, ncol = 10, nrow = 10 + ) + + fml_df <- dims_to_dataframe(wb_dims(x = df, col_names = FALSE, from_row = 2), fill = TRUE) + + wb <- wb_workbook()$add_worksheet()$add_data(x = df) + + wb$add_formula( + x = fml_df, + dims = wb_dims(x = df, from_row = 13, col_names = FALSE) + ) + + exp <- c(210, 16) + got <- dim(wb$worksheets[[1]]$sheet_data$cc) + expect_equal(exp, got) + +})