From 9c923c65238dfe41d626e8ff1eaee39009546285 Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Sun, 13 Aug 2023 14:41:25 +0200 Subject: [PATCH] Flexible merge (#733) * cleanup wb_merge_cells documentation * [wb_merge_cells] add merge solver * fix example --- NEWS.md | 4 + R/class-workbook-wrappers.R | 39 ++++---- R/class-workbook.R | 6 +- R/class-worksheet.R | 30 ++++-- R/helper-functions.R | 125 +++++++++++++++++++++++- man/wbWorkbook.Rd | 9 +- man/wb_merge_cells.Rd | 36 ++++--- tests/testthat/test-class-worksheet.R | 2 +- tests/testthat/test-fill_merged_cells.R | 39 ++++++++ tests/testthat/test-helper-functions.R | 6 +- 10 files changed, 244 insertions(+), 52 deletions(-) diff --git a/NEWS.md b/NEWS.md index 002150868..bd8e7be03 100644 --- a/NEWS.md +++ b/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) + *************************************************************************** diff --git a/R/class-workbook-wrappers.R b/R/class-workbook-wrappers.R index afa6bde9e..847d18802 100644 --- a/R/class-workbook-wrappers.R +++ b/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 diff --git a/R/class-workbook.R b/R/class-workbook.R index ed46d7a68..dc5fbf9b4 100644 --- a/R/class-workbook.R +++ b/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) }, diff --git a/R/class-worksheet.R b/R/class-worksheet.R index 05fb0980a..600b8b579 100644 --- a/R/class-worksheet.R +++ b/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('', 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('', sqref)) invisible(self) diff --git a/R/helper-functions.R b/R/helper-functions.R index 75ff8a386..ef7ea8071 100644 --- a/R/helper-functions.R +++ b/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_) +} diff --git a/man/wbWorkbook.Rd b/man/wbWorkbook.Rd index 6c4752924..793fc2621 100644 --- a/man/wbWorkbook.Rd +++ b/man/wbWorkbook.Rd @@ -1523,7 +1523,12 @@ The \code{wbWorkbook} object \subsection{Method \code{merge_cells()}}{ Set cell merging for a sheet \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{wbWorkbook$merge_cells(sheet = current_sheet(), dims = NULL, ...)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{wbWorkbook$merge_cells( + sheet = current_sheet(), + dims = NULL, + solve = FALSE, + ... +)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -1533,6 +1538,8 @@ Set cell merging for a sheet \item{\code{dims}}{worksheet cells} +\item{\code{solve}}{logical if intersecting cells should be solved} + \item{\code{...}}{additional arguments} } \if{html}{\out{}} diff --git a/man/wb_merge_cells.Rd b/man/wb_merge_cells.Rd index 3e7eb7444..29794c06d 100644 --- a/man/wb_merge_cells.Rd +++ b/man/wb_merge_cells.Rd @@ -5,7 +5,7 @@ \alias{wb_unmerge_cells} \title{Worksheet cell merging} \usage{ -wb_merge_cells(wb, sheet = current_sheet(), dims = NULL, ...) +wb_merge_cells(wb, sheet = current_sheet(), dims = NULL, solve = FALSE, ...) wb_unmerge_cells(wb, sheet = current_sheet(), dims = NULL, ...) } @@ -16,6 +16,8 @@ wb_unmerge_cells(wb, sheet = current_sheet(), dims = NULL, ...) \item{dims}{worksheet cells} +\item{solve}{logical if intersecting merges should be solved} + \item{...}{additional arguments} } \description{ @@ -27,27 +29,29 @@ rows are used. } \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)) + +wb$add_worksheet() + +## 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")) -# 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 +## 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") -# 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 +# or let us decide how to solve this +wb <- wb_merge_cells(wb, dims = "A1:A10", solve = TRUE) } \seealso{ diff --git a/tests/testthat/test-class-worksheet.R b/tests/testthat/test-class-worksheet.R index e75338112..4f661f0c4 100644 --- a/tests/testthat/test-class-worksheet.R +++ b/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( - "'Sheet 1'!A3:K3L3'Sheet 1'!A4:K4L4" + "'Sheet 1'!A3:K3L3'Sheet 1'!A4:K4L4" ) got <- wb$worksheets[[1]]$extLst expect_equal(exp, got) diff --git a/tests/testthat/test-fill_merged_cells.R b/tests/testthat/test-fill_merged_cells.R index 0db05db26..9219697d8 100644 --- a/tests/testthat/test-fill_merged_cells.R +++ b/tests/testthat/test-fill_merged_cells.R @@ -68,3 +68,42 @@ test_that("fill merged NA cells", { r1, ignore_attr = TRUE) }) + +test_that("solving merge conflicts works", { + wb <- wb_workbook()$add_worksheet() + wb$merge_cells(dims = "A1:B2") + wb$merge_cells(dims = "G1:K2") + + # first solve replacing A1:B2 + wb$merge_cells(dims = "A1:C3", solve = TRUE) + + exp <- c("", "") + got <- wb$worksheets[[1]]$mergeCells + expect_equal(exp, got) + + # second solve replace A1:C3 and parts of G1:K2 + wb$merge_cells(dims = "A1:J7", solve = TRUE) + + exp <- c("", "") + got <- wb$worksheets[[1]]$mergeCells + expect_equal(exp, got) + + # third solve replace both parts with single merge + wb$merge_cells(dims = "A1:Z8", solve = TRUE) + + exp <- "" + got <- wb$worksheets[[1]]$mergeCells + expect_equal(exp, got) + + # fourth solve insert into merged cell region + wb$merge_cells(dims = "B2:D4", solve = TRUE) + + exp <- c( + "", "", + "", "", + "" + ) + got <- wb$worksheets[[1]]$mergeCells + expect_equal(exp, got) + +}) diff --git a/tests/testthat/test-helper-functions.R b/tests/testthat/test-helper-functions.R index 0a3638e7f..a21e4243b 100644 --- a/tests/testthat/test-helper-functions.R +++ b/tests/testthat/test-helper-functions.R @@ -139,7 +139,7 @@ test_that("add_sparklines", { exp <- read_xml(' - + @@ -155,7 +155,7 @@ test_that("add_sparklines", { - + @@ -171,7 +171,7 @@ test_that("add_sparklines", { - +