R/top_headers.R

In moj-analytical-services/xltabr: Automatically Write Beautifully Formatted Cross Tabulations/Contingency Tables to Excel

#' Create all the required properties for the top headers on the tab object
#'
#' @param tab The core tab object
top_headers_initialise <- function(tab) {

  tab$top_headers <- list()

  # The top headers are a list of character vectors, each one representing a row
  # This allows the user to provide more than one level of top headers
  tab$top_headers$top_headers_list <- NULL
  tab$top_headers$top_headers_row_style_names <- NULL
  tab$top_headers$top_headers_col_style_names <- NULL
  tab
}

#' Add top headers to the tab.  The top headers are provided as a character vector.
#' If you need more than one row, provide a list of character vectors.
#' Top headers are automatically assigned the style_text 'top_header_1', but
#' you may provide style overrides using column_style_names and row_style_names
#'
#' @param tab The core tab object
#' @param top_headers For a single top_header row, a character vector.  For multiple top_header rows, a list of character vectors.
#' @param row_style_names A character vector, with an element for each row of the top header.  Each element is a style_name (i.e. a key in the style catalogue)
#' @param col_style_names A character vector, with and element for each column of the top header.  Each element is a style name. Col styles in inherit from row_styles.
#'
#' @export
#' @examples
#' crosstab <- read.csv(system.file("extdata", "example_crosstab.csv", package="xltabr"))
#' tab <- initialise()
#'
#' top_headers_row_1 <- c("", "", "Car type", "Car type", "Car type")
#' top_headers_row_2 <- c("Drive", "Age", "Sedan", "Sport", "Supermini")
#' top_headers <- list(top_headers_row_1, top_headers_row_2)
#'
#' tab <- add_top_headers(tab, top_headers)
add_top_headers <- function(tab, top_headers, col_style_names="", row_style_names="body|top_header_1") {

  # Check types and assign the data to top_headers_list.  Each row is an element in the list
  if (typeof(top_headers) == "character") {
    top_headers <- list(top_headers)
  }
  tab$top_headers$top_headers_list <- top_headers


  # Use recycling to make the col_style_names and row_style_names match the number of entries in top headers
  m <-rbind(top_headers[[1]],col_style_names)
  col_style_names <- m[2,]

  m <-rbind(seq_along(top_headers), row_style_names)
  row_style_names <- m[2,]

  tab$top_headers$top_headers_row_style_names <- row_style_names
  tab$top_headers$top_headers_col_style_names <- col_style_names

  tab
}


#' Compute the columns of the workbook which are occupied by the top headers
#'
#' @param tab The core tab object
top_headers_get_wb_cols <- function(tab) {

  if (is.null(tab$top_headers$top_headers_list)) {
    return(NULL)
  }

  tlc <- tab$extent$topleft_col

  header_cols_vec <- tab$top_headers$top_headers_list[[1]]

  wb_cols <- seq_along(header_cols_vec) + tlc - 1

  wb_cols
}

#' Compute the rows of the workbook which are occupied by the top headers
#'
#' @param tab The core tab object
top_headers_get_wb_rows <- function(tab) {

  if (is.null(tab$top_headers$top_headers_list)) {
    return(NULL)
  }

  offset <- title_get_bottom_wb_row(tab)
  seq_along(tab$top_headers$top_headers_list) + offset


}

#' Compute the bottom (lowest) row of the workbook occupied by the top headers
#' If the top headers do not exist, returns the last row of the previous element (the titles)
#'
#' @param tab The core tab object
top_headers_get_bottom_wb_row <- function(tab) {

  title_bottom <- title_get_bottom_wb_row(tab)
  th_rows <- top_headers_get_wb_rows(tab)

  max(c(title_bottom, th_rows))

}

#' Compute the rightmost column of the workbook which is occupied by the top headers
#'
#' @param tab The core tab object
top_headers_get_rightmost_wb_col <- function(tab) {

  th_cols <- top_headers_get_wb_cols(tab)

  if (length(th_cols) == 0) {
    return(tab$extent$topleft_col - 1)
  } else {
    return(max(th_cols))
  }
}



#' Create table with columns |row|col|style name| containing the styles names for each cell of the top headers
#'
#' @param tab The core tab object
top_headers_get_cell_styles_table <- function(tab) {

  rows <- top_headers_get_wb_rows(tab)

  if (length(rows) == 0) {
    df <- data.frame("row" = integer(0), "col" = integer(0), "style_name" = character(0), stringsAsFactors = FALSE)
    return(df)
  }

  rs <- tab$top_headers$top_headers_row_style_names
  df1 <- data.frame(rs, row = rows, stringsAsFactors = FALSE)

  cs <- tab$top_headers$top_headers_col_style_names
  cols <-  top_headers_get_wb_cols(tab)

  df2 <- data.frame(cs, col = cols, stringsAsFactors = FALSE)
  df <- merge(df1, df2)

  df$style_name <- paste(df$rs, df$cs, sep="|")
  df$style_name <- remove_leading_trailing_pipe(df$style_name)

  df[, c("row", "col", "style_name")]
}

#' Write all the top header data to the workbook (but do not write style information)
#'
#' @param tab The core tab object
top_headers_write_rows <- function(tab) {

  if (is.null(tab$top_headers$top_headers_list)) {
    return(tab)
  }

  ws_name <- tab$misc$ws_name

  #TODO:check there's something to write before writing

  #The transpose operation is safe because we want everything to be character
  data <- t(data.frame(tab$top_headers$top_headers_list))

  col <- min(top_headers_get_wb_cols(tab))
  row <- min(top_headers_get_wb_rows(tab))

  openxlsx::writeData(tab$wb, ws_name, data, startRow = row, startCol = col, colNames = FALSE)

  tab
}