R/sprinkle_gradient.R

In nutterb/pixiedust: Tables so Beautifully Fine-Tuned You Will Believe It's Magic

#' @name sprinkle_gradient
#' @title Change Color Features by Binning Numeric Values
#' 
#' @description Numeric values within a range of cells are binned and colors
#'   assigned to show gradual increases in the numeric value.
#'   
#' @param x An object of class \code{dust}
#' @param rows Either a numeric vector of rows in the tabular object to be 
#'   modified or an object of class \code{call}.  When a \code{call}, 
#'   generated by \code{quote(expression)}, the expression resolves to 
#'   a logical vector the same length as the number of rows in the table.
#'   Sprinkles are applied to where the expression resolves to \code{TRUE}.
#' @param cols Either a numeric vector of columns in the tabular object to
#'   be modified, or a character vector of column names. A mixture of 
#'   character and numeric indices is permissible.
#' @param gradient \code{character}. A subset of \code{c("bg", "font", 
#'   "font_color", "border", "left_border", "top_border", "right_border",
#'   "bottom_border")}.
#' @param gradient_colors \code{character(2)}. Gives the colors between 
#'   which to shared gradients.
#' @param gradient_cut \code{numeric}. Determines the breaks points for the 
#'   gradient shading. When \code{NULL} equally spaced quantiles are used, 
#'   the number of which are determined by \code{gradient_n}.
#' @param gradient_n \code{numeric(1)}. Determines the number of shades to use 
#'   between the colors in \code{gradient_colors} 
#' @param gradient_na \code{character(1)} A valid color that sets the color of 
#'   \code{NA} values when shading a numeric range.
#' @param part A character string denoting which part of the table to modify.
#' @param fixed \code{logical(1)} indicating if the values in \code{rows} 
#'   and \code{cols} should be read as fixed coordinate pairs.  By default, 
#'   sprinkles are applied at the intersection of \code{rows} and \code{cols}, 
#'   meaning that the arguments do not have to share the same length.  
#'   When \code{fixed = TRUE}, they must share the same length.
#' @param recycle A \code{character} one that determines how sprinkles are 
#'   managed when the sprinkle input doesn't match the length of the region
#'   to be sprinkled.  By default, recycling is turned off.  Recycling 
#'   may be performed across rows first (left to right, top to bottom), 
#'   or down columns first (top to bottom, left to right).
#' @param ... Additional arguments to pass to other methods. Currently ignored.
#' 
#' @details This sprinkle is only recognized by HTML and LaTeX.  All of the 
#'   \code{height_units} values are recognized by HTML.  For LaTeX, \code{"px"}
#'   is converted to \code{"pt"}. 
#'   
#' \code{"font"} and \code{"font_color"} both change the font color.
#' 
#' \code{"border"} is a shortcut to specify all borders.
#'   
#' @section Functional Requirements:
#' \enumerate{
#'  \item Correctly reassigns the appropriate elements of the \code{bg},
#'    \code{font_color}, \code{left_border}, \code{top_border},
#'    \code{right_border}, or \code{bottom_border} column in the table part.
#'  \item Casts an error if \code{x} is not a \code{dust} object.
#'  \item Casts an error if \code{gradient} is not a subset of 
#'    \code{c("bg", "font", "font_color", "border", "left_border",
#'            "right_border", "top_border", "bottom_border")}
#'  \item Casts an error if \code{gradient_colors} is not a \code{character(2)}
#'    value.
#'  \item Casts an error if any value of \code{gradient_colors} is not a
#'    recognized color value.
#'  \item Casts an error if \code{gradient_cut} is not \code{numeric}.
#'  \item Casts an error if \code{gradient_n} is not \code{numeric(1)}.
#'  \item Casts an error if \code{gradient_na} is not \code{character(1)}.
#'  \item Casts an error if \code{gradient_na} is not a valid color.
#'  \item Casts an error if \code{part} is not one of \code{"body"}, 
#'    \code{"head"}, \code{"foot"}, or \code{"interfoot"}
#'  \item Casts an error if \code{fixed} is not a \code{logical(1)}
#'  \item Casts an error if \code{recycle} is not one of \code{"none"},
#'    \code{"rows"}, or \code{"cols"}
#' }
#' 
#' The functional behavior of the \code{fixed} and \code{recycle} arguments 
#' is not tested for this function. It is tested and validated in the
#' tests for \code{\link{index_to_sprinkle}}.
#' 
#' @seealso \code{\link{sprinkle}}, 
#'   \code{\link{index_to_sprinkle}}
#'   
#' @export

