R/tabexport.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

#============================================================
# tabexport.R - Version 5
# Export one or more r4vn_tab/r4vn_tabmulti objects.
#
# Data source:
#   - Word/Excel: object$data created directly by tab()/tabmulti()
#   - HTML/PDF/PNG: original table_html/html
#
# No tabledata.R or HTML-to-data parser is required.
#
# Examples:
# tabexport(tb1, tb2, tb3)
# tabexport(tb1, tb2, tb3, export=c("html","docx","xlsx"), file="Hypertension")
#============================================================

#' Export One or More R4VN Tables
#'
#' Accepts objects created by \code{tab()} or \code{tabmulti()}, as well as
#' data frames and matrices, and returns their data or exports them to HTML,
#' Word, Excel, PDF, or PNG.
#'
#' @usage
#' tabexport(..., export = NULL, file = NULL, open = FALSE, title = NULL,
#'           sheet = NULL, overwrite = TRUE, quiet = FALSE)
#'
#' @param ... One or more \code{r4vn_tab}, \code{r4vn_tabmulti}, data-frame,
#'   or matrix objects. A list of tables is also accepted.
#' @param export Output format: \code{"html"}, \code{"docx"},
#'   \code{"xlsx"}, \code{"pdf"}, \code{"png"}, or a vector of formats.
#'   \code{NULL} or \code{FALSE} returns data only. \code{TRUE} is
#'   equivalent to \code{"html"}. Aliases \code{"word"} and
#'   \code{"excel"} are accepted.
#' @param file Base output path. The extension is added automatically.
#' @param open Logical. Open the last exported file.
#' @param title Optional report title.
#' @param sheet Optional Excel sheet names.
#' @param overwrite Logical. Overwrite existing files.
#' @param quiet Logical. Suppress export messages.
#'
#' @details
#' Word and Excel use the flat \code{$data} component stored in R4VN table
#' objects. HTML, PDF, and PNG retain the original HTML presentation.
#'
#' Optional packages are required for some formats:
#' \itemize{
#'   \item Excel: \pkg{openxlsx} or \pkg{writexl};
#'   \item Word: \pkg{officer} and \pkg{flextable};
#'   \item PDF: \pkg{pagedown} and Chrome or Chromium;
#'   \item PNG: \pkg{webshot2} and a compatible browser.
#' }
#'
#' With \code{export = NULL}, one table returns a data frame and multiple
#' tables return a named list of data frames.
#'
#' @return When \code{export = NULL} or \code{FALSE}, returns a data frame or
#'   list. Otherwise invisibly returns an object of class
#'   \code{r4vn_export} containing \code{data}, \code{files},
#'   \code{objects}, and \code{call}.
#'
#' @seealso \code{\link{tab}} and \code{\link{tabmulti}}.
#' @family R4VN tables
#'
#' @examples
#' set.seed(2026)
#' dat <- data.frame(
#'   age = round(rnorm(80, 45, 12)),
#'   sex = factor(sample(c("Female", "Male"), 80, TRUE)),
#'   bmi = round(rnorm(80, 23, 3), 1)
#' )
#'
#' tb <- tab(
#'   dat,
#'   vars = vars(c.age, b2.sex, q.bmi),
#'   title = "Descriptive characteristics",
#'   show = FALSE
#' )
#'
#' # Return a flat data frame without creating a file.
#' exported_data <- tabexport(tb)
#' head(exported_data)
#'
#' # Export HTML to a temporary location.
#' html_result <- tabexport(
#'   tb,
#'   export = "html",
#'   file = file.path(tempdir(), "r4vn_example"),
#'   quiet = TRUE
#' )
#' html_result$files
#' unlink(html_result$files)
#'
#' \donttest{
#' if (requireNamespace("officer", quietly = TRUE) &&
#'     requireNamespace("flextable", quietly = TRUE) &&
#'     requireNamespace("openxlsx", quietly = TRUE)) {
#'   ex <- tabexport(
#'     tb,
#'     export = c("html", "docx", "xlsx"),
#'     file = tempfile("R4VN_report_"),
#'     open = FALSE
#'   )
#'   unlink(ex$files)
#' }
#' }
#'
#' # Extended usage examples
#' \donttest{
#' t1 <- tab(iris, vars = vars(c.Sepal.Length, c.Sepal.Width, Species),
#'           show = FALSE)
#' t2 <- tab(iris, vars = vars(c.Sepal.Length, c.Petal.Length), by = Species,
#'           test = TRUE, show = FALSE)
#'
#' # Return the underlying data frame
#' tabexport(t1, export = NULL)
#'
#' # One or several output formats, with several tables in one report
#' ex1 <- tabexport(t1, t2, export = "html", file = tempfile("Iris_tables_"), open = FALSE)
#' unlink(ex1$files)
#' if (requireNamespace("officer", quietly = TRUE) &&
#'     requireNamespace("flextable", quietly = TRUE) &&
#'     requireNamespace("openxlsx", quietly = TRUE)) {
#'   ex2 <- tabexport(t1, t2, export = c("html", "docx", "xlsx"),
#'                    file = tempfile("Iris_analysis_"), title = "Iris analysis", open = FALSE)
#'   unlink(ex2$files)
#' }
#'
#' # PDF/PNG export is available when its external rendering tools are installed.
#' }
#' @export
tabexport <- function(..., export = NULL, file = NULL, open = FALSE, title = NULL,
                      sheet = NULL, overwrite = TRUE, quiet = FALSE) {
  objects <- list(...)
  object_names <- names(objects)

  if (length(objects) == 1L && is.list(objects[[1L]]) &&
      !inherits(objects[[1L]], c("r4vn_tab", "r4vn_tabmulti", "data.frame", "matrix"))) {
    inner <- objects[[1L]]
    objects <- inner
    object_names <- names(inner)
  }

  if (!length(objects)) stop("At least one table must be supplied.", call. = FALSE)
  if (is.null(object_names)) object_names <- rep("", length(objects))
  if (length(object_names) < length(objects)) object_names <- c(object_names, rep("", length(objects) - length(object_names)))

  valid <- vapply(objects, function(x) inherits(x, c("r4vn_tab", "r4vn_tabmulti")) || is.data.frame(x) || is.matrix(x), logical(1))
  if (any(!valid)) stop("Each object must be created by `tab()` or `tabmulti()`, or be a data frame or matrix.", call. = FALSE)
  if (!is.logical(open) || length(open) != 1L || is.na(open)) stop("`open` must be TRUE or FALSE.", call. = FALSE)
  if (!is.logical(overwrite) || length(overwrite) != 1L || is.na(overwrite)) stop("`overwrite` must be TRUE or FALSE.", call. = FALSE)
  if (!is.logical(quiet) || length(quiet) != 1L || is.na(quiet)) stop("`quiet` must be TRUE or FALSE.", call. = FALSE)

  clean_text <- function(x) {
    x <- as.character(x)
    x <- gsub("<br\\s*/?>", " ", x, ignore.case = TRUE)
    x <- gsub("<[^>]+>", "", x)
    x <- gsub("&lt;", "<", x, fixed = TRUE)
    x <- gsub("&gt;", ">", x, fixed = TRUE)
    x <- gsub("&quot;", "\"", x, fixed = TRUE)
    x <- gsub("&#39;", "'", x, fixed = TRUE)
    x <- gsub("&nbsp;", " ", x, fixed = TRUE)
    x <- gsub("&amp;", "&", x, fixed = TRUE)
    x <- gsub("[\r\n\t]+", " ", x)
    x <- gsub("\\s+", " ", x)
    trimws(x)
  }

  escape_html <- function(x) {
    x <- as.character(x)
    x <- gsub("&", "&amp;", x, fixed = TRUE)
    x <- gsub("<", "&lt;", x, fixed = TRUE)
    x <- gsub(">", "&gt;", x, fixed = TRUE)
    x <- gsub('"', "&quot;", x, fixed = TRUE)
    gsub("'", "&#39;", x, fixed = TRUE)
  }

  safe_name <- function(x, fallback = "Table") {
    x <- clean_text(x)
    x <- iconv(x, from = "", to = "ASCII//TRANSLIT")
    if (is.na(x)) x <- ""
    x <- gsub("[^A-Za-z0-9 _-]+", "", x)
    x <- gsub("\\s+", "_", trimws(x))
    if (!nzchar(x)) x <- fallback
    x
  }

  unique_sheet_names <- function(x) {
    out <- character(length(x))
    used <- character()
    for (i in seq_along(x)) {
      base <- safe_name(x[i], paste0("Table", i))
      base <- gsub("[\\\\/:?*\\[\\]]", "_", base)
      base <- substr(base, 1L, 31L)
      candidate <- base
      index <- 1L
      while (candidate %in% used) {
        index <- index + 1L
        suffix <- paste0("_", index)
        candidate <- paste0(substr(base, 1L, max(1L, 31L - nchar(suffix))), suffix)
      }
      out[i] <- candidate
      used <- c(used, candidate)
    }
    out
  }

  extract_title <- function(x, fallback) {
    if (is.data.frame(x) || is.matrix(x)) return(fallback)
    block <- x$table_html
    if (is.null(block) || !length(block) || !nzchar(block[1L])) return(fallback)
    match <- regmatches(block[1L], regexpr("<div class=\"table-title\">.*?</div>", block[1L], perl = TRUE))
    if (!length(match) || !nzchar(match)) fallback else clean_text(match)
  }

  extract_notes <- function(x) {
    if (is.data.frame(x) || is.matrix(x) || is.null(x$table_html)) return(character())
    pattern <- "<div class=\"(?:table-note|test-note|effect-note|model-note)\">.*?</div>"
    matches <- regmatches(x$table_html[1L], gregexpr(pattern, x$table_html[1L], perl = TRUE))[[1L]]
    if (!length(matches) || identical(matches, "-1")) return(character())
    notes <- clean_text(matches)
    notes[nzchar(notes)]
  }

  data_from_object <- function(x, index) {
    if (is.data.frame(x) || is.matrix(x)) {
      out <- as.data.frame(x, stringsAsFactors = FALSE, check.names = FALSE)
    } else {
      if (is.null(x$data) || !is.data.frame(x$data)) {
        stop(
          "Object ", index, " does not contain `$data`. Replace `tab.R` and `tabmulti.R` ",
          "with the current versions, reload the package, and recreate the table.",
          call. = FALSE
        )
      }
      out <- x$data
    }
    names(out) <- make.unique(as.character(names(out)), sep = "_")
    rownames(out) <- NULL
    out
  }

  fallback_title <- function(x, index) {
    if (inherits(x, "r4vn_tabmulti")) paste0("Table_", index, "_Multivariable") else paste0("Table_", index)
  }

  table_titles <- character(length(objects))
  tables <- vector("list", length(objects))
  notes <- vector("list", length(objects))

  for (i in seq_along(objects)) {
    fallback <- if (nzchar(object_names[i])) object_names[i] else fallback_title(objects[[i]], i)
    table_titles[i] <- extract_title(objects[[i]], fallback)
    tables[[i]] <- data_from_object(objects[[i]], i)
    notes[[i]] <- extract_notes(objects[[i]])
  }

  if (!is.null(sheet)) {
    sheet <- as.character(sheet)
    if (length(sheet) == 1L && length(tables) > 1L) sheet <- paste0(sheet, seq_along(tables))
    if (length(sheet) != length(tables)) stop("The number of names in `sheet` must equal the number of tables.", call. = FALSE)
    excel_names <- unique_sheet_names(sheet)
  } else {
    excel_names <- unique_sheet_names(table_titles)
  }
  names(tables) <- excel_names

  if (is.null(export) || identical(export, FALSE)) {
    if (length(tables) == 1L) return(tables[[1L]])
    return(tables)
  }

  if (isTRUE(export)) export <- "html"
  export <- tolower(as.character(export))
  export[export == "word"] <- "docx"
  export[export == "excel"] <- "xlsx"
  allowed <- c("html", "docx", "xlsx", "pdf", "png")
  invalid <- setdiff(export, allowed)
  if (length(invalid)) stop("`export` must contain only: ", paste(allowed, collapse = ", "), ". Invalid values: ", paste(invalid, collapse = ", "), ".", call. = FALSE)
  export <- unique(export)

  make_filename <- function(type) {
    extension <- paste0(".", type)
    if (is.null(file) || !length(file) || is.na(file[1L]) || !nzchar(file[1L])) {
      base <- if (!is.null(title) && nzchar(as.character(title)[1L])) safe_name(title[1L], "r4vn_report") else paste0("r4vn_report_", format(Sys.time(), "%Y%m%d_%H%M%S"))
      return(file.path(tempdir(), paste0(base, extension)))
    }
    supplied <- path.expand(as.character(file)[1L])
    directory <- dirname(supplied)
    base <- basename(supplied)
    if (nzchar(tools::file_ext(base))) base <- tools::file_path_sans_ext(base)
    file.path(directory, paste0(base, extension))
  }

  check_output <- function(path) {
    directory <- dirname(path)
    if (!dir.exists(directory)) {
      ok <- dir.create(directory, recursive = TRUE, showWarnings = FALSE)
      if (!ok && !dir.exists(directory)) stop("Could not create directory: ", directory, call. = FALSE)
    }
    if (file.exists(path) && !overwrite) stop("File already exists: ", path, call. = FALSE)
    invisible(path)
  }

  open_file <- function(path) {
    path <- normalizePath(path, winslash = "/", mustWork = FALSE)
    if (.Platform$OS.type == "windows") {
      shell.exec(path)
    } else if (identical(Sys.info()[["sysname"]], "Darwin")) {
      system2("open", path, wait = FALSE)
    } else {
      system2("xdg-open", path, wait = FALSE)
    }
    invisible(path)
  }

  dataframe_html <- function(data, table_title) {
    header <- paste0("<th>", escape_html(names(data)), "</th>", collapse = "")
    body <- if (!nrow(data)) "" else paste(vapply(seq_len(nrow(data)), function(i) {
      paste0("<tr>", paste0("<td>", escape_html(as.character(data[i, , drop = TRUE])), "</td>", collapse = ""), "</tr>")
    }, character(1)), collapse = "")
    paste0("<section class=\"r4vn-table\"><div class=\"table-title\">", escape_html(table_title),
           "</div><table><thead><tr>", header, "</tr></thead><tbody>", body, "</tbody></table></section>")
  }

  object_block <- function(x, index) {
    if (inherits(x, c("r4vn_tab", "r4vn_tabmulti")) && !is.null(x$table_html) && length(x$table_html) == 1L && nzchar(x$table_html)) return(x$table_html)
    dataframe_html(tables[[index]], table_titles[index])
  }

  combined_html <- function() {
    if (length(objects) == 1L && inherits(objects[[1L]], c("r4vn_tab", "r4vn_tabmulti")) &&
        !is.null(objects[[1L]]$html) && length(objects[[1L]]$html) == 1L && nzchar(objects[[1L]]$html)) {
      return(objects[[1L]]$html)
    }
    blocks <- vapply(seq_along(objects), function(i) object_block(objects[[i]], i), character(1))
    report_title <- if (is.null(title) || !nzchar(as.character(title)[1L])) "" else paste0("<h1>", escape_html(title[1L]), "</h1>")
    css <- paste0(
      "body{font-family:'Times New Roman',Times,serif;background:#fff;color:#111;margin:18px}",
      "h1{font-size:22px;margin:0 0 18px}.table-title{font-size:18px;font-weight:700;margin:0 0 8px}",
      ".r4vn-table{margin-bottom:28px;overflow-x:auto}.r4vn-table table{border-collapse:collapse;width:auto;min-width:760px;border-top:2px solid #111;border-bottom:2px solid #111}",
      ".r4vn-table th{padding:5px 9px;border-bottom:1.5px solid #111;font-weight:700;white-space:nowrap;text-align:center;background:#fff}",
      ".r4vn-table th:first-child{text-align:left;min-width:240px}.r4vn-table td{padding:4px 9px;vertical-align:top;border:0;white-space:nowrap;text-align:center}",
      ".r4vn-table td:first-child{text-align:left}.r4vn-table tr.variable-start td{border-top:1px solid #aaa}",
      ".level-name{display:inline-block;padding-left:22px}.variable-name{font-weight:700}.variable-code{font-family:Consolas,monospace;font-size:.78em;color:#666}",
      ".header-n{display:block;font-size:.78em;font-weight:400}.table-note,.test-note,.effect-note,.model-note{font-size:12px;color:#333;margin-top:6px;line-height:1.35}",
      ".diagnostic-start td{border-top:1.5px solid #555;padding-top:7px}.diagnostic-row td:first-child{font-style:italic}"
    )
    paste0("<!DOCTYPE html><html><head><meta charset=\"UTF-8\"><meta name=\"viewport\" content=\"width=device-width,initial-scale=1\"><style>",
           css, "</style></head><body>", report_title, paste(blocks, collapse = "<div style=\"height:28px\"></div>"), "</body></html>")
  }

  exported_files <- character()

  for (type in export) {
    output_file <- make_filename(type)
    check_output(output_file)

    if (type == "html") {
      writeLines(enc2utf8(combined_html()), output_file, useBytes = TRUE)
    }

    if (type == "xlsx") {
      if (requireNamespace("openxlsx", quietly = TRUE)) {
        workbook <- openxlsx::createWorkbook()
        header_style <- openxlsx::createStyle(textDecoration = "bold", halign = "center", border = "Bottom")
        for (i in seq_along(tables)) {
          sheet_name <- excel_names[i]
          openxlsx::addWorksheet(workbook, sheet_name)
          openxlsx::writeData(workbook, sheet_name, tables[[i]], headerStyle = header_style)
          openxlsx::freezePane(workbook, sheet_name, firstRow = TRUE, firstCol = TRUE)
          openxlsx::setColWidths(workbook, sheet_name, cols = seq_len(ncol(tables[[i]])), widths = "auto")
        }
        openxlsx::saveWorkbook(workbook, output_file, overwrite = TRUE)
      } else if (requireNamespace("writexl", quietly = TRUE)) {
        writexl::write_xlsx(tables, path = output_file)
      } else {
        stop("Package `openxlsx` or `writexl` is required for Excel export.", call. = FALSE)
      }
    }

    if (type == "docx") {
      if (!requireNamespace("officer", quietly = TRUE) || !requireNamespace("flextable", quietly = TRUE)) {
        stop("Packages `officer` and `flextable` are required for Word export.", call. = FALSE)
      }
      document <- officer::read_docx()

      # Word templates do not always contain styles named "Title" or
      # "heading 1". Select an available style and fall back to the document
      # default instead of failing.
      add_word_paragraph <- function(doc, text, preferred_styles = character()) {
        available <- tryCatch(as.character(officer::styles_info(doc)$style_name),
                              error = function(e) character())
        style <- NULL
        if (length(available) && length(preferred_styles)) {
          matched <- match(tolower(preferred_styles), tolower(available))
          matched <- matched[!is.na(matched)]
          if (length(matched)) style <- available[matched[1L]]
        }
        if (is.null(style) || !nzchar(style)) {
          officer::body_add_par(doc, value = text)
        } else {
          officer::body_add_par(doc, value = text, style = style)
        }
      }

      if (!is.null(title) && nzchar(as.character(title)[1L])) {
        document <- add_word_paragraph(
          document, as.character(title)[1L],
          c("Title", "graphic title", "table title", "heading 1", "Normal")
        )
      }

      for (i in seq_along(tables)) {
        document <- add_word_paragraph(
          document, table_titles[i],
          c("heading 1", "table title", "graphic title", "Title", "Normal")
        )
        ft <- flextable::flextable(tables[[i]])
        ft <- flextable::theme_booktabs(ft)
        ft <- flextable::bold(ft, part = "header")
        ft <- flextable::align(ft, align = "center", part = "header")
        if (ncol(tables[[i]]) >= 1L) ft <- flextable::align(ft, j = 1L, align = "left", part = "all")
        if (ncol(tables[[i]]) > 8L) ft <- flextable::fontsize(ft, size = 7.5, part = "all") else ft <- flextable::fontsize(ft, size = 9, part = "all")
        ft <- flextable::font(ft, fontname = "Times New Roman", part = "all")
        ft <- flextable::autofit(ft)
        ft <- flextable::set_table_properties(ft, layout = "autofit", width = 1)
        document <- flextable::body_add_flextable(document, value = ft)

        if (length(notes[[i]])) {
          for (note in notes[[i]]) {
            document <- add_word_paragraph(document, note, c("Normal", "normal"))
          }
        }
        if (i < length(tables)) document <- officer::body_add_break(document)
      }
      print(document, target = output_file)
    }

    if (type %in% c("pdf", "png")) {
      temporary_html <- tempfile(fileext = ".html")
      writeLines(enc2utf8(combined_html()), temporary_html, useBytes = TRUE)
      if (type == "pdf") {
        if (!requireNamespace("pagedown", quietly = TRUE)) stop("Package `pagedown` and Chrome/Chromium are required for PDF export.", call. = FALSE)
        pagedown::chrome_print(input = temporary_html, output = output_file)
      } else {
        if (!requireNamespace("webshot2", quietly = TRUE)) stop("Package `webshot2` is required for PNG export.", call. = FALSE)
        webshot2::webshot(
          url = temporary_html,
          file = output_file,
          vwidth = 1600,
          vheight = 1200,
          zoom = 2,
          delay = 0.2
        )
      }
    }

    output_file <- normalizePath(output_file, winslash = "/", mustWork = file.exists(output_file))
    exported_files <- c(exported_files, output_file)
    if (!quiet) message("Exported: ", output_file)
  }

  if (open && length(exported_files)) open_file(utils::tail(exported_files, 1L))

  result <- list(data = if (length(tables) == 1L) tables[[1L]] else tables,
                 files = exported_files, objects = objects, call = match.call())
  class(result) <- c("r4vn_export", "list")
  invisible(result)
}

#' Print an R4VN Export Result
#'
#' Lists exported file paths, or prints returned table data when no files were
#' created.
#'
#' @param x An object returned by \code{tabexport()}.
#' @param ... Additional arguments currently ignored.
#' @return The input object, invisibly.
#' @keywords internal
#' @method print r4vn_export
#' @export
print.r4vn_export <- function(x, ...) {
  if (length(x$files)) {
    cat("Exported files:\n")
    cat(paste0(" - ", x$files, collapse = "\n"), "\n")
  } else {
    print(x$data)
  }
  invisible(x)
}

attr(tabexport, "r4vn_version") <- "tabexport-5.0.0-2026-08-03"