R/make_row_heat_tgrob.R

In kimjam/qrcutils: Contains utility functions for data pipeline project.

#' @title get_row_bg
#' @description Function to get cell background colors based on row-wise z score
#'
#' @param df Dataframe to assign colors to
#'
#' @return Returns matrix of cell background colors.
get_row_bg <- function(df) {
  mask <- vapply(df, is.numeric, logical(1))
  cols <- t(scale(t(as.matrix(df[mask])))) %>%
    apply(.,
          1,
          function(x)
            dplyr::case_when(
              x < -2 ~ '#198c19',
              dplyr::between(x, -2, -1.5) ~ '#4ca64c',
              dplyr::between(x, -1.5, -1) ~ '#7fbf7f',
              dplyr::between(x, -1, -.5) ~ '#b2d8b2',
              dplyr::between(x, -.5, 0) ~ '#e5f2e5',
              dplyr::between(x, 0, .5) ~ '#ffe5e5',
              dplyr::between(x, .5, 1) ~ '#ffb2b2',
              dplyr::between(x, 1, 1.5) ~ '#ff7f7f',
              dplyr::between(x, 1.5, 2) ~ '#ff4c4c',
              x > 2 ~ '#ff1919',
              TRUE ~ 'black'
            )) %>%
    t() %>%
    cbind(matrix(rep('grey', sum(!mask) * nrow(.)), ncol = sum(!mask)), .)

  return(cols)
}

#' @title make_row_heat_tgrob
#' @description Function to turn dataframe in row-wise heat table grob.
#'
#' @param df Dataframe to make table from.
#' @param flex Boolean indicating if table is for rmarkdown flexdashboard.
#' Defaults to FALSE
#'
#' @return Returns tableGrob
#' @export
make_row_heat_tgrob <- function(df, flex = FALSE) {
  cex <- ifelse(flex, .5, 1)
  return(df %<>%
           tableGrob(
             row = NULL,
             theme = ttheme_default(
               core = list(fg_params = list(cex = cex),
                           bg_params = list(fill = get_row_bg(.))),
               colhead = list(fg_params = list(cex = cex)),
               rowhead = list(fg_params = list(cex = cex)))
           ))
}