[write] add params argument to wb_add_data_table() which allows t…

…o filter a table with `choose`. Similar to how it is done in `wb_add_pivot_table()`.

R/class-workbook-wrappers.R

@@ -265,6 +265,7 @@ wb_add_data <- function(
 #' @param banded_rows logical. If `TRUE`, rows are color banded.
 #' @param banded_cols logical. If `TRUE`, the columns are color banded.
 #' @param total_row logical. With the default `FALSE` no total row is added.
+#' @param params list. Optional arguments passed to the data table creation.
 #' @param ... additional arguments
 #'
 #' @details # Modify total row argument
@@ -311,7 +312,8 @@ wb_add_data_table <- function(
  remove_cell_style = FALSE,
  na.strings = na_strings(),
  inline_strings = TRUE,
- total_row = FALSE,
+ total_row = FALSE,
+ params = NULL,
  ...
 ) {
  assert_workbook(wb)
@@ -336,6 +338,7 @@ wb_add_data_table <- function(
  na.strings = na.strings,
  inline_strings = inline_strings,
  total_row = total_row,
+ params = params,
  ... = ...
  )
 }

R/class-workbook.R

@@ -1400,6 +1400,7 @@ wbWorkbook <- R6::R6Class(
  #' `na_strings()` uses the special `#N/A` value within the workbook.
  #' @param inline_strings write characters as inline strings
  #' @param total_row write total rows to table
+ #' @param params optional parameters passed to the data table creation
  #' @param ... additional arguments
  #' @return The `wbWorkbook` object
  add_data_table = function(
@@ -1423,6 +1424,7 @@ wbWorkbook <- R6::R6Class(
  na.strings = na_strings(),
  inline_strings = TRUE,
  total_row = FALSE,
+ params = NULL,
  ...
  ) {
 
@@ -1457,7 +1459,8 @@ wbWorkbook <- R6::R6Class(
  removeCellStyle = remove_cell_style,
  na.strings = na.strings,
  inline_strings = inline_strings,
- total_row = total_row
+ total_row = total_row,
+ params = params
  )
  invisible(self)
  },
@@ -3431,19 +3434,6 @@ wbWorkbook <- R6::R6Class(
  tActive <- self$tables$tab_act
  }
 
-
- ### autofilter
- autofilter <- if (withFilter) {
- if (!isFALSE(totalsRowCount)) {
- # exclude total row from filter
- rowcol <- dims_to_rowcol(ref)
- autofilter_ref <- rowcol_to_dims(as.integer(rowcol[[2]])[-length(rowcol[[2]])], rowcol[[1]])
- } else {
- autofilter_ref <- ref
- }
- xml_node_create(xml_name = "autoFilter", xml_attributes = c(ref = autofilter_ref))
- }
-
  trf <- NULL
  has_total_row <- FALSE
  has_total_lbl <- FALSE
@@ -3508,6 +3498,47 @@ wbWorkbook <- R6::R6Class(
  #headerRowDxfId="1"
  )
 
+
+ # run this if withFilter is something (TRUE or a character)
+ if (!isFALSE(withFilter)) {
+ if (!isFALSE(totalsRowCount)) {
+ # exclude total row from filter
+ rowcol <- dims_to_rowcol(ref)
+ autofilter_ref <- rowcol_to_dims(as.integer(rowcol[[2]])[-length(rowcol[[2]])], rowcol[[1]])
+ } else {
+ autofilter_ref <- ref
+ }
+ }
+
+ ### autofilter
+ if (isTRUE(withFilter)) {
+ autofilter <- xml_node_create(xml_name = "autoFilter", xml_attributes = c(ref = autofilter_ref))
+ }
+
+ if (is.character(withFilter)) {
+ nms <- names(withFilter)
+ nms <- paste0("x$", escape_varname(nms))
+
+ filter <- vapply(
+ seq_along(nms),
+ function(i) {
+ gsub("^x", replacement = nms[i], x = withFilter[i])
+ },
+ NA_character_
+ )
+ names(filter) <- names(withFilter)
+
+ assert_class(filter, "character")
+
+ ### prepare condition list & autofilter xml
+ fltr <- create_conditions(filter)
+ autofilter <- prepare_autofilter(colNames, autofilter_ref, conditions = fltr)
+
+ # use ref: we dont want to hide a possible totalColumn row
+ sel <- rows_to_hide(self, sheet, ref, filter)
+ self$set_row_heights(rows = sel, hidden = TRUE)
+ }
+
  tab_xml_new <- xml_node_create(
  xml_name = "table",
  xml_children = c(autofilter, tableColumns, tableStyleXML),

R/utils.R

@@ -1405,3 +1405,170 @@ ave2 <- function(x, y, FUN) {
  split(x, g) <- lapply(split(x, g), FUN)
  x
 }
+
+#' helper to parse the string into something that can be converted into openxml
+#' column filters
+#' @param filter_expr an expression like "x$cyl != 4"
+#' @keywords internal
+#' @noRd
+create_conditions <- function(filter_expr) {
+
+ conditions <- vector("list", length(filter_expr))
+ names(conditions) <- names(filter_expr)
+
+ # Define a helper function to add conditions to the list
+ add_condition <- function(operator, value) {
+ list(val = value$vals, operator = operator)
+ }
+
+ get_vals <- function(fltr_xpr, operator) {
+ args <- trimws(strsplit(fltr_xpr, operator)[[1]])
+ list(
+ nams = gsub("`", "", gsub("^x\\$", "", args[1])),
+ vals = eval(parse(text = args[2]))
+ )
+ }
+
+ for (fltr_xpr in filter_expr) {
+
+ # Extract conditions for "equal"
+ if (grepl("%in%", fltr_xpr)) {
+ values <- get_vals(fltr_xpr, "%in%")
+ conditions[[values$nams]] <- add_condition("equal", values)
+ }
+
+ # Extract conditions for "equal" using ==
+ if (grepl("==", fltr_xpr)) {
+ values <- get_vals(fltr_xpr, "==")
+ conditions[[values$nams]] <- add_condition("equal", values)
+ }
+
+ # Extract conditions for "notEqual"
+ if (grepl("!=", fltr_xpr)) {
+ values <- get_vals(fltr_xpr, "!=")
+ conditions[[values$nams]] <- add_condition("notEqual", values)
+ }
+
+ # Extract conditions for "lessThan"
+ if (grepl("<[^=]", fltr_xpr)) { # "<" but not "<="
+ values <- get_vals(fltr_xpr, "<")
+ conditions[[values$nams]] <- add_condition("lessThan", values)
+ }
+
+ # Extract conditions for "lessThanOrEqual"
+ if (grepl("<=", fltr_xpr)) {
+ values <- get_vals(fltr_xpr, "<=")
+ conditions[[values$nams]] <- add_condition("lessThanOrEqual", values)
+ }
+
+ # Extract conditions for "greaterThan"
+ if (grepl(">[^=]", fltr_xpr)) { # ">" but not ">="
+ values <- get_vals(fltr_xpr, ">")
+ conditions[[values$nams]] <- add_condition("greaterThan", values)
+ }
+
+ # Extract conditions for "greaterThanOrEqual"
+ if (grepl(">=", fltr_xpr)) {
+ values <- get_vals(fltr_xpr, ">=")
+ conditions <- add_condition("greaterThanOrEqual", values)
+ }
+ }
+
+ conditions
+}
+
+#' function to create the autofilter xml structure required for openxml
+#' @param colNames character vector of column names
+#' @param autofilter_ref the autofilter reference
+#' @param conditions a named list with conditions to apply to the columns
+#' @keywords internal
+#' @noRd
+prepare_autofilter <- function(colNames, autofilter_ref, conditions) {
+
+ cond_vars <- names(conditions)
+ if (any(!cond_vars %in% colNames)) stop("Condtion variable not found in table.")
+
+ autoFilter <- xml_node_create("autoFilter", xml_attributes = c(ref = autofilter_ref))
+
+
+ aF <- NULL
+ for (cond_var in cond_vars) {
+ colId <- which(colNames == cond_var) - 1L
+
+ condition <- conditions[[cond_var]]
+
+ ## == default or %in% with multiple values
+ if (condition$operator == "equal") {
+ filter <- vapply(
+ condition$val,
+ function(x) {
+ xml_node_create("filter", xml_attributes = c(val = openxlsx2:::as_xml_attr(x)))
+ },
+ FUN.VALUE = NA_character_
+ )
+
+ filters <- xml_node_create("filters")
+ filterColumn <- xml_node_create("filterColumn", xml_attributes = c(colId = openxlsx2:::as_xml_attr(colId)))
+
+ filters <- xml_add_child(filters, filter)
+ filterColumn <- xml_add_child(filterColumn, filters)
+ }
+
+ ## != notEqual, < lessThan, <= lessThanOrEqual, > greaterThan, >= greaterThanOrEqual
+ ## TODO provide replacement function
+ ops <- c("notEqual", "lessThan", "lessThanOrEqual", "greaterThan", "greaterThanOrEqual")
+ if (condition$operator %in% ops) {
+ customFilter <- vapply(
+ condition$val,
+ function(x) {
+ xml_node_create(
+ "customFilter",
+ xml_attributes = c(operator = condition$operator,
+ val = openxlsx2:::as_xml_attr(x))
+ )
+ },
+ FUN.VALUE = NA_character_
+ )
+
+ customFilters <- xml_node_create("customFilters")
+ filterColumn <- xml_node_create("filterColumn", xml_attributes = c(colId = openxlsx2:::as_xml_attr(colId)))
+
+ customFilters <- xml_add_child(customFilters, customFilter)
+ filterColumn <- xml_add_child(filterColumn, customFilters)
+ }
+
+ aF <- c(aF, filterColumn)
+ }
+
+ autoFilter <- xml_add_child(autoFilter, aF)
+
+ autoFilter
+}
+
+#' get rows to hide (in _all but not in _sel)
+#' @param wb a wbWorkbook
+#' @param sheet the sheet index
+#' @param ref the dims
+#' @param filter the filter as character string
+#' @keywords internal
+#' @noRd
+rows_to_hide <- function(wb, sheet, ref, filter) {
+ x <- wb_to_df(wb, sheet = sheet, dims = ref)
+ rows_all <- rownames(x)
+
+ x <- x[eval(parse(text = paste0(filter, collapse = "&"))), , drop = FALSE]
+ rows_sel <- rownames(x)
+
+ out <- rows_all[!rows_all %in% rows_sel]
+ as.integer(out)
+}
+
+#' escape var name with upticks
+#' @param var_name variable name
+#' @keywords internal
+#' @noRd
+escape_varname <- function(var_name) {
+ vapply(var_name, function(x) {
+ ifelse(grepl("\\s", x), sprintf("`%s`", x), x)
+ }, NA_character_)
+}

R/write.R

@@ -780,6 +780,7 @@ write_data2 <- function(
 #' @param inline_strings optional write strings as inline strings
 #' @param total_row optional write total rows
 #' @param shared shared formula
+#' @param params optional list. contains data table filters in `choose`
 #' @noRd
 #' @keywords internal
 write_data_table <- function(
@@ -808,7 +809,8 @@ write_data_table <- function(
  inline_strings = TRUE,
  total_row = FALSE,
  enforce = FALSE,
- shared = FALSE
+ shared = FALSE,
+ params = NULL
 ) {
 
  ## Input validating
@@ -1091,6 +1093,11 @@ write_data_table <- function(
  ref2 <- paste0(int2col(startCol + nCol - !rowNames), startRow + nRow)
  ref <- paste(ref1, ref2, sep = ":")
 
+ if (is.list(params)) {
+ if (!is.null(params$choose))
+ withFilter <- params$choose
+ }
+
  ## create table.xml and assign an id to worksheet tables
  wb$buildTable(
  sheet = sheet,
@@ -1339,6 +1346,7 @@ do_write_datatable <- function(
  inline_strings = TRUE,
  total_row = FALSE,
  shared = FALSE,
+ params = params,
  ...
 ) {
 
@@ -1369,6 +1377,7 @@ do_write_datatable <- function(
  na.strings = na.strings,
  inline_strings = inline_strings,
  total_row = total_row,
- shared = shared
+ shared = shared,
+ params = params
  )
 }

R/write_xlsx.R

@@ -53,7 +53,7 @@ write_xlsx <- function(x, file, as_table = FALSE, ...) {
  "col.names", "row.names", "col_names", "row_names", "table_style",
  "table_name", "with_filter", "first_active_row", "first_active_col",
  "first_row", "first_col", "col_widths", "na.strings",
- "overwrite", "title", "subject", "category"
+ "overwrite", "title", "subject", "category", "params"
  )
 
  params <- list(...)
@@ -352,6 +352,12 @@ write_xlsx <- function(x, file, as_table = FALSE, ...) {
  wb$add_worksheet(nms[[i]], grid_lines = gridLines[i], tab_color = tabColor[i], zoom = zoom[i])
 
  if (as_table[i]) {
+
+ if (length(params$params) <= nSheets)
+ params_list <- params$params[i]
+ else
+ params_list <- NULL
+
  # add data table??
  do_write_datatable(
  wb = wb,
@@ -365,7 +371,8 @@ write_xlsx <- function(x, file, as_table = FALSE, ...) {
  table_name = NULL,
  with_filter = withFilter[[i]],
  na.strings = na.strings,
- total_row = totalRow
+ total_row = totalRow,
+ params = params_list
  )
  } else {
  # TODO add_data()?