another simpler approach

NAMESPACE

@@ -155,7 +155,6 @@ export(xl_open)
 export(xml_add_child)
 export(xml_attr)
 export(xml_attr_mod)
-export(xml_child_mod)
 export(xml_node)
 export(xml_node_create)
 export(xml_node_name)

R/RcppExports.R

@@ -51,6 +51,14 @@ create_char_dataframe <- function(colnames, n) {
     .Call(`_openxlsx2_create_char_dataframe`, colnames, n)
 }
 
+read_xml2df <- function(xml, vec_name, vec_attrs, vec_chlds) {
+    .Call(`_openxlsx2_read_xml2df`, xml, vec_name, vec_attrs, vec_chlds)
+}
+
+write_df2xml <- function(df, vec_name, vec_attrs, vec_chlds) {
+    .Call(`_openxlsx2_write_df2xml`, df, vec_name, vec_attrs, vec_chlds)
+}
+
 col_to_df <- function(doc) {
     .Call(`_openxlsx2_col_to_df`, doc)
 }
@@ -236,14 +244,6 @@ xml_remove_child3 <- function(node, child, level1, level2, which, pointer) {
     .Call(`_openxlsx2_xml_remove_child3`, node, child, level1, level2, which, pointer)
 }
 
-xml_find_node <- function(node, chld) {
-    .Call(`_openxlsx2_xml_find_node`, node, chld)
-}
-
-xml_replace_child <- function(node, path, replacement, escapes = FALSE, pointer = FALSE) {
-    .Call(`_openxlsx2_xml_replace_child`, node, path, replacement, escapes, pointer)
-}
-
 xml_si_to_txt <- function(doc) {
     .Call(`_openxlsx2_xml_si_to_txt`, doc)
 }

R/class-workbook.R

@@ -6046,7 +6046,7 @@ wbWorkbook <- R6::R6Class(
       self$set_properties(modifier = name)
     },
 
-    #' @description page_setup()
+    #' @description set_page_setup() this function is intended to supersed page_setup(), but not yet stable.
     #' @param orientation orientation
     #' @param black_and_white black_and_white
     #' @param cell_comments cell_comment
