R/create_rmd_table.R

In JayAchar/hisreportr: hisreportr: Automating MSF OCA EMR reporting

#' Create table for reports
#'
#' @param x list of data.frames 
#' @param formula string defining formula for generating table
#' @param column_labels string defining names of columns in output
#' @param header_labels string defining names of columns headers
#' @param simplify remove factor levels with no data - defaults to FALSE
#' @param var_names character vector of labels for variables designated
#' in formula
#' @param include_missing include a count of missing values in output - 
#' defaults to TRUE
#' @param ... additional arguments to be passed 
#' 
#' @importFrom assertthat assert_that
#' @importFrom purrr map map_lgl map2
#' @importFrom stringr str_extract_all
#' @importFrom dplyr %>% 
#' @importFrom compareGroups compareGroups createTable export2md
#' @importFrom stats as.formula
#'
#' @return html table with two columns
#'

create_rmd_table <- function(x, 
                             formula, 
                             column_labels = NULL,
                             header_labels = c(all = "N (%)",
                                               N = "Total"),
                             simplify = FALSE,
                             var_names = NULL,
                             include_missing = TRUE,
                             ...) {
  
  .x <- NULL
  .y <- NULL
  
  # check args
  assertthat::assert_that(is.list(x) & ! is.data.frame(x),
                          is.character(formula) | is.list(formula),
                          (is.character(column_labels) | 
                             is.null(column_labels)),
                          is.null(var_names) |
                            is.character(var_names))

  
  if (length(formula) == 1) {
    # duplicate formula to length of data list
    formula <- rep(formula, length(x))
  } 
  
  # convert formulas into list  
  f <- lapply(formula, as.formula)
  
  # Extract variables from formula ----
  table_vars <- stringr::str_extract_all(formula, "\\w+")
  
  # test whether all values in required variables are NA

  if (class(formula) == "list") {
    
    var_na_lst <- purrr::map2(.x = x,
                              .y = table_vars,
                              .f = function(x, y) {
                                all(is.na(x[[y]]))
                              }) 
    
    var_na <- unlist(var_na_lst)
  
    } else {
    
    var_na <- list()
    intermediate <- logical()
    for (i in 1:length(x)) {

      for (tv in match(table_vars[[i]], names(x[[i]]))) {

        intermediate <- c(intermediate, all(is.na(x[[i]][tv])))
      }
      var_na <- c(var_na, list(intermediate))
      intermediate <- logical()
    }
    
  }
      
    # logical vector defining whether any data frame has variables missing
    var_na_lgl <- vapply(var_na, FUN = any, logical(1))
  
  # confirm that number of data frames is same as NA check
  assertthat::assert_that(length(var_na) == length(x))
  
  # stop if all data is missing
  if (sum(var_na_lgl) == length(x)) stop("All data is missing - no table can be generated")

    if(any(var_na_lgl)) {
      warning("A required variable is all NA - data sets have been removed")
      # remove data frames with fully missing variables
      x <- x[! var_na_lgl]
      f <- f[! var_na_lgl]
      if(! is.null(column_labels)) {
        column_labels <- column_labels[! var_na_lgl]
      }
    }

  # create tables into list
  t <- purrr::map2(.x = x,
                   .y = f,
                   .f = function(x = .x, y = .y) {
    compareGroups::compareGroups(formula =  y, 
                                 data = x, 
                                 simplify = simplify, 
                                 include.miss = include_missing,
                                 ...
                                 )
                   })
  
  
  # assign row names to data 
  if (is.character(var_names)) {
    for (d in 1:length(x)) {
        attr(t[[d]], "names") <- var_names
    }
  }
    
  tl <- purrr::map(t, .f = ~compareGroups::createTable(x = .x, digits = 1,
                                 show.p.overall = FALSE))
  
  # reduce list of output tables into single table
  m <- do.call(cbind, tl)
  
  # label columns in output table
  if (! is.null(column_labels)) {
    
    assertthat::assert_that(length(column_labels) == length(x))
    attr(m, "caption") <- column_labels
    
  }
    
  
  # convert output table into html
  compareGroups::export2md(m, 
                           format = "html",
                           header.labels = header_labels,
                           nmax = FALSE,
                           caption = "",
                           position = "left")
}