R/Workbook.R

In huxtable: Easily Create and Style Tables for LaTeX, HTML and Other Formats

#' @import assertthat
NULL


#' Convert a huxtable for Excel
#'
#' If the `openxlsx` package is installed, Huxtables can be converted to
#' [openxlsx::openxlsx()] Worbook objects, for use in Excel documents.
#'
#' @param ht A huxtable.
#' @param Workbook An existing `Workbook` object. By default, a new workbook will be created.
#' @param sheet Name for the worksheet where the huxtable will be created. The
#'   worksheet will be created if it doesn't exist already.
#' @param write_caption If `TRUE`, print any caption in the row above or below the table.
#' @param start_row,start_col Number. Write data starting at the given row and column.
#' @param ... Not used.
#'
#' @details
#' Use [openxlsx::saveWorkbook()] to save the resulting object to an Excel file.
#'
#' Properties are supported with the following exceptions:
#' * Non-numeric column widths and row heights, table width and height.
#' * Decimal padding.
#' * Cell padding.
#' * Table position.
#' * Caption width.
#'
#' Huxtable tries to guess appropriate widths and height for rows and columns; numeric [width()] and
#' [height()] are treated as scaling factors.
#'
#' Contents are only stored as numbers if a whole column is "numeric", i.e. can
#' be converted by [as.numeric()]). Otherwise, they are stored as text.
#'
#' @return An object of class `Workbook`.
#' @export
#'
#' @examples
#' wb <- as_Workbook(jams)
#'
#' \dontrun{
#' openxlsx::saveWorkbook(
#'   wb,
#'   "my-excel-file.xlsx"
#' )
#' }
#'
#' # multiple sheets in a single workbook:
#' wb <- openxlsx::createWorkbook()
#' wb <- as_Workbook(jams,
#'   Workbook = wb, sheet = "sheet1"
#' )
#' wb <- as_Workbook(
#'   hux("Another", "huxtable"),
#'   Workbook = wb,
#'   sheet = "sheet2"
#' )
as_Workbook <- function(ht, ...) UseMethod("as_Workbook")


memo_env <- new.env()

#' @export
#' @rdname as_Workbook
as_Workbook.huxtable <- function(ht,
                                 Workbook = NULL,
                                 sheet = "Sheet 1",
                                 write_caption = TRUE,
                                 start_row = 1,
                                 start_col = 1,
                                 ...) {
  assert_package("as_Workbook", "openxlsx")
  assert_that(is.string(sheet), is.count(start_row), is.count(start_col))

  if (!exists("memoised_createStyle", where = memo_env)) {
    memo_env$memoised_createStyle <- memoise::memoise(openxlsx::createStyle)
  }
  wb <- if (missing(Workbook) || is.null(Workbook)) openxlsx::createWorkbook() else Workbook
  if (!sheet %in% names(wb)) openxlsx::addWorksheet(wb, sheet)
  top_cap <- write_excel_caption(wb, ht, sheet, write_caption, start_row, start_col)

  contents <- clean_contents(ht, output_type = "excel") # character matrix

  write_excel_contents(wb, sheet, contents, start_row, start_col, top_cap)

  apply_excel_styles(wb, sheet, ht, contents, start_row, start_col, top_cap)

  set_excel_dimensions(wb, sheet, ht, start_row, start_col)

  return(wb)
}

#' Write caption to an Excel worksheet
#'
#' @noRd
write_excel_caption <- function(wb, ht, sheet, write_caption, start_row, start_col) {
  cap <- caption(ht)
  cap_pos <- caption_pos(ht)
  top_cap <- write_caption && !is.na(cap) && grepl("top", cap_pos)
  cap_row <- if (top_cap) start_row else start_row + nrow(ht)
  if (write_caption && !is.na(cap)) {
    openxlsx::writeData(wb, sheet, x = cap, startRow = cap_row)
    cap_style <- openxlsx::createStyle(halign = get_caption_hpos(ht))
    openxlsx::addStyle(wb, sheet,
      style = cap_style, rows = cap_row, cols = seq_len(ncol(ht)),
      gridExpand = TRUE
    )
    openxlsx::mergeCells(wb, sheet, cols = seq_len(ncol(ht)), rows = cap_row)
  }
  top_cap
}