@@ -6074,42 +6074,49 @@ wbWorkbook <- R6::R6Class(
     #' @param print_title_cols printTitleCols
     #' @param summary_row summaryRow
     #' @param summary_col summaryCol
+    #' @param tab_color tabColor
+    #' @param ... additonal arguments
     #' @return The `wbWorkbook` object, invisibly
     set_page_setup = function(
-      sheet            = current_sheet(),
+      sheet                 = current_sheet(),
       # page properties
-      black_and_white  = NULL,
-      cell_comments    = NULL,
-      copies           = NULL,
-      draft            = NULL,
-      errors           = NULL,
-      first_page_number = NULL,
-      id               = NULL, # useful? and should the user be able to set this by accident?
-      page_order       = NULL,
-      paper_height     = NULL,
-      paper_width      = NULL,
-      hdpi             = NULL,
-      vdpi             = NULL,
+      black_and_white       = NULL,
+      cell_comments         = NULL,
+      copies                = NULL,
+      draft                 = NULL,
+      errors                = NULL,
+      first_page_number     = NULL,
+      id                    = NULL, # useful and should the user be able to set this by accident?
+      page_order            = NULL,
+      paper_height          = NULL,
+      paper_width           = NULL,
+      hdpi                  = NULL,
+      vdpi                  = NULL,
       use_first_page_number = NULL,
-      use_printer_defaults = NULL,
-      orientation      = NULL,
-      scale            = NULL,
-      left             = 0.7,
-      right            = 0.7,
-      top              = 0.75,
-      bottom           = 0.75,
-      header           = 0.3,
-      footer           = 0.3,
-      fit_to_width     = FALSE,
-      fit_to_height    = FALSE,
-      paper_size       = NULL,
+      use_printer_defaults  = NULL,
+      orientation           = NULL,
+      scale                 = NULL,
+      left                  = 0.7,
+      right                 = 0.7,
+      top                   = 0.75,
+      bottom                = 0.75,
+      header                = 0.3,
+      footer                = 0.3,
+      fit_to_width          = FALSE,
+      fit_to_height         = FALSE,
+      paper_size            = NULL,
       # outline properties
-      print_title_rows = NULL,
-      print_title_cols = NULL,
-      summary_row      = NULL,
-      summary_col      = NULL
+      print_title_rows      = NULL,
+      print_title_cols      = NULL,
+      summary_row           = NULL,
+      summary_col           = NULL,
+      # tabColor properties
+      tab_color             = NULL,
+      ...
     ) {
 
+      standardize_color_names(...)
+
       sheet <- private$get_sheet_index(sheet)
       xml <- self$worksheets[[sheet]]$pageSetup
 
@@ -6213,17 +6220,42 @@ wbWorkbook <- R6::R6Class(
 
       if (length(xml) == 0) xml <- "<sheetPr/>"
 
+      sheetpr_df <- read_sheetpr(xml)
+
       ## order matters: tabColor, outlinePr, pageSetUpPr.
+      if (length(tab_color)) {
+        tc <- sheetpr_df$tabColor
+        if (tc == "") tc <- "<tabColor/>"
+        if (is.null(names(tab_color))) {
+          if (tab_color == "") {
+            tab_color <- NULL
+          } else {
+            warning("tab_color should be a wb_color() object")
+            tab_color <- wb_color(tab_color)
+          }
+        }
+
+        if (is.null(tab_color)) {
+          sheetpr_df$tabColor <- ""
+        } else {
+          sheetpr_df$tabColor <- xml_attr_mod(tc, xml_attributes = tab_color)
+        }
+      }
+
       ## TODO make sure that the order is valid
       if (length(outlinepr)) {
-        xml <- xml_child_mod(xml, "outlinePr", xml_attributes = outlinepr)
+        op <- sheetpr_df$outlinePr
+        if (op == "") op <- "<outlinePr/>"
+        sheetpr_df$outlinePr <- xml_attr_mod(op, xml_attributes = outlinepr)
       }
 
       if (fit_to_height || fit_to_width) {
-        xml <- xml_child_mod(xml, "pageSetUpPr", xml_attributes = c(fitToPage = "1"))
+        psup <- sheetpr_df$pageSetUpPr
+        if (psup == "") psup <- "<pageSetUpPr/>"
+        sheetpr_df$pageSetUpPr <- xml_attr_mod(psup, xml_attributes = c(fitToPage = "1"))
       }
 
-      self$worksheets[[sheet]]$sheetPr <- xml
+      self$worksheets[[sheet]]$sheetPr <- write_sheetpr(sheetpr_df)
 
       ## print Titles ----
       if (!is.null(print_title_rows) && is.null(print_title_cols)) {

R/helper-functions.R

@@ -1067,3 +1067,42 @@ known_subtotal_funs <- function(x, total, table, row_names = FALSE) {
   list(fml, atr, lbl)
 
 }
+
+
+
+# helper to read sheetPr xml to dataframe
+# @params xml xml_node
+read_sheetpr <- function(xml) {
+  # https://learn.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.sheetproperties?view=openxml-2.8.1
+  if (!inherits(xml, "pugi_xml")) xml <- read_xml(xml)
+
+  vec_attrs <- c("codeName", "enableFormatConditionsCalculation", "filterMode",
+                 "published", "syncHorizontal", "syncRef", "syncVertical",
+                 "transitionEntry", "transitionEvaluation")
+  vec_chlds <- c("tabColor", "outlinePr", "pageSetUpPr")
+
+  read_xml2df(
+    xml       = xml,
+    vec_name  = "sheetPr",
+    vec_attrs = vec_attrs,
+    vec_chlds = vec_chlds
+  )
+}
+
+# helper to write sheetPr dataframe to xml
+write_sheetpr <- function(df) {
+
+  # we have to preserve a certain order of elements at least for childs
+  vec_attrs <- c("codeName", "enableFormatConditionsCalculation", "filterMode",
+                 "published", "syncHorizontal", "syncRef", "syncVertical",
+                 "transitionEntry", "transitionEvaluation")
+  vec_chlds <- c("tabColor", "outlinePr", "pageSetUpPr")
+  nms <- c(vec_attrs, vec_chlds)
+
+  write_df2xml(
+    df        = df[nms],
+    vec_name  = "sheetPr",
+    vec_attrs = vec_attrs,
+    vec_chlds = vec_chlds
+  )
+}

R/pugixml.R

@@ -377,71 +377,4 @@ xml_rm_child <- function(xml_node, xml_child, level, which = 0, pointer = FALSE,
   }
 
   return(z)
-}
-
-
-# inner function update
-upd_child <- function(child, xml_attributes, xml_children, ...) {
-
-  if (!is.null(xml_attributes)) {
-    child <- xml_attr_mod(child, xml_attributes = xml_attributes, ...)
-  }
-
-  if (!is.null(xml_children)) {
-    child <- xml_add_child(child, xml_children, ...)
-  }
-
-  return(child)
-}
-
-#' adds or updates attribute(s) in children of existing xml node
-#'
-#' @details If a named attribute in `xml_attributes` is "" remove the attribute
-#' from the node.
-#' If `xml_attributes` contains a named entry found in the xml node, it is
-#' updated else it is added as attribute.
-#'
-#' @param xml_node some valid xml_node
-#' @param xml_child a name of a child node that should be modified
-#' @param xml_attributes R vector of named attributes
-#' @param xml_children R character vector children attached to the xml_node
-#' @param ... additional attributes passed to function
-#' @examples
-#' xml <- "<foo><bar a=\"0\"/></foo>"
-#' xml_child_mod(xml, xml_child = "bar", xml_children = "<openxlsx2/>")
-#' xml_child_mod(xml, xml_child = "baz", xml_children = "<openxlsx2/>")
-#'
-#' xml_child_mod(xml, xml_child = "bar", xml_attributes = c(a = "1", b = "2"))
-#' xml_child_mod(xml, xml_child = "baz", xml_attributes = c(a = "1", b = "2"))
-#'
-#' @seealso [xml_attr_mod()]
-#'
-#' @export
-xml_child_mod <- function(xml_node, xml_child, xml_attributes = NULL, xml_children = NULL, ...) {
-
-  if (missing(xml_node))
-    stop("need xml_node")
-
-  if (missing(xml_child))
-    stop("need xml_child")
-
-  if (!inherits(xml_node, "pugi_xml")) xml_node <- read_xml(xml_node, ...)
-  assert_class(xml_child, "character")
-
-  cld_name <- xml_child
-  xml_name <- xml_node_name(xml_node)
-  xml_clds <- xml_node_name(xml_node, xml_name)
-
-  # check if the child exists, if true, replace it, else add it
-  if (cld_name %in% xml_clds) {
-    child <- xml_node(xml_node, xml_name, cld_name)
-    child <- upd_child(child, xml_attributes = xml_attributes, xml_children = xml_children, ... = ...)
-    z     <- xml_replace_child(xml_node, xml_find_node(xml_node, cld_name), child, ...)
-  } else {
-    child <- xml_node_create(xml_child, ...)
-    child <- upd_child(child, xml_attributes = xml_attributes, xml_children = xml_children, ... = ...)
-    z     <- xml_add_child(xml_node, child, ...)
-  }
-
-  return(z)
-}
+}