sprinkle_gradient <- function(x, rows = NULL, cols = NULL, 
                              gradient = "bg",
                              gradient_colors = getOption("pixie_gradient_pal", NULL),
                              gradient_cut = NULL,
                              gradient_n = 10,
                              gradient_na = "grey",
                              part = c("body", "head", "foot", "interfoot", "table"),
                              fixed = FALSE, 
                              recycle = c("none", "rows", "cols", "columns"),
                            ...)
{
  UseMethod("sprinkle_gradient")
}

#' @rdname sprinkle_gradient
#' @export

sprinkle_gradient.default <- function(x, rows = NULL, cols = NULL, 
                                   gradient = "bg",
                                   gradient_colors = getOption("pixie_gradient_pal", 
                                                               c("#132B43", "#56B1F7")),
                                   gradient_cut = NULL,
                                   gradient_n = 10,
                                   gradient_na = "grey",
                                   part = c("body", "head", "foot", "interfoot", "table"),
                                   fixed = FALSE, 
                                   recycle = c("none", "rows", "cols", "columns"),
                                   ...)
{
  coll <- checkmate::makeAssertCollection()
  
  checkmate::assert_class(x = x,
                          classes = "dust",
                          add = coll)
  
  sprinkle_gradient_index_assert(gradient = gradient, 
                                 gradient_colors = gradient_colors, 
                                 gradient_cut = gradient_cut,
                                 gradient_n = gradient_n,
                                 gradient_na = gradient_na,
                                 coll = coll)
  
  indices <- index_to_sprinkle(x = x, 
                               rows = rows, 
                               cols = cols, 
                               fixed = fixed,
                               part = part,
                               recycle = recycle,
                               coll = coll)
  
  checkmate::reportAssertions(coll)
  
  sprinkle_gradient_index(x = x, 
                          indices = indices, 
                          gradient = gradient, 
                          gradient_colors = gradient_colors, 
                          gradient_cut = gradient_cut, 
                          gradient_n = gradient_n, 
                          gradient_na = gradient_na, 
                          part = part, 
                          ...)
}

#' @rdname sprinkle_gradient
#' @export

sprinkle_gradient.dust_list <- function(x, rows = NULL, cols = NULL, 
                                        gradient = "bg",
                                        gradient_colors = getOption("pixie_gradient_pal", 
                                                                    c("#132B43", "#56B1F7")),
                                        gradient_cut = NULL,
                                        gradient_n = 10,
                                        gradient_na = "grey",
                                        part = c("body", "head", "foot", "interfoot", "table"),
                                      fixed = FALSE, 
                                      recycle = c("none", "rows", "cols", "columns"),
                                      ...)
{
  structure(
    lapply(X = x,
           FUN = sprinkle_gradient.default,
           rows = rows,
           cols = cols,
           gradient = gradient,
           gradient_colors = gradient_colors,
           gradient_cut = gradient_cut,
           gradient_n = gradient_n,
           gradient_na = gradient_na,
           part = part,
           fixed = fixed,
           recycle = recycle,
           ...),
    class = "dust_list"
  )
}

# Unexported Utility ------------------------------------------------

# These functions are to be used inside of the general `sprinkle` call
# When used inside `sprinkle`, the indices are already determined, 
# the only the `height` and `height_units` arguments needs to be validated. 
# The assert function is kept separate so it may be called earlier
# without attempting to perform the assignment.

