R/tabmeta-export.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# ============================================================================
# R4VN meta-analysis export helper
# Used by zzz-tabexport-meta.R
# ============================================================================

.r4vn_meta_safe_filename <- function(x, fallback = "meta_analysis") {
  x <- as.character(x)[1L]
  x <- iconv(x, from = "", to = "ASCII//TRANSLIT")
  if (is.na(x)) x <- fallback
  x <- gsub("[^A-Za-z0-9 _-]+", "", x)
  x <- gsub("\\s+", "_", trimws(x))
  if (!nzchar(x)) fallback else x
}

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

.r4vn_meta_export_html <- function(x, path) {
  dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
  asset_dir <- file.path(
    dirname(path),
    paste0(tools::file_path_sans_ext(basename(path)), "_files")
  )
  dir.create(asset_dir, recursive = TRUE, showWarnings = FALSE)

  html <- x$html
  if (length(x$plots)) {
    for (nm in names(x$plots)) {
      src <- x$plots[[nm]]
      if (file.exists(src)) {
        dst <- file.path(asset_dir, basename(src))
        file.copy(src, dst, overwrite = TRUE)
        replacement <- paste0(basename(asset_dir), "/", basename(src))
        html <- gsub(
          paste0('src="', basename(src), '"'),
          paste0('src="', replacement, '"'),
          html,
          fixed = TRUE
        )
      }
    }
  }

  writeLines(enc2utf8(html), path, useBytes = TRUE)
  normalizePath(path, winslash = "/", mustWork = TRUE)
}

.r4vn_meta_export_docx <- function(x, path, title = NULL) {
  for (pkg in c("officer", "flextable")) {
    if (!requireNamespace(pkg, quietly = TRUE)) {
      stop(
        "Package `", pkg, "` is required for Word export. Install it with ",
        "install.packages(\"", pkg, "\").",
        call. = FALSE
      )
    }
  }

  doc <- officer::read_docx()
  report_title <- if (is.null(title) || !nzchar(as.character(title)[1L])) {
    x$title
  } else {
    as.character(title)[1L]
  }

  doc <- officer::body_add_par(doc, report_title, style = "heading 1")

  for (nm in names(x$tables)) {
    tab <- x$tables[[nm]]
    if (is.null(tab) || !is.data.frame(tab)) next

    heading <- gsub("_", " ", nm, fixed = TRUE)
    doc <- officer::body_add_par(doc, heading, style = "heading 2")
    ft <- flextable::flextable(tab)
    ft <- flextable::theme_booktabs(ft)
    ft <- flextable::autofit(ft)
    ft <- flextable::fontsize(ft, size = 9, part = "all")
    doc <- flextable::body_add_flextable(doc, ft)
    doc <- officer::body_add_par(doc, "")
  }

  if (!is.null(x$bias$status)) {
    doc <- officer::body_add_par(
      doc, "Publication bias", style = "heading 2"
    )
    doc <- officer::body_add_par(doc, x$bias$status)
  }

  if (!is.null(x$small_sample$status)) {
    doc <- officer::body_add_par(
      doc, "Few-study inference", style = "heading 2"
    )
    doc <- officer::body_add_par(doc, x$small_sample$status)
  }

  if (isTRUE(x$report) &&
      (is.null(x$interpretation) || !nrow(x$interpretation))) {
    doc <- officer::body_add_par(doc, "Results text", style = "heading 2")
    doc <- officer::body_add_par(doc, x$results_text)
  }

  if (length(x$plots)) {
    for (nm in names(x$plots)) {
      img <- x$plots[[nm]]
      if (!file.exists(img)) next
      doc <- officer::body_add_par(
        doc, x$plot_titles[[nm]], style = "heading 2"
      )
      doc <- officer::body_add_img(
        doc, src = img, width = 6.5, height = 5.0
      )
      doc <- officer::body_add_par(doc, "")
    }
  }

  print(doc, target = path)
  normalizePath(path, winslash = "/", mustWork = TRUE)
}

