Flexible merge (#733)

* cleanup wb_merge_cells documentation

* [wb_merge_cells] add merge solver

* fix example

NEWS.md

@@ -6,6 +6,10 @@
 * fixes for loading workbooks with threaded comments
 * fixes for loading workbooks with embeddings other than docx
 
+## New features
+
+* provide solve argument for `wb_merge_cells()`. This allows to solve cell intersecting regions. [733](https://github.com/JanMarvin/openxlsx2/pull/733)
+
 
 ***************************************************************************
 

R/class-workbook-wrappers.R

@@ -482,43 +482,44 @@ wb_copy_cells <- function(
 #' @param wb A workbook object
 #' @param sheet A name or index of a worksheet
 #' @param dims worksheet cells
+#' @param solve logical if intersecting merges should be solved
 #' @param ... additional arguments
 #'
 #' @examples
 #' # Create a new workbook
-#' wb <- wb_workbook()
-#'
-#' # Add a worksheets
-#' wb$add_worksheet("Sheet 1")
-#' wb$add_worksheet("Sheet 2")
+#' wb <- wb_workbook()$add_worksheet()
 #'
 #' # Merge cells: Row 2 column C to F (3:6)
-#' wb <- wb_merge_cells(wb, "Sheet 1", cols = 2, rows = 3:6)
+#' wb <- wb_merge_cells(wb, dims = "C3:F6")
 #'
 #' # Merge cells:Rows 10 to 20 columns A to J (1:10)
-#' wb <- wb_merge_cells(wb, 1, cols = 1:10, rows = 10:20)
+#' wb <- wb_merge_cells(wb, dims = wb_dims(rows = 10:20, cols = 1:10))
 #'
-#' # Intersecting merges
-#' wb <- wb_merge_cells(wb, 2, cols = 1:10, rows = 1)
-#' wb <- wb_merge_cells(wb, 2, cols = 5:10, rows = 2)
-#' wb <- wb_merge_cells(wb, 2, cols = c(1, 10), rows = 12) # equivalent to 1:10
-#' try(wb_merge_cells(wb, 2, cols = 1, rows = c(1,10))) # intersects existing merge
+#' wb$add_worksheet()
 #'
-#' # remove merged cells
-#' wb <- wb_unmerge_cells(wb, 2, cols = 1, rows = 1) # removes any intersecting merges
-#' wb <- wb_merge_cells(wb, 2, cols = 1, rows = 1:10) # Now this works
+#' ## Intersecting merges
+#' wb <- wb_merge_cells(wb, dims = wb_dims(cols = 1:10, rows = 1))
+#' wb <- wb_merge_cells(wb, dims = wb_dims(cols = 5:10, rows = 2))
+#' wb <- wb_merge_cells(wb, dims = wb_dims(cols = 1:10, rows = 12))
+#' try(wb_merge_cells(wb, dims = "A1:A10"))
+#'
+#' ## remove merged cells
+#' # removes any intersecting merges
+#' wb <- wb_unmerge_cells(wb, dims = wb_dims(cols = 1, rows = 1))
+#' wb <- wb_merge_cells(wb, dims = "A1:A10")
+#'
+#' # or let us decide how to solve this
+#' wb <- wb_merge_cells(wb, dims = "A1:A10", solve = TRUE)
 #'
 #' @name wb_merge_cells
 #' @family workbook wrappers
 NULL
 
-
-
 #' @export
 #' @rdname wb_merge_cells
-wb_merge_cells <- function(wb, sheet = current_sheet(), dims = NULL, ...) {
+wb_merge_cells <- function(wb, sheet = current_sheet(), dims = NULL, solve = FALSE, ...) {
  assert_workbook(wb)
- wb$clone()$merge_cells(sheet = sheet, dims = dims, ... = ...)
+ wb$clone(deep = TRUE)$merge_cells(sheet = sheet, dims = dims, solve = solve, ... = ...)
 }
 
 #' @export

R/class-workbook.R

@@ -3558,9 +3558,10 @@ wbWorkbook <- R6::R6Class(
  #' Set cell merging for a sheet
  #' @param sheet sheet
  #' @param dims worksheet cells
+ #' @param solve logical if intersecting cells should be solved
  #' @param ... additional arguments
  #' @return The `wbWorkbook` object, invisibly
- merge_cells = function(sheet = current_sheet(), dims = NULL, ...) {
+ merge_cells = function(sheet = current_sheet(), dims = NULL, solve = FALSE, ...) {
 
  cols <- list(...)[["cols"]]
  rows <- list(...)[["rows"]]
@@ -3584,7 +3585,8 @@ wbWorkbook <- R6::R6Class(
  sheet <- private$get_sheet_index(sheet)
  self$worksheets[[sheet]]$merge_cells(
  rows = rows,
- cols = cols
+ cols = cols,
+ solve = solve
  )
  invisible(self)
  },

R/class-worksheet.R

@@ -498,8 +498,9 @@ wbWorksheet <- R6::R6Class(
  #' @description
  #' Set cell merging for a sheet
  #' @param rows,cols Row and column specifications.
+ #' @param solve logical if intersects should be solved
  #' @return The `wbWorkbook` object, invisibly
- merge_cells = function(rows = NULL, cols = NULL) {
+ merge_cells = function(rows = NULL, cols = NULL, solve = FALSE) {
 
  rows <- range(as.integer(rows))
  cols <- range(col2int(cols))
@@ -518,17 +519,28 @@ wbWorksheet <- R6::R6Class(
 
  # Error if merge intersects
  if (any(intersects)) {
- msg <- sprintf(
- "Merge intersects with existing merged cells: \n\t\t%s.\nRemove existing merge first.",
- stri_join(current[intersects], collapse = "\n\t\t")
- )
- stop(msg, call. = FALSE)
+ if (solve) {
+ refs <- NULL
+ for (i in current) {
+ got <- solve_merge(i, sqref)
+ refs <- c(refs, got)
+ }
+ # replace all merged Cells
+ if (all(is.na(refs))) {
+ self$mergeCells <- character()
+ } else {
+ self$mergeCells <- sprintf('<mergeCell ref="%s"/>', refs[!is.na(refs)])
+ }
+ } else {
+ msg <- sprintf(
+ "Merge intersects with existing merged cells: \n\t\t%s.\nRemove existing merge first.",
+ stri_join(current[intersects], collapse = "\n\t\t")
+ )
+ stop(msg, call. = FALSE)
+ }
  }
  }
 
- # TODO does this have to be xml? Can we just save the data.frame or
- # matrix and then check that? This would also simplify removing the
- # merge specifications
  self$append("mergeCells", sprintf('<mergeCell ref="%s"/>', sqref))
 
  invisible(self)

R/helper-functions.R

@@ -477,7 +477,7 @@ create_sparklines <- function(
  first = first,
  last = last,
  negative = negative,
- "xr2:uid" = sprintf("{6F57B887-24F1-C14A-942C-%s}", random_string(length = 12, pattern = "[A-Z0-9]"))
+ "xr2:uid" = sprintf("{6F57B887-24F1-C14A-942C-%s}", random_string(length = 12, pattern = "[A-F0-9]"))
  ),
  xml_children = c(
  xml_node_create("x14:colorSeries", xml_attributes = colorSeries),
@@ -1213,3 +1213,126 @@ st_guid <- function() {
 st_userid <- function() {
  random_string(length = 16, pattern = "[a-z0-9]")
 }
+
+# solve merge helpers -----------------------------------------------------
+
+#' check side
+#' @param x a logical string
+#' @name sidehelper
+#' @noRd
+fullsided <- function(x) {
+ x[1] && x[length(x)]
+}
+
+#' @rdname sidehelper
+#' @noRd
+onesided <- function(x) {
+ (x[1] && !x[length(x)]) || (!x[1] && x[length(x)])
+}
+
+
+#' @rdname sidehelper
+#' @noRd
+twosided <- function(x) {
+ if (any(x)) (!x[1] && !x[length(x)])
+ else FALSE
+}
+
+#' @rdname sidehelper
+#' @noRd
+top_half <- function(x) {
+ if (twosided(x)) {
+ out <- rep(FALSE, length(x))
+ out[seq_len(which(x == TRUE)[1] - 1L)] <- TRUE
+ return(out)
+ } else {
+ stop("not twosided")
+ }
+}
+
+#' @rdname sidehelper
+#' @noRd
+bottom_half <- function(x) {
+ if (twosided(x)) {
+ out <- rep(TRUE, length(x))
+ out[seq_len(rev(which(x == TRUE))[1])] <- FALSE
+ return(out)
+ } else {
+ stop("not twosided")
+ }
+}
+
+#' merge solver. split exisisting merge into pieces
+#' @param have current merged cells
+#' @param want newly merged cells
+#' @noRd
+solve_merge <- function(have, want) {
+
+ got <- dims_to_dataframe(have, fill = TRUE)
+ new <- dims_to_dataframe(want, fill = TRUE)
+
+ cols_overlap <- colnames(got) %in% colnames(new)
+ rows_overlap <- rownames(got) %in% rownames(new)
+
+ # no overlap at all
+ if (!any(cols_overlap) || !any(rows_overlap)) {
+ return(have)
+ }
+
+ # return pieces of the old
+ pieces <- list()
+
+ # new overlaps old completely
+ if (fullsided(cols_overlap) && fullsided(rows_overlap)) {
+ return(NA_character_)
+ }
+
+ # all columns are overlapped onesided
+ if (fullsided(cols_overlap) && onesided(rows_overlap)) {
+ pieces[[1]] <- got[!rows_overlap, drop = FALSE]
+ }
+
+ # all columns are overlapped twosided
+ if (fullsided(cols_overlap) && twosided(rows_overlap)) {
+ pieces[[1]] <- got[top_half(rows_overlap), drop = FALSE]
+ pieces[[2]] <- got[bottom_half(rows_overlap), drop = FALSE]
+ }
+
+ # all rows are overlapped onesided
+ if (onesided(cols_overlap) && fullsided(rows_overlap)) {
+ pieces[[1]] <- got[, !cols_overlap, drop = FALSE]
+ }
+
+ # all rows are overlapped twosided
+ if (twosided(cols_overlap) && fullsided(rows_overlap)) {
+ pieces[[1]] <- got[, top_half(cols_overlap), drop = FALSE]
+ pieces[[2]] <- got[, bottom_half(cols_overlap), drop = FALSE]
+ }
+
+ # new is part of old
+ if (onesided(cols_overlap) && onesided(rows_overlap)) {
+ pieces[[1]] <- got[!rows_overlap, cols_overlap, drop = FALSE]
+ pieces[[2]] <- got[, !cols_overlap, drop = FALSE]
+ }
+
+ if (onesided(cols_overlap) && twosided(rows_overlap)) {
+ pieces[[1]] <- got[top_half(rows_overlap), cols_overlap, drop = FALSE]
+ pieces[[2]] <- got[bottom_half(rows_overlap), cols_overlap, drop = FALSE]
+ pieces[[3]] <- got[, !cols_overlap, drop = FALSE]
+ }
+
+ if (twosided(cols_overlap) && onesided(rows_overlap)) {
+ pieces[[1]] <- got[rows_overlap, top_half(cols_overlap), drop = FALSE]
+ pieces[[2]] <- got[rows_overlap, bottom_half(cols_overlap), drop = FALSE]
+ pieces[[3]] <- got[!rows_overlap, , drop = FALSE]
+ }
+
+ if (twosided(cols_overlap) && twosided(rows_overlap)) {
+ pieces[[1]] <- got[, top_half(cols_overlap), drop = FALSE]
+ pieces[[2]] <- got[, bottom_half(cols_overlap), drop = FALSE]
+ pieces[[3]] <- got[top_half(rows_overlap), cols_overlap, drop = FALSE]
+ pieces[[4]] <- got[bottom_half(rows_overlap), cols_overlap, drop = FALSE]
+ }
+
+ vapply(pieces, dataframe_to_dims, NA_character_)
+}

tests/testthat/test-class-worksheet.R

@@ -20,7 +20,7 @@ test_that("test data validation list and sparklines", {
  add_sparklines(sheet = 1, sparklines = s2)
 
  exp <- c(
- "<ext xmlns:x14=\"http://schemas.microsoft.com/office/spreadsheetml/2009/9/main\" uri=\"{05C60535-1F16-4fd2-B633-F4F36F0B64E0}\"><x14:sparklineGroups xmlns:xm=\"http://schemas.microsoft.com/office/excel/2006/main\"><x14:sparklineGroup displayEmptyCellsAs=\"gap\" xr2:uid=\"{6F57B887-24F1-C14A-942C-ASEVX1JWJGYG}\"><x14:colorSeries rgb=\"FF376092\"/><x14:colorNegative rgb=\"FFD00000\"/><x14:colorAxis rgb=\"FFD00000\"/><x14:colorMarkers rgb=\"FFD00000\"/><x14:colorFirst rgb=\"FFD00000\"/><x14:colorLast rgb=\"FFD00000\"/><x14:colorHigh rgb=\"FFD00000\"/><x14:colorLow rgb=\"FFD00000\"/><x14:sparklines><x14:sparkline><xm:f>'Sheet 1'!A3:K3</xm:f><xm:sqref>L3</xm:sqref></x14:sparkline></x14:sparklines></x14:sparklineGroup><x14:sparklineGroup displayEmptyCellsAs=\"gap\" xr2:uid=\"{6F57B887-24F1-C14A-942C-9DKW7WYNM276}\"><x14:colorSeries rgb=\"FF376092\"/><x14:colorNegative rgb=\"FFD00000\"/><x14:colorAxis rgb=\"FFD00000\"/><x14:colorMarkers rgb=\"FFD00000\"/><x14:colorFirst rgb=\"FFD00000\"/><x14:colorLast rgb=\"FFD00000\"/><x14:colorHigh rgb=\"FFD00000\"/><x14:colorLow rgb=\"FFD00000\"/><x14:sparklines><x14:sparkline><xm:f>'Sheet 1'!A4:K4</xm:f><xm:sqref>L4</xm:sqref></x14:sparkline></x14:sparklines></x14:sparklineGroup></x14:sparklineGroups></ext>"
+ "<ext xmlns:x14=\"http://schemas.microsoft.com/office/spreadsheetml/2009/9/main\" uri=\"{05C60535-1F16-4fd2-B633-F4F36F0B64E0}\"><x14:sparklineGroups xmlns:xm=\"http://schemas.microsoft.com/office/excel/2006/main\"><x14:sparklineGroup displayEmptyCellsAs=\"gap\" xr2:uid=\"{6F57B887-24F1-C14A-942C-4C6EF08E87F7}\"><x14:colorSeries rgb=\"FF376092\"/><x14:colorNegative rgb=\"FFD00000\"/><x14:colorAxis rgb=\"FFD00000\"/><x14:colorMarkers rgb=\"FFD00000\"/><x14:colorFirst rgb=\"FFD00000\"/><x14:colorLast rgb=\"FFD00000\"/><x14:colorHigh rgb=\"FFD00000\"/><x14:colorLow rgb=\"FFD00000\"/><x14:sparklines><x14:sparkline><xm:f>'Sheet 1'!A3:K3</xm:f><xm:sqref>L3</xm:sqref></x14:sparkline></x14:sparklines></x14:sparklineGroup><x14:sparklineGroup displayEmptyCellsAs=\"gap\" xr2:uid=\"{6F57B887-24F1-C14A-942C-459E3EFAA032}\"><x14:colorSeries rgb=\"FF376092\"/><x14:colorNegative rgb=\"FFD00000\"/><x14:colorAxis rgb=\"FFD00000\"/><x14:colorMarkers rgb=\"FFD00000\"/><x14:colorFirst rgb=\"FFD00000\"/><x14:colorLast rgb=\"FFD00000\"/><x14:colorHigh rgb=\"FFD00000\"/><x14:colorLow rgb=\"FFD00000\"/><x14:sparklines><x14:sparkline><xm:f>'Sheet 1'!A4:K4</xm:f><xm:sqref>L4</xm:sqref></x14:sparkline></x14:sparklines></x14:sparklineGroup></x14:sparklineGroups></ext>"
  )
  got <- wb$worksheets[[1]]$extLst
  expect_equal(exp, got)