[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

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

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

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 <- "<col min=\"11\" max=\"11\" style=\"2\" width=\"8.43\"/>"
+  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)
+
+})