[write] add params argument to wb_add_data_table()

R/class-workbook-wrappers.R

@@ -282,6 +282,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
@@ -329,7 +330,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)
@@ -354,6 +356,7 @@ wb_add_data_table <- function(
     na.strings        = na.strings,
     inline_strings    = inline_strings,
     total_row         = total_row,
+    params            = params,
     ...               = ...
   )
 }

R/class-workbook.R

@@ -1505,6 +1505,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(
@@ -1528,6 +1529,7 @@ wbWorkbook <- R6::R6Class(
         na.strings        = na_strings(),
         inline_strings    = TRUE,
         total_row         = FALSE,
+        params            = NULL,
         ...
     ) {
 
@@ -1562,7 +1564,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)
     },
@@ -3791,9 +3794,8 @@ wbWorkbook <- R6::R6Class(
         tActive <- self$tables$tab_act
       }
 
-
       ### autofilter
-      autofilter <- if (withFilter) {
+      autofilter <- if (!isFALSE(withFilter)) {
         autofilter_ref <- ref
         xml_node_create(xml_name = "autoFilter", xml_attributes = c(ref = autofilter_ref))
       }
@@ -3867,6 +3869,48 @@ wbWorkbook <- R6::R6Class(
         #headerRowDxfId="1"
       )
 
+
+      # run this if withFilter is something (TRUE or a character)
+      autofilter <- NULL
+      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
+        autofilter <- xml_node_create(xml_name = "autoFilter", xml_attributes = c(ref = autofilter_ref))
+      }
+
+      if (is.character(withFilter)) {
+        fltr_nms <- names(withFilter)
+        fltr_nms <- paste0("x$", escape_varname(fltr_nms))
+
+        filter <- vapply(
+          seq_along(fltr_nms),
+          function(i) {
+            gsub("^x", replacement = fltr_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)
+
+        ## revese the condition to make sure that we have lower strings
+        ## select the rows to hide and hide them
+        filter <- reverse_conditions(fltr)
+        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

@@ -1439,6 +1439,226 @@ file_ext2 <- function(filepath) {
   sub(".*\\.", "", basename2(filepath))
 }
 
+#' 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_)
+}
+
+#' 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]])
+
+    nams <- gsub("`", "", gsub("^x\\$", "", args[1]))
+    vals <- eval(parse(text = args[2]))
+
+    # openxml does not care about case sensitivity
+    vals <- if (is.character(vals)) tolower(vals) else vals
+
+    list(nams = nams, vals = vals)
+  }
+
+  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
+}
+
+#' helper to parse the conditions back into the expressions
+#'  so that we can have lower case strings
+#' @param conditions a condition created by [create_conditions()]
+#' @keywords internal
+#' @noRd
+reverse_conditions <- function(conditions) {
+
+  filter_expr <- vector("character", length(conditions))
+  i <- 1
+
+  for (name in names(conditions)) {
+    condition <- conditions[[name]]
+
+    operator <- condition$operator
+    value    <- condition$val
+
+    value_str <- if (is.character(value)) {
+      shQuote(value, type = "cmd")
+    } else {
+       value
+    }
+
+    # merge for potential "%in%"
+    if (operator == "equal") value_str <- paste0("c(", paste0(value_str, collapse = ", "), ")")
+
+    name <- escape_varname(name)
+
+    expr <- switch(
+      operator,
+      "equal"              = paste0("x$", name, " %in% ", value_str), # not ==
+      "notEqual"           = paste0("x$", name, " != ", value_str),
+      "lessThan"           = paste0("x$", name, " < ", value_str),
+      "lessThanOrEqual"    = paste0("x$", name, " <= ", value_str),
+      "greaterThan"        = paste0("x$", name, " > ", value_str),
+      "greaterThanOrEqual" = paste0("x$", name, " >= ", value_str),
+      stop("Unknown operator: ", operator)
+    )
+
+    filter_expr[i] <- expr
+    i <- i + 1
+  }
+
+  # Return the vector of filter expressions
+  filter_expr
+}
+
+#' 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 = as_xml_attr(x)))
+        },
+        FUN.VALUE = NA_character_
+      )
+
+      filters      <- xml_node_create("filters")
+      filterColumn <- xml_node_create("filterColumn", xml_attributes = c(colId = 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 = as_xml_attr(x))
+          )
+        },
+        FUN.VALUE = NA_character_
+      )
+
+      customFilters <- xml_node_create("customFilters")
+      filterColumn  <- xml_node_create("filterColumn", xml_attributes = c(colId = 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)
+
+  chrs <- vapply(x, is.character, NA)
+  x[chrs] <- lapply(x[chrs], tolower)
+
+  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)
+}
+
 if (getRversion() < "4.0.0") {
   deparse1 <- function(expr, collapse = " ") {
     paste(deparse(expr), collapse = collapse)

R/write.R

@@ -835,6 +835,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(
@@ -863,7 +864,8 @@ write_data_table <- function(
     inline_strings  = TRUE,
     total_row       = FALSE,
     enforce         = FALSE,
-    shared          = FALSE
+    shared          = FALSE,
+    params          = NULL
 ) {
 
   ## Input validating
@@ -1154,6 +1156,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,
@@ -1411,6 +1418,7 @@ do_write_datatable <- function(
     inline_strings    = TRUE,
     total_row         = FALSE,
     shared            = FALSE,
+    params            = params,
     ...
 ) {
 
@@ -1441,6 +1449,7 @@ do_write_datatable <- function(
     na.strings      = na.strings,
     inline_strings  = inline_strings,
     total_row       = total_row,
-    shared          = shared
+    shared          = shared,
+    params          = params
   )
 }