R/merge_rows.R

Defines functions adjust_heights merge_rows

Documented in adjust_heights merge_rows

#' @title adjust_heights
#' @description Adjust heights of merged rows.
#'
#' @param colnum Column to adjust row heights.
#' @param tgrob tableGrob
#' @param df Dataframe used to obtain row heights.
#'
#' @return Returns adjusted tableGrob.
adjust_heights <- function(colnum, tgrob, df) {
  group_var <- names(df)[colnum]
  borders <- df %>%
    dplyr::ungroup() %>%
    dplyr::mutate(row_ind = row_number() + 1) %>%
    dplyr::group_by_(group_var) %>%
    dplyr::summarise(top = min(row_ind),
                     bottom = max(row_ind)) %>%
    dplyr::arrange(top)

  tgrob$layout[tgrob$layout$t != 1 &
                  tgrob$layout$l == colnum, 't'] <- borders$top
  tgrob$layout[tgrob$layout$b != 1 &
                  tgrob$layout$l == colnum, 'b'] <- borders$bottom

  return(tgrob)
}

#' @title merge_rows
#' @description A function to merge equal rows for tableGrob formatting.
#' Assumes n columns that need formatting are first n columns of dataframe.
#'
#' @param df Dataframe to be formatted
#' @param n Number of columns that need merging. Defaults to 1.
#' @param flex Boolean indicating if table is for rmarkdown flexdashboard.
#' Defaults to FALSE
#'
#' @return Returns formatted tableGrob.
#' @export
merge_rows <- function(df, n = 1, flex = FALSE) {
  cex <- ifelse(flex, .5, 1)
  mytheme <- ttheme_default(
    core = list(fg_params = list(cex = cex)),
    colhead = list(fg_params = list(cex = cex)),
    rowhead = list(fg_params = list(cex = cex))
  )

  cols <- purrr::map(seq(n), ~.x)
  cols[[n+1]] <- (n+1):ncol(df)

  cols %<>%
    purrr::map(~tableGrob(unique(df[.x]),
                          row = NULL,
                          theme = mytheme))

  halign <- do.call(gridExtra::combine, c(cols, along = 1))

  for(i in seq(n)) {
    halign <- adjust_heights(colnum = i, tgrob = halign, df = df)
  }

  return(halign)
}
kimjam/qrcutils documentation built on May 20, 2019, 10:21 p.m.