#' Write huxtable contents to an Excel worksheet
#'
#' @noRd
write_excel_contents <- function(wb, sheet, contents, start_row, start_col, top_cap) {
  nr <- nrow(contents)
  contents <- as.data.frame(contents, stringsAsFactors = FALSE)
  is_a_number_mx <- suppressWarnings(apply(contents, 2, function(col) {
    !is.na(as.numeric(col))
  }))
  dim(is_a_number_mx) <- dim(contents) # apply might return a vector :-/
  for (j in seq_len(ncol(contents))) {
    col_contents <- contents[[j]]
    ws_col <- start_col - 1 + j

    for (i in seq_len(nr)) {
      ws_row <- start_row - 1 + i
      if (top_cap) ws_row <- ws_row + 1

      is_a_number_col <- is_a_number_mx[i:nr, j]
      if (all(is_a_number_col) || all(!is_a_number_col)) {
        insert <- col_contents[i:nr]
        if (all(is_a_number_col)) insert <- as.numeric(insert)

        openxlsx::writeData(wb, sheet, insert,
          startRow = ws_row, startCol = ws_col,
          colNames = FALSE, rowNames = FALSE, borders = "none", borderStyle = "none"
        )
        break
      } else {
        insert <- col_contents[i]
        if (is_a_number_col[1]) insert <- as.numeric(insert)
        openxlsx::writeData(wb, sheet, insert,
          startRow = ws_row, startCol = ws_col,
          colNames = FALSE, rowNames = FALSE, borders = "none", borderStyle = "none"
        )
      }
    }
  }
}

#' Apply styles to an Excel worksheet
#'
#' @noRd
apply_excel_styles <- function(wb, sheet, ht, contents, start_row, start_col, top_cap) {
  dcells <- display_cells(ht, all = FALSE)
  for (r in seq_len(nrow(dcells))) {
    dcell <- dcells[r, ]
    drow <- dcell$display_row
    dcol <- dcell$display_col

    workbook_rows <- start_row - 1 + seq(drow, dcell$end_row)
    if (top_cap) workbook_rows <- workbook_rows + 1
    workbook_cols <- start_col - 1 + seq(dcol, dcell$end_col)

    null_args <- list()
    null_args$tc <- text_color(ht)[drow, dcol]
    null_args$fs <- font_size(ht)[drow, dcol]
    null_args$ft <- font(ht)[drow, dcol]
    null_args$bgc <- background_color(ht)[drow, dcol]
    null_args <- lapply(null_args, function(x) if (is.na(x)) NULL else x)

    nf <- number_format(ht)[[drow, dcol]]
    format_zero <- format_numbers(0, nf)
    num_fmt <- if (grepl("^0\\.0+$", format_zero)) format_zero else if (is.numeric(contents[drow, dcol])) "NUMBER" else "GENERAL"

    borders <- get_all_borders(ht, drow, dcol)
    border_char <- names(borders)
    border_colors <- get_all_border_colors(ht, drow, dcol)
    border_colors <- unlist(border_colors[border_char])
    border_colors[is.na(border_colors)] <- getOption("openxlsx.borderColour", "black")

    border_styles <- get_all_border_styles(ht, drow, dcol)
    border_styles <- unlist(border_styles[border_char])
    border_styles[border_styles == "solid"] <- as.character(cut(
      unlist(borders[border_styles == "solid"]),
      c(-1, 0, 0.5, 1, 2, Inf),
      labels = c("none", "hair", "thin", "medium", "thick")
    ))

    va <- valign(ht)[drow, dcol]

    style <- memo_env$memoised_createStyle(
      fontName = null_args$ft,
      fontSize = null_args$fs,
      fontColour = null_args$tc,
      numFmt = num_fmt,
      border = border_char,
      borderColour = border_colors,
      borderStyle = border_styles,
      fgFill = null_args$bgc, # bgFill is "for conditional formatting only"
      halign = real_align(ht)[drow, dcol],
      valign = switch(va,
        middle = "center",
        va
      ),
      textDecoration = c("bold", "italic")[c(bold(ht)[drow, dcol], italic(ht)[drow, dcol])],
      wrapText = wrap(ht)[drow, dcol],
      textRotation = rotation(ht)[drow, dcol]
    )
    openxlsx::addStyle(wb, sheet,
      style = style, rows = workbook_rows, cols = workbook_cols,
      gridExpand = TRUE
    )
    if (dcell$rowspan > 1 || dcell$colspan > 1) {
      openxlsx::mergeCells(wb, sheet,
        cols = workbook_cols,
        rows = workbook_rows
      )
    }
  }
}

#' Set dimensions for an Excel worksheet
#'
#' @noRd
set_excel_dimensions <- function(wb, sheet, ht, start_row, start_col) {
  cw <- col_width(ht)
  if (!is.numeric(cw) || anyNA(cw)) cw <- rep(1 / ncol(ht), ncol(ht))
  basic_width <- 20 * ncol(ht)
  w <- width(ht)
  if (!is.numeric(w) || is.na(w)) w <- 0.5
  openxlsx::setColWidths(wb, sheet,
    cols = start_col - 1 + seq_len(ncol(ht)),
    widths = cw * w * basic_width
  )

  if (is.numeric(rh <- row_height(ht)) && length(rh) > 0) {
    table_height <- height(ht)
    if (is.na(table_height) || !is.numeric(table_height)) table_height <- 1
    basic_height <- 30 * nrow(ht)
    openxlsx::setRowHeights(wb, sheet,
      rows = start_row - 1 + seq_len(nrow(ht)),
      heights = rh * basic_height * table_height
    )
  }
}