R/write_table.R

In adayim/cttab: Tables of Descriptive Statistics in word

#' Write data.frame or matrix to word
#'
#' @param x data.frame or matrix
#' @param rowlabelhead A heading for the first column of the table, which contains the row labels.
#' @param footnote A character string to be added as a footnote to the table.
#' Can also be a vector which results in multiple lines of footnotes.
#' The default \code{NULL} causes the footnote to be omitted.
#' @param caption A character string to be added as a caption to the table.
#' The default \code{NULL} causes the caption to be omitted.
#' @param ... Kept for later used.
#'
#' @return A flextable object.
#' @importFrom officer fp_border
#' @import flextable
#' @export
#'
#' @examples
#' \dontrun{
#' write_table(head(mtcars))
#' }
write_table <- function(x,
                        rowlabelhead = "",
                        caption = NULL,
                        footnote = NULL,
                        ...) {
  if (!any(c("matrix", "data.frame") %in% class(x)))
    stop("Only data.frame and matrix supported!")
  
  if (is.null(rowlabelhead))
    rowlabelhead <- ""
  
  if (!is.null(caption)) {
    caption <- paste(caption, collapse = "\n")
  } else {
    caption <- ""
  }
  
  if (inherits(x, "matrix")) {
    tab <- data.frame(Var = row.names(x),
                      x,
                      row.names = NULL)
    thead <- colnames(x)
    thead <- c(rowlabelhead, thead)
    names(thead) <- colnames(tab)
  }else{
    with_varlab <- sapply(x, has.label)
    for (i in names(x)[!with_varlab]) {
      var_lab(x[[i]]) <- i
    }
    thead <- sapply(x, var_lab)
    
    has_label <- sapply(x, has.labels)
    for (i in names(x)[has_label]) {
      x[[i]] <- to_factor(x[[i]])
    }
    tab <- x
  }
  
  ft <- flextable::qflextable(tab)
  
  typology <- data.frame(
    col_keys = colnames(tab),
    head1 = thead,
    stringsAsFactors = FALSE)
  
  ft <- flextable::set_header_df(ft, mapping = typology,
                                 key = "col_keys")
  ft <- flextable::merge_h(ft, part = "header")
  
  # Make higher level to bold
  if (inherits(x, "tab1")) {
    pos <- attr(x, "position")
    # Set variable bold and merge
    mer_hori <- which(pos %in% c(0, 1))
    
    # Avoid merge observation
    j2 <- ifelse(ncol(tab) == 2, 2, ncol(tab) - 1)
    obs_pos <- which(tab[,1] == "Observation")
    ft <- flextable::merge_h_range(ft, i = setdiff(mer_hori, obs_pos),
                                   j1 = 1, j2 = j2)
    ft <- flextable::bold(ft,
                          i = mer_hori,
                          bold = TRUE,
                          part = "body")
    
    # Define col split color
    ft <- flextable::bg(ft, i = which(pos == 0), bg = "#d9d9d9")
  }
  
  # Alignment
  ft <- flextable::align(ft, align = "center", part = "all")
  ft <- flextable::align(ft,
                         j = 1,
                         align = "left",
                         part = "all")
  
  ft <- flextable::set_caption(ft, caption = caption)
  
  if (!is.null(footnote)) {
    footnote <- paste(footnote, collapse = "\n")
    ft <- flextable::add_footer_lines(ft, values = footnote)
  }
  
  theme_stats(ft)

}


#' @export
#' @title Apply stats theme
#' @description Apply theme booktabs to a flextable
#' @param x a flextable object
#'
theme_stats <- function(x) {
  if (!inherits(x, "flextable")) {
    stop("theme_booktabs supports only flextable objects.")
  }
  
  big_border <- officer::fp_border(width = 2, color = "black")
  std_border <- stats::update(big_border, width = 1)
  
  nrow_part <- function(x, part) {
    if (is.null(x[[part]]))
      0
    else if (is.null(x[[part]]$dataset))
      0
    else
      nrow(x[[part]]$dataset)
  }
  
  h_nrow <- nrow_part(x, "header")
  f_nrow <- nrow_part(x, "footer")
  b_nrow <- nrow_part(x, "body")
  
  if (h_nrow > 0) {
    x <- flextable::hline_top(x, border = big_border, part = "header")
    x <- flextable::hline_bottom(x, border = big_border, part = "header")
    x <- flextable::bold(x, bold = TRUE, part = "header")
  }
  
  if (b_nrow > 0) {
    x <- flextable::hline_bottom(x, border = big_border, part = "body")
  }
  
  # change font 
  x <- flextable::font(x,fontname = "Times",part ="all")
  x <- flextable::fontsize(x,size = 10,part ="all")
  
  # change row height
  x <- flextable::height_all(x, height = 0.1, part = "body")
  x <- flextable::height_all(x, height = 0.3, part = "header")
  x <- flextable::height_all(x, height = 0.1, part = "footer")
  
  x <- flextable::fix_border_issues(x)
  flextable::padding(x, padding = 0, part = "all")
}