R/sprinkle_bg_pattern.R

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

#' @name sprinkle_bg_pattern
#' @title Row and Column Background Striping
#' 
#' @description Provides background color striping based on row or column.
#'   Striping may be done with any number of colors. The most common use of 
#'   striping is to provide row discrimination in tables.
#'   
#' @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 bg_pattern A character vector giving the colors to be iterated in 
#'   the pattern.  
#' @param bg_pattern_by A subset of \code{c("rows", "cols")}, with partial
#'   matching accepted.  Only the first value is used, and determines the 
#'   direction of the pattern.
#' @param part A character string denoting which part of the table to modify.
#' @param ... Additional arguments to pass to other methods. Currently ignored.
#' 
#' @section Functional Requirements:
#' \enumerate{
#'   \item Correctly reassigns the appropriate elements \code{bg} column
#'    in the table part.
#'  \item Casts an error if \code{x} is not a \code{dust} object.
#'  \item Casts an error if \code{bg_pattern} is not a character vector.
#'  \item Casts an error if any element in \code{bg_pattern} is not a valid
#'    color name.
#'  \item Casts an error if \code{bg_pattern_by} is not a subset of 
#'    \code{c("rows", "columns")} (with partial matching).
#'  \item Casts an error if \code{part} is not one of \code{"body"}, 
#'    \code{"head"}, \code{"foot"}, or \code{"interfoot"}
#' }
#' 
#' This is a rare sprinkle that doesn't use the \code{fixed} and \code{recycle}
#' arguments.  They are assumed to be \code{FALSE} and \code{"none"}, 
#' respectively, in order to pass through \code{index_to_sprinkle}. 
#' 
#' @seealso \code{\link{sprinkle_bg}}, \code{\link{sprinkle}}, 
#'   \code{\link{index_to_sprinkle}}
#' 
#' @export

sprinkle_bg_pattern <- function(x, rows = NULL, cols = NULL, 
                                bg_pattern = c("transparent", "#DCDCDC"),
                                bg_pattern_by = c("rows", "cols"),
                                ..., part = c("body", "head", "foot", "interoot", "table"))
{
  UseMethod("sprinkle_bg_pattern")
}

#' @rdname sprinkle_bg_pattern
#' @export

sprinkle_bg_pattern.default <- function(x, rows = NULL, cols = NULL, 
                                     bg_pattern = c("transparent", "#DCDCDC"),
                                     bg_pattern_by = c("rows", "cols"),
                                     ...,
                                     part = c("body", "head", "foot", "interfoot", "table"))
{
  coll <- checkmate::makeAssertCollection()
  
  checkmate::assert_class(x = x,
                          classes = "dust",
                          add = coll)
  
  bg_pattern_by <- 
    sprinkle_bg_pattern_index_assert(bg_pattern = bg_pattern,
                                     bg_pattern_by = bg_pattern_by, 
                                     coll = coll)
  
  indices <- index_to_sprinkle(x = x, 
                               rows = rows, 
                               cols = cols, 
                               fixed = FALSE,
                               part = part,
                               recycle = "none",
                               coll = coll)
  
  checkmate::reportAssertions(coll)
  
  part <- part[1]
  
  sprinkle_bg_pattern_index(x = x, 
                            indices = indices, 
                            bg_pattern = bg_pattern,
                            bg_pattern_by = bg_pattern_by, 
                            part = part)
}

#' @rdname sprinkle_bg_pattern
#' @export

sprinkle_bg_pattern.dust_list <- function(x, rows = NULL, cols = NULL, 
                                          bg_pattern = c("transparent", "#DCDCDC"),
                                          bg_pattern_by = c("rows", "cols"),
                                          ...,
                                          part = c("body", "head", "foot", "interfoot", "table"))
{
  structure(
    lapply(X = x,
           FUN = sprinkle_na_string.default,
           rows = rows,
           cols = cols,
           bg_pattern = bg_pattern,
           bg_pattern_by = bg_pattern_by,
           part = part,
           fixed = FALSE,
           recycle = "none",
           ...),
    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 `na_string` argument needs to be validated. 
# The assert function is kept separate so it may be called earlier
# without attempting to perform the assignment.

sprinkle_bg_pattern_index_assert <- function(bg_pattern = c("transparent", "#DCDCDC"),
                                             bg_pattern_by = c("rows", "cols"),
                                             coll)
{
  checkmate::assert_character(x = bg_pattern,
                              add = coll,
                              .var.name = "bg_pattern")
  
  if (!all(is_valid_color(bg_pattern)))
  {
    coll$push(sprintf("The following elements in `bg_pattern` are not valid colors: %s",
                      paste0(bg_pattern[!is_valid_color(bg_pattern)],
                             collapse = ", ")))
  }
  
  bg_pattern_by <- 
    checkmate::matchArg(x = bg_pattern_by,
                        choices = c("rows", "cols"),
                        add = coll,
                        .var.name = "bg_pattern_by")
  
  bg_pattern_by
}

sprinkle_bg_pattern_index <- function(x, indices, 
                                      bg_pattern = c("transparent", "#DCDCDC"),
                                      bg_pattern_by = c("rows"), 
                                      part)
{
  if (bg_pattern_by == "rows")
  {
    pattern <- data.frame(row = sort(unique(x[[part]][["row"]][indices])))
    pattern[["bg"]] <- rep(bg_pattern, 
                           length.out = nrow(pattern))
    
    pattern <- merge(pattern, 
                     x[[part]][indices, c("row", "col")], 
                     by = c("row"), 
                     sort = FALSE, 
                     all.x = TRUE)

    pattern <- pattern[order(pattern$col, pattern$row), ]
    
    x[[part]][["bg"]][indices] <- pattern[["bg"]]
  }
  else 
  {
    pattern <- data.frame(col = sort(unique(x[[part]][["col"]][indices])))
    pattern[["bg"]] <- rep(bg_pattern, 
                           length.out = nrow(pattern))
    
    pattern <- 
      merge(pattern, 
            x[[part]][indices, c("row", "col")], 
            by = c("col"), 
            all.x = TRUE)

    pattern <- pattern[order(pattern$col, pattern$row), ]
    
    x[[part]][["bg"]][indices] <- pattern[["bg"]]
  }
  
  x
}