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-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/R/class-workbook.R b/R/class-workbook.R index 32b86ff34..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("xmlns:x14", 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 <- grepl("xmlns:x14", 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]], @@ -1992,7 +1976,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 +2280,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 +2290,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 +2362,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 @@ -9537,7 +9521,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), @@ -9556,11 +9540,15 @@ 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") + } - private$append_sheet_field(sheet, "conditionalFormatting", read_xml(cfRule, pointer = FALSE)) - names(self$worksheets[[sheet]]$conditionalFormatting) <- nms + if (length(cfRule)) { + private$append_sheet_field(sheet, "conditionalFormatting", read_xml(cfRule, pointer = FALSE)) + names(self$worksheets[[sheet]]$conditionalFormatting) <- nms + } invisible(self) }, diff --git a/R/class-worksheet.R b/R/class-worksheet.R index 36a91d5e5..fc24088ca 100644 --- a/R/class-worksheet.R +++ b/R/class-worksheet.R @@ -902,6 +902,7 @@ wbWorksheet <- R6::R6Class( # @description add data_validation_lst # @param datavalidation datavalidation + # TODO extend this for x15 and add it to timeline do_append_x14 = function( x, s_name, @@ -921,6 +922,8 @@ wbWorksheet <- R6::R6Class( uri <- "" # if (l_name == "x14:dataValidations") uri <- "{CCE6A557-97BC-4b89-ADB6-D9C93CAAB3DF}" if (l_name == "x14:sparklineGroups") uri <- "{05C60535-1F16-4fd2-B633-F4F36F0B64E0}" + if (l_name == "x14:conditionalFormattings") uri <- "{78C0D931-6437-407d-A8EE-F0AAD7539E65}" + if (l_name == "x14:slicerList") uri <- "{A8765BA9-456A-4dab-B4F3-ACF838C121DE}" is_needed_uri <- grepl(pattern = uri, extLst, fixed = TRUE) @@ -942,13 +945,15 @@ wbWorksheet <- R6::R6Class( # check again and should be exactly one ext node is_xmlns_x14 <- grepl(pattern = "xmlns:x14", extLst) + l_name_attr <- c("xmlns:xm" = "http://schemas.microsoft.com/office/excel/2006/main") + # check for l_name and add one if none is found if (length(xml_node(ext, "ext", l_name)) == 0) { ext <- xml_add_child( ext, xml_node_create( l_name, - xml_attributes = c("xmlns:xm" = "http://schemas.microsoft.com/office/excel/2006/main")) + xml_attributes = l_name_attr) ) } diff --git a/R/conditional_formatting.R b/R/conditional_formatting.R index 78f2092a6..f50990730 100644 --- a/R/conditional_formatting.R +++ b/R/conditional_formatting.R @@ -121,29 +121,6 @@ cf_create_databar <- function(extLst, formula, params, sqref, values) { gradient = gradient ) - # check if any extLst availaible - if (length(extLst) == 0) { - extLst <- newExtLst - } else if (length(xml_node(extLst, "ext", "x14:conditionalFormattings")) == 0) { - # extLst is available, has no conditionalFormattings - extLst <- xml_add_child( - extLst, - xml_node(newExtLst, "ext", "x14:conditionalFormattings") - ) - } else { - # extLst is available, has conditionalFormattings - extLst <- xml_add_child( - extLst, - xml_node( - newExtLst, - "ext", - "x14:conditionalFormattings", - "x14:conditionalFormatting" - ), - level = "x14:conditionalFormattings" - ) - } - cf_rule_extLst <- sprintf( ' @@ -192,7 +169,7 @@ cf_create_databar <- function(extLst, formula, params, sqref, values) { ) } - attr(cf_rule, "extLst") <- extLst + attr(cf_rule, "extLst") <- newExtLst cf_rule } @@ -349,6 +326,8 @@ cf_bottom_n <- function(dxfId, values) { #' @rdname cf_rules #' @noRd cf_icon_set <- function( + extLst, + sqref, values, params ) { @@ -359,6 +338,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 +360,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 +378,59 @@ 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)) { + extLst <- paste0( + "", + xml, + "", + sqref, + "", + "" + ) + + xml <- character() + attr(xml, "extLst") <- extLst + + } + + xml } #' @rdname cf_rules diff --git a/R/utils.R b/R/utils.R index 186d26fe0..60b73b631 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 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. } } } diff --git a/tests/testthat/test-conditional_formatting.R b/tests/testthat/test-conditional_formatting.R index 927c6f486..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) @@ -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)) + + +})