R/fct_dt_styling.R

In teofiln/gene.editing.dash: VOR Gene Editing Dashboard

#' Map numeric vector to color gradient
#'
#' @param values the values (usually a column) to calculate a gradient for
#' @param type the type of gradient, either `gradient` for continuous or `pos/neg` for positive/negative color coding
#'
#' @description Internal functions not exported

make_color_map <- function(values, type = c("gradient", "posneg"), colors = c("steelblue", "firebrick2")) {
  gradient_colors <- c(colors[[1]], "#FFFFFF", colors[[2]])

  text_contrast_color <- function(color) {
    ifelse(mean(col2rgb(color)) > 140, "black", "white")
  }

  if (type == "gradient") {
    var_breaks <- quantile(values, probs = seq(0, 1, 0.05), na.rm = TRUE)
    colors <- scales::col_numeric(palette = gradient_colors[c(1, 3)], domain = range(var_breaks))
    bg_gradient <- c(colors(var_breaks), "firebrick2")
    font_gradient <- sapply(bg_gradient, text_contrast_color)
  }

  if (type == "posneg") {
    if (all(values >= 0) | all(values <= 0)) {
      stop(
        "Can't apply positive/negative formatting when the column does not include both positive and negative numbers."
      )
    }
    var_breaks <- c(-0.01, 0.01)
    bg_gradient <- gradient_colors
    font_gradient <- gradient_colors
  }

  return(list(var_breaks, bg_gradient, font_gradient))
}

#' Color gradient fill for DataTables
#'
#' @description Makes a DataTable HTML widget background fill for cells corresponding to the numeric value.
#' Either as a continuous scale gradient between red (negative) and green (positive) or as a
#' simple positive (green) and negative (red) fill.
#'
#' @param table a table to display
#' @param columns names of columns to prepare
#' @param colors vector of two colors for the min/max of the gradient
#' @param gradient_type either `gradient` or `posneg`
#' @param ... named arguments passed onto DT::datatable
#'
#' @return A DataTable HTML widget with gradient color coding
#' @export

dt_gradient <- function(table, columns, colors, gradient_type=c("gradient", "posneg"), ...) {

  X <- table %>% dplyr::select(dplyr::one_of(columns)) %>% unlist %>% unname %>% sort
  color_map <- make_color_map(values = X, type = gradient_type, colors = colors)

  DT::datatable(data = table, ...) %>%
    DT::formatStyle(
      columns = columns,
      backgroundColor = DT::styleInterval(cuts = color_map[[1]], values = color_map[[2]]),
      color = DT::styleInterval(cuts = color_map[[1]], values = color_map[[3]]),
      fontWeight = "900"
    )
}

buttons_for_dt <- function(visible_cols) {
  list(
    list(
      extend = "csv",
      text = "Download CSV current view",
      filename = "page",
      exportOptions = list(columns = visible_cols, modifier = list(page = "current"))
    ),
    list(
      extend = "excel",
      text = "Download Excel current view",
      filename = "page",
      exportOptions = list(columns = visible_cols, modifier = list(page = "current"))
    ),
    list(
      extend = "csv",
      text = "Download CSV all data",
      filename = "data",
      exportOptions = list(columns = visible_cols, modifier = list(page = "all"))
    ),
    list(
      extend = "excel",
      text = "Download Excel all data",
      filename = "data",
      exportOptions = list(columns = visible_cols, modifier = list(page = "all"))
    )#,
    # list(
    #   extend = "pdf",
    #   text = "Download pdf current view",
    #   filename = "data",
    #   exportOptions = list(columns = visible_cols, modifier = list(page = "current"))
    # )
  )
}