From f8ff1dd48731d8ca976d4d876a654ebfbef36c8a Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Sat, 4 Nov 2023 17:05:18 +0100 Subject: [PATCH] [clone] column and row styles (#839) * [clone] column and row styles * update test to make it look like the entire row is colored * improve cloning of styles. previously we tried cloning the same style multiple times, now we reduce to unique styles before we start cloning --- R/class-workbook.R | 25 ++++++++++ R/helper-functions.R | 68 ++++++++++++++++++++++------ tests/testthat/test-cloneWorksheet.R | 49 ++++++++++++++++++++ 3 files changed, 129 insertions(+), 13 deletions(-) diff --git a/R/class-workbook.R b/R/class-workbook.R index af1e8e2b5..8b83da154 100644 --- a/R/class-workbook.R +++ b/R/class-workbook.R @@ -1174,8 +1174,33 @@ wbWorkbook <- R6::R6Class( new_s <- unname(new_sty[match(self$worksheets[[newSheetIndex]]$sheet_data$cc$c_s, names(new_sty))]) new_s[is.na(new_s)] <- "" self$worksheets[[newSheetIndex]]$sheet_data$cc$c_s <- new_s + rm(style, new_s, new_sty) } + style <- get_colstyle(from, sheet = old) + # only if styles are present + if (!is.null(style)) { + new_sty <- set_cellstyles(self, style = style) + cols <- self$worksheets[[newSheetIndex]]$unfold_cols() + new_s <- unname(new_sty[match(cols$style, names(new_sty))]) + new_s[is.na(new_s)] <- "" + cols$style <- new_s + self$worksheets[[newSheetIndex]]$fold_cols(cols) + rm(style, new_s, new_sty) + } + + style <- get_rowstyle(from, sheet = old) + # only if styles are present + if (!is.null(style)) { + new_sty <- set_cellstyles(self, style = style) + new_s <- unname(new_sty[match(self$worksheets[[newSheetIndex]]$sheet_data$row_attr$s, names(new_sty))]) + new_s[is.na(new_s)] <- "" + self$worksheets[[newSheetIndex]]$sheet_data$row_attr$s <- new_s + rm(style, new_s, new_sty) + } + + # TODO dxfs styles for (pivot) table styles and conditional formatting + clone_shared_strings(from, old, self, newSheetIndex) } diff --git a/R/helper-functions.R b/R/helper-functions.R index 7304de5af..17385353c 100644 --- a/R/helper-functions.R +++ b/R/helper-functions.R @@ -1400,22 +1400,12 @@ basename2 <- function(path) { } } -## get cell styles for a worksheet -get_cellstyle <- function(wb, sheet = current_sheet(), dims) { - - st_ids <- NULL - if (missing(dims)) { - st_ids <- styles_on_sheet(wb = wb, sheet = sheet) %>% as.character() - xf_ids <- match(st_ids, wb$styles_mgr$xf$id) - xf_xml <- wb$styles_mgr$styles$cellXfs[xf_ids] - } else { - xf_xml <- get_cell_styles(wb = wb, sheet = sheet, cell = dims) - } - +fetch_styles <- function(wb, xf_xml, st_ids) { # returns NA if no style found if (all(is.na(xf_xml))) return(NULL) lst_out <- vector("list", length = length(xf_xml)) + names(lst_out) <- st_ids for (i in seq_along(xf_xml)) { @@ -1444,11 +1434,59 @@ get_cellstyle <- function(wb, sheet = current_sheet(), dims) { } + # unique drops names + lst_out <- lst_out[!duplicated(lst_out)] + attr(lst_out, "st_ids") <- st_ids lst_out } +## get cell styles for a worksheet +get_cellstyle <- function(wb, sheet = current_sheet(), dims) { + + st_ids <- NULL + if (missing(dims)) { + st_ids <- styles_on_sheet(wb = wb, sheet = sheet) %>% as.character() + xf_ids <- match(st_ids, wb$styles_mgr$xf$id) + xf_xml <- wb$styles_mgr$styles$cellXfs[xf_ids] + } else { + xf_xml <- get_cell_styles(wb = wb, sheet = sheet, cell = dims) + } + + fetch_styles(wb, xf_xml, st_ids) +} + +get_colstyle <- function(wb, sheet = current_sheet()) { + + st_ids <- NULL + if (length(wb$worksheets[[sheet]]$cols_attr)) { + cols <- wb$worksheets[[sheet]]$unfold_cols() + st_ids <- cols$s[cols$s != ""] + xf_ids <- match(st_ids, wb$styles_mgr$xf$id) + xf_xml <- wb$styles_mgr$styles$cellXfs[xf_ids] + } else { + xf_xml <- NA_character_ + } + + fetch_styles(wb, xf_xml, st_ids) +} + +get_rowstyle <- function(wb, sheet = current_sheet()) { + + st_ids <- NULL + if (!is.null(wb$worksheets[[sheet]]$sheet_data$row_attr)) { + rows <- wb$worksheets[[sheet]]$sheet_data$row_attr + st_ids <- rows$s[rows$s != ""] + xf_ids <- match(st_ids, wb$styles_mgr$xf$id) + xf_xml <- wb$styles_mgr$styles$cellXfs[xf_ids] + } else { + xf_xml <- NA_character_ + } + + fetch_styles(wb, xf_xml, st_ids) +} + ## apply cell styles to a worksheet and return reference ids set_cellstyles <- function(wb, style) { @@ -1515,7 +1553,11 @@ set_cellstyles <- function(wb, style) { st_ids <- wb$styles_mgr$get_xf_id(session_ids) if (!is.null(attr(style, "st_ids"))) { - names(st_ids) <- attr(style, "st_ids") + names(st_ids) <- names(style) + out <- attr(style, "st_ids") + + want <- match(out, names(st_ids)) + st_ids <- st_ids[want] } st_ids diff --git a/tests/testthat/test-cloneWorksheet.R b/tests/testthat/test-cloneWorksheet.R index c86a378de..a071fbb1c 100644 --- a/tests/testthat/test-cloneWorksheet.R +++ b/tests/testthat/test-cloneWorksheet.R @@ -240,3 +240,52 @@ test_that("cloning from workbooks works", { expect_equal(exp, got) }) + +test_that("cloning column and row styles works", { + + tmp <- temp_xlsx() + + ### prepare a worksheet to clone from + wb <- wb_workbook()$ + add_worksheet()$add_data(x = head(mtcars))$ + add_worksheet()$add_data(x = head(iris)) + + new_fill <- create_fill(patternType = "solid", fgColor = wb_color(hex = "yellow")) + + wb$styles_mgr$add(new_fill, "new_fill") + new_cellxfs <- create_cell_style( + num_fmt_id = 0, + fill_id = wb$styles_mgr$get_fill_id("new_fill") + ) + wb$styles_mgr$add(new_cellxfs, "new_styles") + + wb$worksheets[[1]]$sheet_data$row_attr[2, "customFormat"] <- "1" + wb$worksheets[[1]]$sheet_data$row_attr[2, "s"] <- wb$styles_mgr$get_xf_id("new_styles") + + cols <- openxlsx2:::wb_create_columns(wb, sheet = 1, cols = seq_along(mtcars)) + cols[cols$min == 11, "style"] <- "1" + wb$worksheets[[1]]$fold_cols(cols) + + # otherwise the style color somehow is omitted in the data area + wb$set_cell_style(sheet = 1, dims = "A2:K2", style = wb$styles_mgr$get_xf_id("new_styles")) + wb$set_cell_style(sheet = 1, dims = "K1:K7", style = wb$styles_mgr$get_xf_id("new_styles")) + + wb$save(tmp) + rm(wb, cols, new_cellxfs, new_fill) + + ### clone the actual worksheet + wb_mtcars <- wb_load(tmp) + + wb <- wb_workbook()$add_worksheet() + wb$clone_worksheet(old = "Sheet 1", "mtcars", from = wb_mtcars) + wb$clone_worksheet(old = "Sheet 2", "iris", from = wb_mtcars) + + exp <- "" + got <- wb$worksheets[[2]]$cols_attr[2] + expect_equal(exp, got) + + exp <- "3" + got <- wb$worksheets[[2]]$sheet_data$row_attr[2, "s"] + expect_equal(exp, got) + +})