sprinkle_gradient_index_assert <- function(gradient = "bg",
                                           gradient_colors = getOption("pixie_gradient_pal", NULL),
                                           gradient_cut = NULL,
                                           gradient_n = 10,
                                           gradient_na = "grey",
                                           coll)
{
  checkmate::assert_subset(x = gradient,
                           choices = c("bg", "font", "font_color",
                                       "border", "left_border", 
                                       "top_border", "right_border",
                                       "bottom_border"),
                           add = coll)
  
  if (!is.null(gradient_colors))
  {
    checkmate::assert_character(x = gradient_colors,
                                len = 2,
                                add = coll)
    
    valid_color <-  is_valid_color(gradient_colors)  
    if (!all(valid_color))
    {
      coll$push(sprintf("The following are not valid colors: %s",
                        paste0(gradient_colors[!valid_color], 
                               collapse = ", ")))
    }
  }
  
  if (!is.null(gradient_cut))
  {
    checkmate::assert_numeric(x = gradient_cut,
                              add = coll)
  }
  
  if (!is.null(gradient_n))
  {
    checkmate::assert_numeric(x = gradient_n,
                              len = 1,
                              add = coll)
  }
  
  if (!is.null(gradient_na))
  {
    checkmate::assert_character(x = gradient_na,
                              len = 1,
                              add = coll)
    
    if (any(!is_valid_color(gradient_na)))
    {
      coll$push("`gradient_na` must be a valid color")
    }
  }
}

sprinkle_gradient_index <- function(x, indices, 
                                    gradient = "bg",
                                    gradient_colors = getOption("pixie_gradient_pal", NULL),
                                    gradient_cut = NULL,
                                    gradient_n = 10,
                                    gradient_na = "grey", 
                                    part, ...)
{
  part <- part[1]
  
  if ("border" %in% gradient)
  {
    gradient <- c(sprintf("%s_border", 
                          c("top", "left", "right", "bottom")),
                  gradient)
    gradient <- unique(gradient[!gradient %in% "border"])
  }
  
  if ("font" %in% gradient)
  {
    gradient <- c("font_color", gradient)
    gradient <- unique(gradient[!gradient %in% "font"])
  }
  
  ux <- unique(x[[part]][["value"]][indices])
  
  if (is.null(gradient_colors)) 
  {
    gradient_colors <- getOption("pixie_gradient_pal", 
                                 c("#132B43", "#56B1F7"))
  }
  
  args <- list(...)
  
  border_thickness <- 
    if ("border_thickness" %in% names(args)) args[["border_thickness"]] else 1
  
  border_units <- 
    if ("border_units" %in% names(args)) args[["border_units"]] else "px"
  
  border_style <- 
    if ("border_style" %in% names(args)) args[["border_style"]] else "solid"
  
  gradient["font" %in% gradient] <- "font_color"
  
  if (is.null(gradient_n)) gradient_n <- 10
  
  if (is.null(gradient_na))
  {
    gradient_na <- "grey"
  }
  
  gradient_colors <- 
    scales::gradient_n_pal(gradient_colors)(seq(0, 1, length.out = gradient_n))
  
  if (is.null(border_thickness)) border_thickness <- 1
  if (is.null(border_units)) border_units <- "px"
  if (is.null(border_style)) border_style <- "solid"
  
  gradient_split <- 
    if (is.null(gradient_cut))
    {
      cut(as.numeric(x[[part]][["value"]][indices]),
          breaks = stats::quantile(as.numeric(x[[part]][["value"]][indices]), 
                                   probs = seq(0, 1, length.out = gradient_n),
                                   na.rm = TRUE),
          include.lowest = TRUE)
    }
  else
  {
    cut(as.numeric(x[[part]][["value"]][indices]),
        breaks = gradient_cut,
        include.lowest = TRUE,
        na.rm = TRUE)
  }
  
  na_val <- which(is.na(gradient_split))
  
  for (i in seq_along(gradient))
  {
    if (grepl("border", gradient[i]))
    {
      x[[part]][[gradient[i]]][indices] <- 
        sprintf("%s%s %s %s",
                border_thickness,
                border_units,
                border_style,
                gradient_colors[as.numeric(gradient_split)])
      
      x[[part]][[gradient[i]]][indices][na_val] <- 
        sprintf("%s%s %s %s",
                border_thickness,
                border_units,
                border_style,
                gradient_na)
    }
    else 
    {
      x[[part]][[gradient[i]]][indices] <- 
        gradient_colors[as.numeric(gradient_split)]
      
      x[[part]][[gradient[i]]][indices][na_val] <- 
        gradient_na
    }
  }
  
  x
}