[write] add total_row option to wb_add_data_table() (#959)

NEWS.md

@@ -4,6 +4,8 @@
 
 * It's now possible to pass array formula vectors to `wb_add_formula()`.
 
+* `wb_add_data_table()` gained a new `total_row` argument. This allows to add a total row to spreadsheets including text and spreadsheet formulas.
+
 ## Fixes
 
 * Export `wb_add_ignore_error()`. [955](https://github.com/JanMarvin/openxlsx2/pull/955)

R/class-workbook-wrappers.R

@@ -260,10 +260,31 @@ wb_add_data <- function(
 #' @param last_column logical. If `TRUE`, the last column is bold.
 #' @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 ... additional arguments
 #'
+#' @details # Modify total row argument
+#' It is possible to further tweak the total row. In addition to the default
+#' `FALSE` possible values are `TRUE` (the xlsx file will create column sums
+#' each variable).
+#'
+#' In addition it is possible to tweak this further using a character string
+#' with one of the following functions for each variable: `"average"`,
+#' `"count"`, `"countNums"`, `"max"`, `"min"`, `"stdDev"`, `"sum"`, `"var"`.
+#' It is possible to leave the cell empty `"none"` or to create a text input
+#' using a named character with name `text` like: `c(text = "Total")`.
+#' It's also possible to pass other spreadsheet software functions if they
+#' return a single value and hence `"SUM"` would work too.
+#'
 #' @family worksheet content functions
 #' @family workbook wrappers
+#' @examples
+#' wb <- wb_workbook()$add_worksheet()$
+#'   add_data_table(
+#'     x = as.data.frame(USPersonalExpenditure),
+#'     row_names = TRUE,
+#'     total_row = c(text = "Total", "none", "sum", "sum", "sum", "SUM")
+#'   )
 #' @export
 wb_add_data_table <- function(
     wb,
@@ -286,6 +307,7 @@ wb_add_data_table <- function(
     remove_cell_style = FALSE,
     na.strings        = na_strings(),
     inline_strings    = TRUE,
+    total_row        = FALSE,
     ...
 ) {
   assert_workbook(wb)
@@ -309,6 +331,7 @@ wb_add_data_table <- function(
     remove_cell_style = remove_cell_style,
     na.strings        = na.strings,
     inline_strings    = inline_strings,
+    total_row        = total_row,
     ...               = ...
   )
 }
@@ -530,7 +553,7 @@ wb_add_slicer <- function(
 #' cells (see the `MMULT()` example below). For this type of formula, the
 #' output range must be known a priori and passed to `dims`, otherwise only the
 #' value of the first cell will be returned. This type of formula, whose result
-#' extends over several cells, is only possible with scalar values. If a vector
+#' extends over several cells, is only possible with single strings. If a vector
 #' is passed, it is only possible to return individual cells.
 #'
 #' @param wb A Workbook object containing a worksheet.

R/class-workbook.R

@@ -1339,6 +1339,7 @@ wbWorkbook <- R6::R6Class(
     #' @param na.strings Value used for replacing `NA` values from `x`. Default
     #'   `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 ... additional arguments
     #' @return The `wbWorkbook` object
     add_data_table = function(
@@ -1361,6 +1362,7 @@ wbWorkbook <- R6::R6Class(
         remove_cell_style = FALSE,
         na.strings        = na_strings(),
         inline_strings    = TRUE,
+        total_row         = FALSE,
         ...
     ) {
 
@@ -1394,7 +1396,8 @@ wbWorkbook <- R6::R6Class(
         applyCellStyle  = apply_cell_style,
         removeCellStyle = remove_cell_style,
         na.strings      = na.strings,
-        inline_strings  = inline_strings
+        inline_strings  = inline_strings,
+        total_row       = total_row
       )
       invisible(self)
     },
@@ -2754,23 +2757,25 @@ wbWorkbook <- R6::R6Class(
     #' @param tableName tableName
     #' @param withFilter withFilter
     #' @param totalsRowCount totalsRowCount
+    #' @param totalLabel totalLabel
     #' @param showFirstColumn showFirstColumn
     #' @param showLastColumn showLastColumn
     #' @param showRowStripes showRowStripes
     #' @param showColumnStripes showColumnStripes
     #' @return The `wbWorksheet` object, invisibly
     buildTable = function(
-      sheet = current_sheet(),
+      sheet             = current_sheet(),
       colNames,
       ref,
       showColNames,
       tableStyle,
       tableName,
-      withFilter, # TODO set default for withFilter?
-      totalsRowCount = 0,
-      showFirstColumn = 0,
-      showLastColumn = 0,
-      showRowStripes = 1,
+      withFilter        = TRUE,
+      totalsRowCount    = 0,
+      totalLabel        = FALSE,
+      showFirstColumn   = 0,
+      showLastColumn    = 0,
+      showRowStripes    = 1,
       showColumnStripes = 0
     ) {
 
@@ -2799,32 +2804,65 @@ wbWorkbook <- R6::R6Class(
       }
 
       if (is.null(self$tables)) {
-        nms <- NULL
+        nms     <- NULL
         tSheets <- NULL
-        tNames <- NULL
+        tNames  <- NULL
         tActive <- NULL
       } else {
-        nms <- self$tables$tab_ref
+        nms     <- self$tables$tab_ref
         tSheets <- self$tables$tab_sheet
-        tNames <- self$tables$tab_name
+        tNames  <- self$tables$tab_name
         tActive <- self$tables$tab_act
       }
 
 
       ### autofilter
       autofilter <- if (withFilter) {
-        xml_node_create(xml_name = "autoFilter", xml_attributes = c(ref = ref))
+        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
+      if (!isFALSE(totalsRowCount)) {
+        trf <- totalsRowCount
+        has_total_row <- TRUE
+
+        if (length(totalLabel) == length(colNames)) {
+          lbl <- totalLabel
+          has_total_lbl <- all(is.na(totalLabel))
+        } else {
+          lbl <- rep(NA_character_, length(colNames))
+          has_total_lbl <- FALSE
+        }
       }
 
       ### tableColumn
       tableColumn <- sapply(colNames, function(x) {
         id <- which(colNames %in% x)
-        xml_node_create("tableColumn", xml_attributes = c(id = id, name = x))
+        trf_id <- if (has_total_row) trf[[id]] else NULL
+        lbl_id <- if (has_total_lbl && !is.na(lbl[[id]])) lbl[[id]] else NULL
+        xml_node_create(
+          "tableColumn",
+          xml_attributes = c(
+            id                = id,
+            name              = x,
+            totalsRowFunction = trf_id,
+            totalsRowLabel    = lbl_id
+          )
+        )
       })
 
       tableColumns <- xml_node_create(
-        xml_name = "tableColumns",
-        xml_children = tableColumn,
+        xml_name       = "tableColumns",
+        xml_children   = tableColumn,
         xml_attributes = c(count = as.character(length(colNames)))
       )
 
@@ -2849,8 +2887,8 @@ wbWorkbook <- R6::R6Class(
         name           = tableName,
         displayName    = tableName,
         ref            = ref,
-        totalsRowCount = totalsRowCount,
-        totalsRowShown = "0"
+        totalsRowCount = as_xml_attr(has_total_row),
+        totalsRowShown = as_xml_attr(has_total_row)
         #headerRowDxfId="1"
       )
 

R/helper-functions.R

@@ -976,3 +976,94 @@ clone_shared_strings <- function(wb_old, old, wb_new, new) {
   # print(sprintf("cloned: %s", length(new_ids)))
 
 }
+
+known_subtotal_funs <- function(x, total, table, row_names = FALSE) {
+
+  # unfortunately x has no row names at this point
+  ncol_x <- ncol(x) + row_names
+  nms_x <- names(x)
+  if (row_names) nms_x <- c("_rowNames_", nms_x)
+
+  fml <- vector("character", ncol_x)
+  atr <- vector("character", ncol_x)
+  lbl <- rep(NA_character_, ncol_x)
+
+  if (isTRUE(total) || all(as.character(total) == "109") || all(total == "sum")) {
+    fml <- paste0("SUBTOTAL(109,", table, "[", names(x), "])")
+    atr <- rep("sum", ncol_x)
+  } else {
+
+    # all get the same total_row value
+    if (length(total) == 1) {
+      total <- rep(total, ncol_x)
+    }
+
+    if (length(total) != ncol_x) {
+      stop("length of total_row and table columns do not match", call. = FALSE)
+    }
+
+    builtinIds <- c("101", "103", "102", "104", "105", "107", "109", "110")
+    builtins   <- c("average", "count", "countNums", "max", "min", "stdDev", "sum", "var")
+
+    ttl <- as.character(total)
+
+    for (i in seq_len(ncol_x)) {
+
+      if (any(names(total)[i] == "") && (ttl[i] %in% builtinIds || ttl[i] %in% builtins)) {
+        if (ttl[i] == "101" || ttl[i] == "average") {
+          fml[i] <- paste0("SUBTOTAL(", 101, ",", table, "[", nms_x[i], "])")
+          atr[i] <- "average"
+        } else if (ttl[i] == "102" || ttl[i] == "countNums") {
+          fml[i] <- paste0("SUBTOTAL(", 102, ",", table, "[", nms_x[i], "])")
+          atr[i] <- "countNums"
+        } else if (ttl[i] == "103" || ttl[i] == "count") {
+          fml[i] <- paste0("SUBTOTAL(", 103, ",", table, "[", nms_x[i], "])")
+          atr[i] <- "count"
+        } else if (ttl[i] == "104" || ttl[i] == "max") {
+          fml[i] <- paste0("SUBTOTAL(", 104, ",", table, "[", nms_x[i], "])")
+          atr[i] <- "max"
+        } else if (ttl[i] == "105" || ttl[i] == "min") {
+          fml[i] <- paste0("SUBTOTAL(", 105, ",", table, "[", nms_x[i], "])")
+          atr[i] <- "min"
+        } else if (ttl[i] == "107" || ttl[i] == "stdDev") {
+          fml[i] <- paste0("SUBTOTAL(", 107, ",", table, "[", nms_x[i], "])")
+          atr[i] <- "stdDev"
+        } else if (ttl[i] == "109" || ttl[i] == "sum") {
+          fml[i] <- paste0("SUBTOTAL(", 109, ",", table, "[", nms_x[i], "])")
+          atr[i] <- "sum"
+        } else if (ttl[i] == "110" || ttl[i] == "var") {
+          fml[i] <- paste0("SUBTOTAL(", 110, ",", table, "[", nms_x[i], "])")
+          atr[i] <- "var"
+        }
+
+      } else if (ttl[i] == "0" || ttl[i] == "none") {
+        fml[i] <- ""
+        atr[i] <- "none"
+      } else if (any(names(total)[i] == "text")) {
+        fml[i] <- as_xml_attr(ttl[i])
+        atr[i] <- ""
+        lbl[i] <- as_xml_attr(ttl[i])
+      } else {
+        # works, but in excel the formula is added to tables.xml as a child to the column
+        fml[i] <- paste0(ttl[i], "(", table, "[", nms_x[i], "])")
+        atr[i] <- "custom"
+      }
+
+    }
+
+  }
+
+  # prepare output
+  fml <- as.data.frame(t(fml))
+  names(fml) <- nms_x
+  names(atr) <- nms_x
+  names(lbl) <- nms_x
+
+  # prepare output to be written with formulas
+  for (i in seq_along(fml)) {
+    if (is.na(lbl[[i]])) class(fml[[i]]) <- c("formula", fml[[i]])
+  }
+
+  list(fml, atr, lbl)
+
+}