From 9d91d93358f6f2ad124bc1d874abc9a7b62b2fb3 Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Sun, 1 Sep 2024 19:32:22 +0200 Subject: [PATCH] [write] add `params` argument to `wb_add_data_table()` which allows to filter a table with `choose`. Similar to how it is done in `wb_add_pivot_table()`. --- R/class-workbook-wrappers.R | 5 +- R/class-workbook.R | 58 ++++++++++--- R/utils.R | 167 ++++++++++++++++++++++++++++++++++++ R/write.R | 13 ++- R/write_xlsx.R | 18 +++- man/wbWorkbook.Rd | 3 + man/wb_add_data_table.Rd | 3 + tests/testthat/test-write.R | 35 ++++++++ 8 files changed, 283 insertions(+), 19 deletions(-) diff --git a/R/class-workbook-wrappers.R b/R/class-workbook-wrappers.R index 60c534a46..d8ff5fd94 100644 --- a/R/class-workbook-wrappers.R +++ b/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, ... = ... ) } diff --git a/R/class-workbook.R b/R/class-workbook.R index dcd213181..bf5ad3d71 100644 --- a/R/class-workbook.R +++ b/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,46 @@ 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) + + # 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), diff --git a/R/utils.R b/R/utils.R index 480a34c74..597930137 100644 --- a/R/utils.R +++ b/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_) +} diff --git a/R/write.R b/R/write.R index 8a8748a63..29ba1ac42 100644 --- a/R/write.R +++ b/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 ) } diff --git a/R/write_xlsx.R b/R/write_xlsx.R index 825da3a61..df0d24779 100644 --- a/R/write_xlsx.R +++ b/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,19 @@ 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]) { + + # every sheet has uniqure choose parameters + # or all share the same + # or choose parameters were found + if (is.list(params$params$choose) && length(params$params$choose) <= nSheets) { + params_list <- list(choose = params$params$choose[[i]]) + } else if (is.character(params$params$choose)) { + message("yes") + params_list <- list(choose = params$params$choose) + } else { + params_list <- NULL + } + # add data table?? do_write_datatable( wb = wb, @@ -365,7 +378,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()? diff --git a/man/wbWorkbook.Rd b/man/wbWorkbook.Rd index b9ce472a0..51e61b50e 100644 --- a/man/wbWorkbook.Rd +++ b/man/wbWorkbook.Rd @@ -598,6 +598,7 @@ add a data table na.strings = na_strings(), inline_strings = TRUE, total_row = FALSE, + params = NULL, ... )}\if{html}{\out{}} } @@ -646,6 +647,8 @@ add a data table \item{\code{total_row}}{write total rows to table} +\item{\code{params}}{optional parameters passed to the data table creation} + \item{\code{...}}{additional arguments} } \if{html}{\out{}} diff --git a/man/wb_add_data_table.Rd b/man/wb_add_data_table.Rd index 0682b0c2a..40dba7f04 100644 --- a/man/wb_add_data_table.Rd +++ b/man/wb_add_data_table.Rd @@ -26,6 +26,7 @@ wb_add_data_table( na.strings = na_strings(), inline_strings = TRUE, total_row = FALSE, + params = NULL, ... ) } @@ -81,6 +82,8 @@ uses the special \verb{#N/A} value within the workbook.} \item{total_row}{logical. With the default \code{FALSE} no total row is added.} +\item{params}{list. Optional arguments passed to the data table creation.} + \item{...}{additional arguments} } \description{ diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index 8028a29a1..4eb99af93 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -1239,3 +1239,38 @@ test_that("sheet is a valid argument in write_xlsx", { wb2 <- write_xlsx(x = mtcars, sheet = "data") expect_equal(wb1$get_sheet_names(), wb2$get_sheet_names()) }) + +test_that("writing tables with filters works", { + + exp <- mtcars[mtcars$cyl %in% c(4, 8) & mtcars$am != 1 & mtcars$vs == 1, ] + + wb <- wb_workbook() %>% + wb_add_worksheet() %>% + wb_add_data_table( + x = mtcars, + params = list( + choose = c(cyl = "x %in% c(4, 8)", + am = c("x != 1"), + vs = c("x == 1") + ) + ) + ) + + got <- wb_to_df(wb, skip_hidden_rows = TRUE) + expect_equal(exp, got, ignore_attr = TRUE) + + wb <- write_xlsx( + x = mtcars, + as_table = TRUE, + params = list( + choose = c(cyl = "x %in% c(4, 8)", + am = c("x != 1"), + vs = c("x == 1") + ) + ) + ) + + got <- wb_to_df(wb, skip_hidden_rows = TRUE) + expect_equal(exp, got, ignore_attr = TRUE) + +})