R/rule_fill_gradient.R

In condformat: Conditional Formatting in Data Frames

#' Fill column with sequential colour gradient
#'
#' Fills the background color of a column using a gradient based on
#' the values given by an expression
#'
#' @family rule
#'
#' @param x A condformat object, typically created with [condformat()]
#' @param columns A character vector with column names to be coloured. Optionally
#'                [tidyselect::language()] can be used.
#' @param expression an expression to be evaluated with the data.
#'                   It should evaluate to a numeric vector,
#'                   that will be used to determine the colour gradient level.
#'                   When `columns` selects more than one column, the expression is
#'                   evaluated once per column, with the `.col` pronoun bound to that
#'                   column's own values (and `limits`, if not given, computed from
#'                   that column alone). If omitted, it defaults to `.col`.
#' @inheritParams scales::seq_gradient_pal
#' @param limits range of limits that the gradient should cover
#' @param na.value fill color for missing values
#' @param lockcells logical value determining if no further rules should be applied to the affected cells.
#'
#' @return The condformat_tbl object, with the added formatting information
#' @examples
#' data(iris)
#' cf <- condformat(iris[c(1:5, 70:75, 120:125), ]) |>
#'   rule_fill_gradient(Sepal.Length) |>
#'   rule_fill_gradient(Species, expression=Sepal.Length - Sepal.Width)
#' \dontrun{
#' print(cf)
#' }
#'
#' cf <- condformat(iris[c(1:5, 70:75, 120:125), ]) |>
#'   rule_fill_gradient("Petal.Length") |>
#'   rule_fill_gradient(starts_with("Sepal"), expression=Sepal.Length - Sepal.Width)
#' \dontrun{
#' print(cf)
#' }
#'
#' @export
rule_fill_gradient <- function(x, columns, expression,
                               low = "#132B43", high = "#56B1F7",
                               space = "Lab",
                               na.value = "#7F7F7F",
                               limits = NA,
                               lockcells = FALSE) {
  if (!inherits(x, "condformat_tbl")) {
    x <- condformat(x)
  }
  columnsquo <- rlang::enquo(columns)
  expr <- rlang::enquo(expression)
  rule <- structure(list(columns = columnsquo,
                         expression = expr,
                         low = force(low),
                         high = force(high),
                         na.value = force(na.value),
                         limits = force(limits),
                         lockcells = force(lockcells)),
                    class = c("condformat_rule", "rule_fill_gradient"))
  x <- add_rule_to_condformat(x, rule)
  return(x)
}

#' @importFrom scales rescale
rule_to_cf_field.rule_fill_gradient <- function(rule, xfiltered, xview, ...) {
  columns <- tidyselect::eval_select(expr = rule[["columns"]], data = xview)
  if (length(columns) == 0) {
    return(NULL)
  }
  if (rlang::quo_is_missing(rule[["expression"]])) {
    rule[["expression"]] <- rlang::sym(".col")
  }
  values_per_column <- eval_expression_per_column(rule[["expression"]], xfiltered, columns)

  col_scale <- scales::seq_gradient_pal(low = rule[["low"]], high = rule[["high"]])

  colours_for_values_mat <- matrix(NA,
                                   nrow = nrow(xview), ncol = ncol(xview),
                                   byrow = FALSE)
  colnames(colours_for_values_mat) <- colnames(xview)
  for (col_name in names(columns)) {
    values_determining_color <- values_per_column[[col_name]]
    if (identical(rule[["limits"]], NA)) {
      limits <- range(values_determining_color, na.rm = TRUE)
    } else {
      limits <- rule[["limits"]]
    }
    values_rescaled <- scales::rescale(x = values_determining_color, from = limits)
    colours_for_values <- col_scale(values_rescaled)
    stopifnot(identical(length(colours_for_values), nrow(xview)))
    colours_for_values_mat[, col_name] <- colours_for_values
  }
  cf_field <- structure(list(css_key = "background-color",
                             css_values = colours_for_values_mat,
                             lock_cells = rule[["lockcells"]]),
                        class = c("cf_field_rule_fill_solid",
                                  "cf_field_css", "cf_field"))
  return(cf_field)
}