[cf] add x14 icon sets as discussed in #1053

R/baseXML.R

@@ -480,16 +480,16 @@ gen_databar_extlst <- function(guid, sqref, posColor, negColor, values, border,
  xml <- sprintf('<x14:cfRule type="dataBar" id="{%s}"><x14:dataBar minLength="0" maxLength="100" border="%s" gradient = "%s" negativeBarBorderColorSameAsPositive="0">', guid, border, gradient)
 
  if (is.null(values)) {
- xml <- sprintf('<ext uri="{78C0D931-6437-407d-A8EE-F0AAD7539E65}" xmlns:x14="http://schemas.microsoft.com/office/spreadsheetml/2009/9/main"><x14:conditionalFormattings><x14:conditionalFormatting xmlns:xm="http://schemas.microsoft.com/office/excel/2006/main">
+ xml <- sprintf('<x14:conditionalFormatting>
  %s
  <x14:cfvo type="autoMin"/><x14:cfvo type="autoMax"/><x14:borderColor rgb="%s"/><x14:negativeFillColor rgb="%s"/><x14:negativeBorderColor rgb="%s"/><x14:axisColor rgb="FF000000"/>
- </x14:dataBar></x14:cfRule><xm:sqref>%s</xm:sqref></x14:conditionalFormatting></x14:conditionalFormattings></ext>', xml, posColor, negColor, negColor, sqref)
+ </x14:dataBar></x14:cfRule><xm:sqref>%s</xm:sqref></x14:conditionalFormatting>', xml, posColor, negColor, negColor, sqref)
  } else {
- xml <- sprintf('<ext uri="{78C0D931-6437-407d-A8EE-F0AAD7539E65}" xmlns:x14="http://schemas.microsoft.com/office/spreadsheetml/2009/9/main"><x14:conditionalFormattings><x14:conditionalFormatting xmlns:xm="http://schemas.microsoft.com/office/excel/2006/main">
+ xml <- sprintf('<x14:conditionalFormatting>
  %s
  <x14:cfvo type="num"><xm:f>%s</xm:f></x14:cfvo><x14:cfvo type="num"><xm:f>%s</xm:f></x14:cfvo>
  <x14:borderColor rgb="%s"/><x14:negativeFillColor rgb="%s"/><x14:negativeBorderColor rgb="%s"/><x14:axisColor rgb="FF000000"/>
- </x14:dataBar></x14:cfRule><xm:sqref>%s</xm:sqref></x14:conditionalFormatting></x14:conditionalFormattings></ext>', xml, values[[1]], values[[2]], posColor, negColor, negColor, sqref)
+ </x14:dataBar></x14:cfRule><xm:sqref>%s</xm:sqref></x14:conditionalFormatting>', xml, values[[1]], values[[2]], posColor, negColor, negColor, sqref)
  }
 
  return(xml)

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.
 #' }
 #' }
 #'

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(
- '<x14:slicerList><x14:slicer r:id=\"%s\"/></x14:slicerList>',
+ '<x14:slicer r:id=\"%s\"/>',
  next_id
  )
 
- # add the extension list to the worksheet
- if (length(self$worksheets[[sheet]]$extLst) == 0 || !any(is_ext_x14)) {
-
- ext_x14 <- "<ext uri=\"{A8765BA9-456A-4dab-B4F3-ACF838C121DE}\" xmlns:x14=\"http://schemas.microsoft.com/office/spreadsheetml/2009/9/main\"></ext>"
-
- 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 <- "<ext uri=\"{7E03D99C-DC04-49d9-9315-930204A7B6E9}\" xmlns:x15=\"http://schemas.microsoft.com/office/spreadsheetml/2010/11/main\"></ext>"
@@ -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)
  },
 

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

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(
  '<extLst>
  <ext uri="{B025F937-C7B1-47D3-B67F-A62EFF666E3E}" xmlns:x14="http://schemas.microsoft.com/office/spreadsheetml/2009/9/main">
@@ -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(
+ "<x14:conditionalFormatting xmlns:xm=\"http://schemas.microsoft.com/office/excel/2006/main\">",
+ xml,
+ "<xm:sqref>",
+ sqref,
+ "</xm:sqref>",
+ "</x14:conditionalFormatting>"
+ )
+
+ xml <- character()
+ attr(xml, "extLst") <- extLst
+
+ }
+
+ xml
 }
 
 #' @rdname cf_rules

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