[fml] create shared formulas (#1074)

* [fml] create shared formulas

* [fml] create a formula matrix from dims

* [fml] allow writing formula data frames

* [fml] improve replacement

* bump version and update news

* [fml] add example

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 = "[email protected]", role = "aut", comment = c(ORCID = "0000-0001-9788-3628")),

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

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,
     ...               = ...
   )
 }

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)
     },

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("<dimension ref=\"", dims, "\"/>")
@@ -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
   )
 }

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)
+
+})