R/create_word_xml.R

In shug0131/cctu: In-House Functions for Report Writing at Cambridge Clinical Trials Unit

#' Produces the final xml file
#'
#' @param report_title text string used to label the report title page
#' @param author text string naming the author
#' @param meta_table a data frame  that contains meta information on tables
#' (title, population, number). Defaults is get_meta_table()
#' @param datestamp text used to give the date-time stamp, defaults to the
#' system date/time at the time of running the function
#' @param filename text string giving the filename/path to output the word
#' document to
#' @inheritParams write_ggplot
#' @inheritParams attach_pop
#' @param table_path text string giving the filepath to the tables folder.
#' This is used to directly open table files and copy the content.
#' @param figure_path text string giving the filepath to the figures folder.
#' This is used to create a reference within the  word document. Hence it needs
#'  to be a relative (to the output report) path "../Figures". Likely to lead
#'   to empty figures in the report if it is changed.
#' @param popn_labels alternative text string giving labels used for the
#' population - might want to include the population size... They must match
#'  correctly to unique(meta_table$population), excluding rows with a blank,
#'  or no, population given
#' @param  figure_format the format to look for figure files when building the
#'  report ("png", "jpeg","ps")
#' @param xslt_file a text file containing the xslt document. Default is
#' system.file("extdata", "xml_to_word.xslt", package="cctu").
#' @param keep_xml a boolean if the compiled XML should be kept, used for
#'  debugging purpose.
#' @export
#' @importFrom magrittr %>% %<>%
#'
#' @return This function is run for its side-effects: creates an xml document
#'  that glues together all the outputs and meta data as per the meta-table
#'   argument; a transformation fo this as per the xslt file, the default can
#'   be opened as a word document.
#'
#' @details  suggest that \code{\link{file.path}} is used to create non default
#'  file paths, to cope with OS vaguaries.