.r4vn_meta_export_xlsx <- function(x, path) {
  if (!requireNamespace("openxlsx", quietly = TRUE)) {
    stop(
      "Package `openxlsx` is required for Excel meta-analysis export. ",
      "Install it with install.packages(\"openxlsx\").",
      call. = FALSE
    )
  }

  wb <- openxlsx::createWorkbook()
  used <- character()

  unique_sheet <- function(z) {
    z <- gsub("[\\\\/:?*\\[\\]]", "_", z)
    z <- substr(z, 1L, 31L)
    if (!nzchar(z)) z <- "Sheet"
    candidate <- z
    i <- 1L
    while (candidate %in% used) {
      i <- i + 1L
      suffix <- paste0("_", i)
      candidate <- paste0(
        substr(z, 1L, max(1L, 31L - nchar(suffix))), suffix
      )
    }
    used <<- c(used, candidate)
    candidate
  }

  for (nm in names(x$tables)) {
    tab <- x$tables[[nm]]
    if (is.null(tab) || !is.data.frame(tab)) next
    sh <- unique_sheet(gsub("_", " ", nm, fixed = TRUE))
    openxlsx::addWorksheet(wb, sh)
    openxlsx::writeData(wb, sh, tab)
    openxlsx::freezePane(wb, sh, firstRow = TRUE)
    openxlsx::setColWidths(
      wb, sh, cols = seq_len(ncol(tab)), widths = "auto"
    )
  }

  if (length(x$plots)) {
    for (nm in names(x$plots)) {
      img <- x$plots[[nm]]
      if (!file.exists(img)) next
      sh <- unique_sheet(paste0("Figure_", nm))
      openxlsx::addWorksheet(wb, sh)
      openxlsx::writeData(
        wb, sh, x$plot_titles[[nm]], startRow = 1, startCol = 1
      )
      openxlsx::insertImage(
        wb, sh, img,
        startRow = 3, startCol = 1,
        width = 7.5, height = 5.5, units = "in"
      )
    }
  }

  openxlsx::saveWorkbook(wb, path, overwrite = TRUE)
  normalizePath(path, winslash = "/", mustWork = TRUE)
}

.r4vn_export_meta <- function(
    x, export = NULL, file = NULL, open = FALSE, title = NULL,
    overwrite = TRUE, quiet = FALSE, ...) {

  if (!inherits(x, "r4vn_meta")) {
    stop("`x` must be an R4VN meta-analysis.", call. = FALSE)
  }

  if (is.null(export) || identical(export, FALSE)) return(x$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")
  bad <- setdiff(export, allowed)
  if (length(bad)) {
    stop(
      "Unsupported export format: ", paste(bad, collapse = ", "), ".",
      call. = FALSE
    )
  }
  export <- unique(export)

  if (is.null(file) || !length(file) ||
      is.na(as.character(file)[1L]) ||
      !nzchar(as.character(file)[1L])) {
    file <- file.path(tempdir(), .r4vn_meta_safe_filename(x$title))
  } else {
    file <- path.expand(as.character(file)[1L])
    if (nzchar(tools::file_ext(file))) {
      file <- tools::file_path_sans_ext(file)
    }
  }

  dir.create(dirname(file), recursive = TRUE, showWarnings = FALSE)
  outputs <- character()
  html_path <- NULL

  if (any(c("html", "pdf", "png") %in% export)) {
    html_path <- paste0(file, ".html")
    if (file.exists(html_path) && !overwrite) {
      stop("File already exists: ", html_path, call. = FALSE)
    }
    html_path <- .r4vn_meta_export_html(x, html_path)
    if ("html" %in% export) outputs <- c(outputs, html = html_path)
  }

  if ("docx" %in% export) {
    p <- paste0(file, ".docx")
    if (file.exists(p) && !overwrite) {
      stop("File already exists: ", p, call. = FALSE)
    }
    outputs <- c(
      outputs,
      docx = .r4vn_meta_export_docx(x, p, title)
    )
  }

  if ("xlsx" %in% export) {
    p <- paste0(file, ".xlsx")
    if (file.exists(p) && !overwrite) {
      stop("File already exists: ", p, call. = FALSE)
    }
    outputs <- c(outputs, xlsx = .r4vn_meta_export_xlsx(x, p))
  }

  if ("pdf" %in% export) {
    if (!requireNamespace("pagedown", quietly = TRUE)) {
      stop(
        "Package `pagedown` is required for PDF export.",
        call. = FALSE
      )
    }
    p <- paste0(file, ".pdf")
    if (file.exists(p) && !overwrite) {
      stop("File already exists: ", p, call. = FALSE)
    }
    pagedown::chrome_print(input = html_path, output = p)
    outputs <- c(
      outputs,
      pdf = normalizePath(p, winslash = "/", mustWork = TRUE)
    )
  }

  if ("png" %in% export) {
    if (!requireNamespace("webshot2", quietly = TRUE)) {
      stop(
        "Package `webshot2` is required for PNG report export.",
        call. = FALSE
      )
    }
    p <- paste0(file, ".png")
    if (file.exists(p) && !overwrite) {
      stop("File already exists: ", p, call. = FALSE)
    }
    webshot2::webshot(url = html_path, file = p, full_page = TRUE)
    outputs <- c(
      outputs,
      png = normalizePath(p, winslash = "/", mustWork = TRUE)
    )
  }

  if (!isTRUE(quiet) && length(outputs)) {
    message(
      "R4VN meta-analysis exported:\n",
      paste(outputs, collapse = "\n")
    )
  }

  if (isTRUE(open) && length(outputs)) {
    .r4vn_meta_open_file(outputs[length(outputs)])
  }

  structure(
    list(
      data = x$tables,
      files = outputs,
      objects = list(x),
      call = match.call()
    ),
    class = "r4vn_export"
  )
}