From e587b1992bf949e0ca0eaccc20b4c3e3f8a8ff72 Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Tue, 18 Jun 2024 08:37:07 +0200 Subject: [PATCH 1/6] [cf] add support for x14 icon sets --- R/class-workbook.R | 10 +++-- R/conditional_formatting.R | 92 +++++++++++++++++++++++--------------- R/utils.R | 43 ++++++++++++++++++ 3 files changed, 107 insertions(+), 38 deletions(-) diff --git a/R/class-workbook.R b/R/class-workbook.R index 32b86ff34..ab36401db 100644 --- a/R/class-workbook.R +++ b/R/class-workbook.R @@ -9537,7 +9537,7 @@ wbWorkbook <- R6::R6Class( uniqueValues = cf_unique_values(dxfId), ## iconSet ---- - iconSet = cf_icon_set(values, params), + iconSet = cf_icon_set(self$worksheets[[sheet]]$extLst, sqref, values, params), ## containsErrors ---- containsErrors = cf_iserror(dxfId, sqref), @@ -9559,8 +9559,12 @@ wbWorkbook <- R6::R6Class( if (!is.null(attr(cfRule, "extLst"))) self$worksheets[[sheet]]$extLst <- read_xml(attr(cfRule, "extLst"), pointer = FALSE) - private$append_sheet_field(sheet, "conditionalFormatting", read_xml(cfRule, pointer = FALSE)) - names(self$worksheets[[sheet]]$conditionalFormatting) <- nms + if (any(grepl("^ @@ -349,6 +328,8 @@ cf_bottom_n <- function(dxfId, values) { #' @rdname cf_rules #' @noRd cf_icon_set <- function( + extLst, + sqref, values, params ) { @@ -359,6 +340,15 @@ cf_icon_set <- function( reverse <- NULL iconSet <- NULL + # per default iconSet creation is store in $conditionalFormatting. + # The few exceptions are stored in extLst + guid <- NULL + x14_ns <- NULL + if (any(params$iconSet %in% c("3Stars", "3Triangles", "5Boxes", "NoIcons"))) { + guid <- st_guid() + x14_ns <- "x14:" + } + if (!is.null(params$iconSet)) iconSet <- params$iconSet @@ -372,15 +362,16 @@ cf_icon_set <- function( # create cfRule with iconset and cfvo cf_rule <- xml_node_create( - "cfRule", + paste0(x14_ns, "cfRule"), xml_attributes = c( type = "iconSet", - priority = priority + priority = priority, + id = guid ) ) iconset <- xml_node_create( - "iconSet", + paste0(x14_ns, "iconSet"), xml_attributes = c( iconSet = iconSet, showValue = showValue, @@ -389,25 +380,56 @@ cf_icon_set <- function( ) for (i in seq_along(values)) { - iconset <- xml_add_child( - iconset, - xml_child = c( - xml_node_create( - "cfvo", - xml_attributes = c( - type = type, - val = values[i] + if (is.null(x14_ns)) { + iconset <- xml_add_child( + iconset, + xml_child = c( + xml_node_create( + "cfvo", + xml_attributes = c( + type = type, + val = values[i] + ) ) ) ) - ) + } else { + iconset <- xml_add_child( + iconset, + xml_child = c( + xml_node_create( + "x14:cfvo", + xml_attributes = c( + type = type + ), + xml_children = xml_node_create("xm:f", + xml_children = values[i] + ) + ) + ) + ) + } } # return - xml_add_child( + xml <- xml_add_child( cf_rule, xml_child = iconset ) + + if (!is.null(x14_ns)) { + xml <- paste0( + "", + xml, + "", + sqref, + "", + "" + ) + xml <- update_extLst(extLst, xml) + } + + xml } #' @rdname cf_rules diff --git a/R/utils.R b/R/utils.R index 186d26fe0..32b814f16 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1236,3 +1236,46 @@ print.fmt_txt <- function(x, ...) { is_dims <- function(x) { grepl("^[A-Z]+[0-9]+(:[A-Z]+[0-9]+)?$", x) } + +#' helper to update/create extLst on worksheet +#' +#' newer spreadsheet functions live in the extLst also called future record table. +#' if we update this table, we have to make sure that (1) we do not lose any already available entry such as slicers or timelines +#' and (2) that we assign the newest entry to the correct version. an x14 namespace can only hold x14 children. mixing x14 and x15 can cause broken files +#' @param extLst extLst +#' @param newExtLst newExtLst +#' @keywords internal +#' @noRd +update_extLst <- function(extLst, newExtLst) { + + # check if any extLst availaible + if (length(extLst) == 0) { + extLst <- newExtLst + } else { + + # extLst might be x15 + if (!any(grepl("x14:conditionalFormattings", extLst))) { + extLst <- c( + extLst, + sprintf('') + ) + } + + is_ext_x14 <- grepl("x14:conditionalFormattings", extLst) + + # extLst is available, has conditionalFormattings + extLst[is_ext_x14] <- xml_add_child( + extLst[is_ext_x14], + xml_node( + newExtLst, + "ext", + "x14:conditionalFormattings", + "x14:conditionalFormatting" + ), + level = "x14:conditionalFormattings" + ) + + } + + extLst +} From a7720a87612be0668e1be7a26049a875f5b3def0 Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Tue, 18 Jun 2024 08:37:24 +0200 Subject: [PATCH 2/6] cleanup indentation --- R/utils.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/utils.R b/R/utils.R index 32b814f16..92e86df53 100644 --- a/R/utils.R +++ b/R/utils.R @@ -454,7 +454,7 @@ determine_select_valid <- function(args, select = NULL) { "`select` can't be \"row_names\" if `x` doesn't have row names.\n", "Use `row_names = TRUE` inside `wb_dims()` to ensure row names are preserved.", call. = FALSE - ) + ) } else if (isFALSE(args$col_names %||% TRUE) && identical(select, "col_names")) { # If the default for col_names ever changes in openxlsx2, this would need adjustment. stop( @@ -655,7 +655,7 @@ wb_dims <- function(..., select = NULL) { "Only `rows` and `cols` can be provided unnamed to `wb_dims()`.\n", "You must name all other arguments.", call. = FALSE - ) + ) } if (len == 1 && all_args_unnamed) { @@ -866,9 +866,9 @@ wb_dims <- function(..., select = NULL) { if (select == "col_names") { if (is.null(cols_arg) || length(cols_arg) %in% c(0, 1)) - ncol_to_span <- ncol(x) - else - ncol_to_span <- cols_arg + ncol_to_span <- ncol(x) + else + ncol_to_span <- cols_arg nrow_to_span <- 1L } else if (select == "row_names") { ncol_to_span <- 1L From 51c37c207bbd003bad2e7c44c4409178d82d874d Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Tue, 18 Jun 2024 09:04:03 +0200 Subject: [PATCH 3/6] [pt] keep slicers and timelines with conditional formatting --- R/class-workbook.R | 12 +- tests/testthat/test-conditional_formatting.R | 111 +++++++++++++++++++ 2 files changed, 117 insertions(+), 6 deletions(-) diff --git a/R/class-workbook.R b/R/class-workbook.R index ab36401db..95021e3bd 100644 --- a/R/class-workbook.R +++ b/R/class-workbook.R @@ -1902,7 +1902,7 @@ wbWorkbook <- R6::R6Class( next_id <- get_next_id(self$worksheets_rels[[sheet]]) # add the pivot table and the drawing to the worksheet - is_ext_x14 <- grepl("xmlns:x14", self$worksheets[[sheet]]$extLst) + is_ext_x14 <- grepl("x14:slicerList", self$worksheets[[sheet]]$extLst) if (!any(grepl(sprintf("Target=\"../slicers/slicer%s.xml\"", self$worksheets[[sheet]]$relships$slicer), self$worksheets_rels[[sheet]]))) { slicer_list_xml <- sprintf( @@ -1920,7 +1920,7 @@ wbWorkbook <- R6::R6Class( ext_x14 ) - is_ext_x14 <- grepl("xmlns:x14", self$worksheets[[sheet]]$extLst) + is_ext_x14 <- length(self$worksheets[[sheet]]$extLst) } @@ -1992,7 +1992,7 @@ wbWorkbook <- R6::R6Class( # remove worksheet relationship self$worksheets_rels[[sheet]] <- self$worksheets_rels[[sheet]][!grepl(slicer_xml, self$worksheets_rels[[sheet]])] # remove "x14:slicerList" - is_ext_x14 <- grepl("xmlns:x14", self$worksheets[[sheet]]$extLst) + is_ext_x14 <- grepl("x14:slicerList", self$worksheets[[sheet]]$extLst) extLst <- xml_rm_child(self$worksheets[[sheet]]$extLst[is_ext_x14], xml_child = "x14:slicerList") self$worksheets[[sheet]]$extLst[is_ext_x14] <- extLst @@ -2296,7 +2296,7 @@ wbWorkbook <- R6::R6Class( ) # add the extension list to the worksheet - is_ext_x15 <- grepl("xmlns:x15", self$worksheets[[sheet]]$extLst) + is_ext_x15 <- grepl("x15:timelineRefs", self$worksheets[[sheet]]$extLst) if (length(self$worksheets[[sheet]]$extLst) == 0 || !any(is_ext_x15)) { ext_x15 <- "" @@ -2306,7 +2306,7 @@ wbWorkbook <- R6::R6Class( ext_x15 ) - is_ext_x15 <- grepl("xmlns:x15", self$worksheets[[sheet]]$extLst) + is_ext_x15 <- length(self$worksheets[[sheet]]$extLst) } @@ -2378,7 +2378,7 @@ wbWorkbook <- R6::R6Class( # remove worksheet relationship self$worksheets_rels[[sheet]] <- self$worksheets_rels[[sheet]][!grepl(timeline_xml, self$worksheets_rels[[sheet]])] # remove "x15:timelineRefs" - is_ext_x15 <- grepl("xmlns:x15", self$worksheets[[sheet]]$extLst) + is_ext_x15 <- grepl("x15:timelineRefs", self$worksheets[[sheet]]$extLst) extLst <- xml_rm_child(self$worksheets[[sheet]]$extLst[is_ext_x15], xml_child = "x15:timelineRefs") self$worksheets[[sheet]]$extLst[is_ext_x15] <- extLst diff --git a/tests/testthat/test-conditional_formatting.R b/tests/testthat/test-conditional_formatting.R index 927c6f486..4dcfd108a 100644 --- a/tests/testthat/test-conditional_formatting.R +++ b/tests/testthat/test-conditional_formatting.R @@ -911,3 +911,114 @@ test_that("remove conditional formatting works", { got <- wb$worksheets[[4]]$conditionalFormatting expect_equal(exp, got) }) + +test_that("conditional formatting works with slicers/timelines", { + + # create a workbook with two sheets and some data + test_wb <- function() { + # prepare data + df <- data.frame( + AirPassengers = c(AirPassengers), + time = seq(from = as.Date("1949-01-01"), to = as.Date("1960-12-01"), by = "month"), + letters = letters[1:4] + ) + + # create workbook + wb <- wb_workbook()$ + add_worksheet("pivot")$ + add_worksheet("data")$ + add_data(x = df) + } + + # create data on sheet pivot with cf + test_cf <- function(wb) { + x <- matrix( + sample(c(0, 1), size = 20*10, replace = TRUE), + 20, + 10 + ) + + wb$add_data(x = x, sheet = "pivot", colNames = FALSE, dims = wb_dims(x = x, from_row = 30)) + wb$add_conditional_formatting( + dims = wb_dims(x = x, from_row = 30, cols = 1), + rule = c(.1, 0.1, 1), + type = "iconSet", + params = list( + percent = FALSE, + iconSet = "3Stars", + reverse = FALSE) + ) + wb$add_conditional_formatting( + dims = wb_dims(x = x, from_row = 30, cols = 2), + rule = c(.1, 0.1, 1), + type = "iconSet", + params = list( + percent = FALSE, + iconSet = "3Stars", + reverse = FALSE) + ) + wb + } + + # add pt w/ slicer and timeline on sheet pivot + test_pt <- function(wb) { + + # get pivot table data source + df <- wb_data(wb, sheet = "data") + + # create pivot table + wb$add_pivot_table( + df, + sheet = "pivot", + rows = "time", + cols = "letters", + data = "AirPassengers", + pivot_table = "airpassengers", + params = list( + compact = FALSE, outline = FALSE, compact_data = FALSE, + row_grand_totals = FALSE, col_grand_totals = FALSE) + ) + + # add slicer + wb$add_slicer( + df, + dims = "E1:I7", + sheet = "pivot", + slicer = "letters", + pivot_table = "airpassengers", + params = list(choose = c(letters = 'x %in% c("a", "b")')) + ) + + # add timeline + wb$add_timeline( + df, + dims = "E9:I14", + sheet = "pivot", + timeline = "time", + pivot_table = "airpassengers", + params = list( + beg_date = as.Date("1954-01-01"), + end_date = as.Date("1961-01-01"), + choose_beg = as.Date("1957-01-01"), + choose_end = as.Date("1958-01-01"), + level = 0, + style = "TimeSlicerStyleLight2" + ) + ) + wb + } + + wb <- test_wb() + wb <- test_cf(wb) + wb <- test_pt(wb) + + expect_equal(3L, length(wb$worksheets[[1]]$extLst)) + + wb <- test_wb() + wb <- test_pt(wb) + wb <- test_cf(wb) + + expect_equal(3L, length(wb$worksheets[[1]]$extLst)) + + +}) \ No newline at end of file From 4ee383b426db3a7a968e3513cd493a26a1047d55 Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Tue, 18 Jun 2024 09:37:16 +0200 Subject: [PATCH 4/6] [doc] add x14 icon sets --- R/class-workbook-wrappers.R | 6 +++--- man/wb_add_conditional_formatting.Rd | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/R/class-workbook-wrappers.R b/R/class-workbook-wrappers.R index d024f33af..46e4f326e 100644 --- a/R/class-workbook-wrappers.R +++ b/R/class-workbook-wrappers.R @@ -3873,9 +3873,9 @@ wb_add_form_control <- function( #' `[params$reverse]`\cr If `TRUE`, the order is reversed. Default `FALSE`\cr\cr #' `[params$percent]`\cr If `TRUE`, uses percentage\cr\cr #' `[params$iconSet]`\cr Uses one of the implemented icon sets. Values must match the length of the icons -#' in the set 3Arrows, 3ArrowsGray, 3Flags, 3Signs, 3Symbols, 3Symbols2, 3TrafficLights1, 3TrafficLights2, -#' 4Arrows, 4ArrowsGray, 4Rating, 4RedToBlack, 4TrafficLights, 5Arrows, 5ArrowsGray, 5Quarters, 5Rating. The -#' default is 3TrafficLights1. +#' in the set 3Arrows, 3ArrowsGray, 3Flags, 3Signs, 3Stars, 3Symbols, 3Symbols2, 3TrafficLights1, 3TrafficLights2, +#' 3Triangles, 4Arrows, 4ArrowsGray, 4Rating, 4RedToBlack, 4TrafficLights, 5Arrows, 5ArrowsGray, 5Boxes, 5Quarters, 5Rating. +#' The default is 3TrafficLights1. #' } #' } #' diff --git a/man/wb_add_conditional_formatting.Rd b/man/wb_add_conditional_formatting.Rd index 1fcce9bbd..9ad946a68 100644 --- a/man/wb_add_conditional_formatting.Rd +++ b/man/wb_add_conditional_formatting.Rd @@ -101,9 +101,9 @@ unlisted parameters are ignored. \verb{[params$reverse]}\cr If \code{TRUE}, the order is reversed. Default \code{FALSE}\cr\cr \verb{[params$percent]}\cr If \code{TRUE}, uses percentage\cr\cr \verb{[params$iconSet]}\cr Uses one of the implemented icon sets. Values must match the length of the icons -in the set 3Arrows, 3ArrowsGray, 3Flags, 3Signs, 3Symbols, 3Symbols2, 3TrafficLights1, 3TrafficLights2, -4Arrows, 4ArrowsGray, 4Rating, 4RedToBlack, 4TrafficLights, 5Arrows, 5ArrowsGray, 5Quarters, 5Rating. The -default is 3TrafficLights1. +in the set 3Arrows, 3ArrowsGray, 3Flags, 3Signs, 3Stars, 3Symbols, 3Symbols2, 3TrafficLights1, 3TrafficLights2, +3Triangles, 4Arrows, 4ArrowsGray, 4Rating, 4RedToBlack, 4TrafficLights, 5Arrows, 5ArrowsGray, 5Boxes, 5Quarters, 5Rating. +The default is 3TrafficLights1. } } } From f8d87c3447ab72c5e3fdbf432b4236f5fafca8a8 Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Tue, 18 Jun 2024 09:42:02 +0200 Subject: [PATCH 5/6] cleanup --- tests/testthat/test-conditional_formatting.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-conditional_formatting.R b/tests/testthat/test-conditional_formatting.R index 4dcfd108a..d4601cd6c 100644 --- a/tests/testthat/test-conditional_formatting.R +++ b/tests/testthat/test-conditional_formatting.R @@ -933,7 +933,7 @@ test_that("conditional formatting works with slicers/timelines", { # create data on sheet pivot with cf test_cf <- function(wb) { x <- matrix( - sample(c(0, 1), size = 20*10, replace = TRUE), + sample(c(0, 1), size = 20 * 10, replace = TRUE), 20, 10 ) @@ -1021,4 +1021,4 @@ test_that("conditional formatting works with slicers/timelines", { expect_equal(3L, length(wb$worksheets[[1]]$extLst)) -}) \ No newline at end of file +}) From 700bc361474a75dbef97084b014676c9aba8c9d9 Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Tue, 18 Jun 2024 19:58:14 +0200 Subject: [PATCH 6/6] [misc] use internal function to add x14 extLst --- R/baseXML.R | 8 ++-- R/class-workbook.R | 34 ++++------------ R/class-worksheet.R | 7 +++- R/conditional_formatting.R | 15 +++---- R/utils.R | 43 -------------------- tests/testthat/test-conditional_formatting.R | 16 ++++---- 6 files changed, 35 insertions(+), 88 deletions(-) diff --git a/R/baseXML.R b/R/baseXML.R index 1f5063abe..c3b2121c2 100644 --- a/R/baseXML.R +++ b/R/baseXML.R @@ -480,16 +480,16 @@ gen_databar_extlst <- function(guid, sqref, posColor, negColor, values, border, xml <- sprintf('', guid, border, gradient) if (is.null(values)) { - xml <- sprintf(' + xml <- sprintf(' %s - %s', xml, posColor, negColor, negColor, sqref) + %s', xml, posColor, negColor, negColor, sqref) } else { - xml <- sprintf(' + xml <- sprintf(' %s %s%s - %s', xml, values[[1]], values[[2]], posColor, negColor, negColor, sqref) + %s', xml, values[[1]], values[[2]], posColor, negColor, negColor, sqref) } return(xml) diff --git a/R/class-workbook.R b/R/class-workbook.R index 95021e3bd..504a826fc 100644 --- a/R/class-workbook.R +++ b/R/class-workbook.R @@ -1901,33 +1901,17 @@ wbWorkbook <- R6::R6Class( next_id <- get_next_id(self$worksheets_rels[[sheet]]) + + # add the pivot table and the drawing to the worksheet - is_ext_x14 <- grepl("x14:slicerList", self$worksheets[[sheet]]$extLst) if (!any(grepl(sprintf("Target=\"../slicers/slicer%s.xml\"", self$worksheets[[sheet]]$relships$slicer), self$worksheets_rels[[sheet]]))) { slicer_list_xml <- sprintf( - '', + '', next_id ) - # add the extension list to the worksheet - if (length(self$worksheets[[sheet]]$extLst) == 0 || !any(is_ext_x14)) { - - ext_x14 <- "" - - self$worksheets[[sheet]]$append( - "extLst", - ext_x14 - ) - - is_ext_x14 <- length(self$worksheets[[sheet]]$extLst) - - } - - self$worksheets[[sheet]]$extLst[is_ext_x14] <- xml_add_child( - self$worksheets[[sheet]]$extLst[is_ext_x14], - xml_child = slicer_list_xml - ) + self$worksheets[[sheet]]$.__enclos_env__$private$do_append_x14(slicer_list_xml, "x14:slicer", "x14:slicerList") self$worksheets_rels[[sheet]] <- append( self$worksheets_rels[[sheet]], @@ -9556,12 +9540,12 @@ wbWorkbook <- R6::R6Class( ) # dataBar needs additional extLst - if (!is.null(attr(cfRule, "extLst"))) - self$worksheets[[sheet]]$extLst <- read_xml(attr(cfRule, "extLst"), pointer = FALSE) + if (!is.null(attr(cfRule, "extLst"))) { + # self$worksheets[[sheet]]$extLst <- read_xml(attr(cfRule, "extLst"), pointer = FALSE) + self$worksheets[[sheet]]$.__enclos_env__$private$do_append_x14(attr(cfRule, "extLst"), "x14:conditionalFormatting", "x14:conditionalFormattings") + } - if (any(grepl("^ @@ -171,7 +169,7 @@ cf_create_databar <- function(extLst, formula, params, sqref, values) { ) } - attr(cf_rule, "extLst") <- extLst + attr(cf_rule, "extLst") <- newExtLst cf_rule } @@ -418,15 +416,18 @@ cf_icon_set <- function( ) if (!is.null(x14_ns)) { - xml <- paste0( - "", + extLst <- paste0( + "", xml, "", sqref, "", - "" + "" ) - xml <- update_extLst(extLst, xml) + + xml <- character() + attr(xml, "extLst") <- extLst + } xml diff --git a/R/utils.R b/R/utils.R index 92e86df53..60b73b631 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1236,46 +1236,3 @@ print.fmt_txt <- function(x, ...) { is_dims <- function(x) { grepl("^[A-Z]+[0-9]+(:[A-Z]+[0-9]+)?$", x) } - -#' helper to update/create extLst on worksheet -#' -#' newer spreadsheet functions live in the extLst also called future record table. -#' if we update this table, we have to make sure that (1) we do not lose any already available entry such as slicers or timelines -#' and (2) that we assign the newest entry to the correct version. an x14 namespace can only hold x14 children. mixing x14 and x15 can cause broken files -#' @param extLst extLst -#' @param newExtLst newExtLst -#' @keywords internal -#' @noRd -update_extLst <- function(extLst, newExtLst) { - - # check if any extLst availaible - if (length(extLst) == 0) { - extLst <- newExtLst - } else { - - # extLst might be x15 - if (!any(grepl("x14:conditionalFormattings", extLst))) { - extLst <- c( - extLst, - sprintf('') - ) - } - - is_ext_x14 <- grepl("x14:conditionalFormattings", extLst) - - # extLst is available, has conditionalFormattings - extLst[is_ext_x14] <- xml_add_child( - extLst[is_ext_x14], - xml_node( - newExtLst, - "ext", - "x14:conditionalFormattings", - "x14:conditionalFormatting" - ), - level = "x14:conditionalFormattings" - ) - - } - - extLst -} diff --git a/tests/testthat/test-conditional_formatting.R b/tests/testthat/test-conditional_formatting.R index d4601cd6c..dba20a5c2 100644 --- a/tests/testthat/test-conditional_formatting.R +++ b/tests/testthat/test-conditional_formatting.R @@ -564,14 +564,14 @@ test_that("extend dataBar tests", { got <- wb$worksheets[[1]]$conditionalFormatting expect_equal(exp, got) - exp <- read_xml(" - - A1:A11 - C1:C11 - E1:E11 - G1:G11 - I1:I11 - 05K1:K11 + exp <- read_xml(" + + A1:A11 + C1:C11 + E1:E11 + G1:G11 + I1:I11 + 05K1:K11 ", pointer = FALSE) got <- wb$worksheets[[1]]$extLst expect_equal(exp, got)