create_word_xml <- function(
    report_title,
    author,
    meta_table = get_meta_table(),
    datestamp = format(Sys.time(), format = "%H:%M %d %b %Y"),
    filename = file.path(
      getOption("cctu_output", default = "Output"),
      "Reports", "Report.doc"
    ),
    table_path = file.path(
      getOption("cctu_output", default = "Output"),
      "Core"
    ),
    figure_format = c("png", "jpeg", "ps"),
    figure_path = file.path(
      getOption("cctu_output", default = "Output"),
      "Figures"
    ),
    popn_labels = NULL,
    verbose = options()$verbose,
    xslt_file = system.file("extdata", "to_word.xslt", package = "cctu"),
    keep_xml = FALSE) {
  warning("This function is no longer being maintained. Use write_docx() instead",
    immediate. = TRUE
  )

  table_path <- normalizePath(table_path) # %>% final_slash
  long_filename <- filename %>% normalizePath(., mustWork = FALSE)

  if (keep_xml) {
    filename <- paste0(filename, ".xml")
  } else {
    filename <- tempfile(fileext = ".xml")
  }

  meta_table <- clean_meta_table(meta_table)

  if (!is.null(popn_labels)) {
    # preserve any non-population based tables.
    index <- match(meta_table$population, unique(c("", meta_table$population)))
    meta_table$population <- c("", popn_labels)[index]
  }

  file.copy(system.file("extdata", "header.txt", package = "cctu"),
    filename,
    overwrite = TRUE
  )

  filename_text <- filename
  # create a connection to use in cat and
  filename <- file(description = filename, open = "a")


  cat(
    "\n <Report>
  <study>", remove_xml_specials(report_title), "</study>
  <author>", remove_xml_specials(author), "</author><datestamp>",
    datestamp, "</datestamp>",
    file = filename, append = TRUE
  )

  headers <- with(
    meta_table,
    paste0(
      "<heading><section>", section %>% as.character() %>% remove_xml_specials(),
      "</section><title>", title %>% as.character() %>% remove_xml_specials(),
      "</title><population>",
      ifelse(is.na(population), "", remove_xml_specials(as.character(population))),
      "</population><subtitle>",
      ifelse(is.na(subtitle), "", remove_xml_specials(as.character(subtitle))),
      "</subtitle><number>", number,
      "</number><fontsize>",
      ifelse(is.na(fontsize), "", remove_xml_specials(as.character(fontsize))),
      "</fontsize><orientation>", orientation,
      "</orientation></heading>"
    )
  )

  # Format footers
  footers <- apply(meta_table, 1, function(x) {
    r <- c(
      ifelse(is.na(x["footnote1"]), "",
        remove_xml_specials(as.character(x["footnote1"]))
      ),
      ifelse(is.na(x["footnote2"]), "",
        remove_xml_specials(as.character(x["footnote2"]))
      )
    )
    r <- r[r != ""]
    paste(r, collapse = "\n")
  })
  footers <- paste("<footnote>", footers, "</footnote>")

  program <- paste("<Program>", meta_table$program, "</Program>")
  figure_format <- match.arg(figure_format)

  for (i in seq_along(headers)) {
    cat("\n", file = filename, append = TRUE)

    if (meta_table[i, "item"] == "table") {
      cat("\n <MetaTable> \n", headers[i], file = filename, append = TRUE)
      table_text <- readLines(
        con = file.path(table_path, paste0(
          "table_",
          meta_table[i, "number"], ".xml"
        ))
      )
      writeLines(table_text, con = filename)
      cat(footers[i], program[i], "\n </MetaTable> \n",
        file = filename,
        append = TRUE
      )
    }
    if (meta_table[i, "item"] == "figure") {
      fig_path <- file.path(
        figure_path,
        paste0("fig_", meta_table[i, "number"], ".", figure_format)
      )
      fig_path <- normalizePath(fig_path)

      # Get image dimension and scale the figure to fit the page
      r <- png::readPNG(fig_path, native = TRUE, info = TRUE)
      img_wh <- attr(r, "info")$dim
      page_size <- c(595, 842)

      if (meta_table[i, "orientation"] == "landscape") {
        page_size <- rev(page_size)
      }

      # If the image is larger than page size
      if (page_size[1] < img_wh[1] || page_size[2] < img_wh[2]) {
        img_wh <- img_wh / max(img_wh / page_size + 0.5)
      }

      cat("\n <MetaFigure> \n", headers[i], file = filename, append = TRUE)
      cat(sprintf("<src>%s</src>", basename(fig_path)),
        file = filename, append = TRUE
      )
      cat(
        sprintf(
          "<figBase64>%s</figBase64>",
          base64enc::base64encode(fig_path)
        ),
        file = filename, append = TRUE
      )
      cat(
        sprintf(
          "<figuresize>width:%.2fpx;height:%.2fpx</figuresize>",
          img_wh[1], img_wh[2]
        ),
        file = filename, append = TRUE
      )
      cat(footers[i], program[i], "\n </MetaFigure> \n",
        file = filename,
        append = TRUE
      )
    }

    if (meta_table[i, "item"] == "text") {
      cat("\n <MetaText> \n", headers[i], file = filename, append = TRUE)
      table_text <- readLines(
        con = file.path(table_path, paste0(
          "text_",
          meta_table[i, "number"], ".xml"
        ))
      )
      writeLines(table_text, con = filename)
      cat(footers[i], program[i], "\n </MetaText> \n",
        file = filename,
        append = TRUE
      )
    }
  }

  writeLines("\n </Report>", con = filename)
  close(con = filename)
  # now apply the transform explicitly.
  doc <- xml2::read_xml(filename_text)
  transform <- xml2::read_xml(xslt_file)
  output <- xslt::xml_xslt(doc, transform)
  xml2::write_xml(output, file = long_filename)

  if (verbose) {
    message(long_filename, " created.")
  }
}

#' @keywords internal
#'
#'
final_slash <- function(x) {
  paste0(gsub("\\\\$", "", x), "\\")
}