R/sprinkle_font.R

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

#' @name sprinkle_font
#' @title Sprinkle the Characteristics of Text in a Cell
#' 
#' @description Text can be made to stand out (or fade away) by using font 
#'   features such as bold and italic text, color, size, or different fonts.
#'   
#' @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 bold \code{logical(1)} indicating if the text in the selected cells
#'   should be made bold.
#' @param italic \code{logical(1)} indicating if the text in the selected 
#'   cells should be made italic.
#' @param font_size \code{numeric(1)} giving the font size.
#' @param font_size_units \code{character(1)} giving the units of the font 
#'   size.  May be any of \code{c("px", "pt", "\%", "em")}. LaTeX output only
#'   recognizes \code{"pt"} and \code{"em"}. For LaTeX output, \code{"px"} is
#'   quietly changed to \code{"pt"} when printing.
#' @param font_color \code{character(1)} giving a valid color name for the 
#'   text.
#' @param font_family \code{character(1)} giving the font name for the text. 
#'   This is only recognized in HTML output.   
#' @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 The \code{bold} and \code{italic} features are recognized by all 
#'   formats.  
#'   
#'   Font size features are recognized by HTML and LaTeX. LaTeX only recognizes 
#'   the font size unit options of \code{"pt"} and \code{"em"}, but will quietly
#'   change \code{"px"} to \code{"pt"} when printing.
#'   
#'   Font color features are recognized by HTML and LaTeX.
#'   
#'   Font family is only recognized by HTML.
#' 
#' @seealso \code{\link{sprinkle}}
#' 
#' @section Functional Requirements:
#' \enumerate{
#'   \item Correctly change the \code{bold} column of the table part for 
#'     the selected cells.
#'   \item Correctly change the \code{italic} column of the table part for 
#'     the selected cells.
#'   \item Correctly change the \code{font_size} column of the table part for 
#'     the selected cells.
#'   \item Correctly change the \code{font_size_units} column of the table part for 
#'     the selected cells.
#'   \item Correctly chagne the \code{font_color} column of the table part 
#'     for the selected cells.
#'   \item Correctly change the \code{font_family} column of the table part for 
#'     the selected cells.
#'   \item Cast an error if \code{x} is not a dust object.
#'   \item Cast an error if \code{bold} is not \code{logical(1)}
#'   \item Cast an error if \code{italic} is not \code{logical(1)}
#'   \item Cast an error if \code{font_size} is not \code{numeric(1)}
#'   \item Cast an error if \code{font_size_units} is not \code{character(1)}
#'   \item Cast an error if \code{font_size_units} is not one of 
#'     px, pt, em, or %
#'   \item Cast an error if \code{font_color} is not \code{character(1)}
#'   \item Cast an error if \code{font_family} is not \code{character(1)}
#'   \item Cast an error if \code{part} is not a subset of \code{c("body", 
#'     "head", "foot", "interfoot")}
#'  \item Cast an error if \code{recycle = "none"} and \code{bold}
#'    does not have length 1.
#'  \item Cast an error if \code{recycle = "none"} and \code{italic}
#'    does not have length 1.
#'  \item Cast an error if \code{recycle = "none"} and \code{font_size}
#'    does not have length 1.
#'  \item Cast an error if \code{recycle = "none"} and \code{font_size_units}
#'    does not have length 1.
#'  \item Cast an error if \code{recycle = "none"} and \code{font_color}
#'    does not have length 1.
#'  \item Cast an error if \code{recycle = "none"} and \code{font_family}
#'    does not have length 1.
#' }
#' 
#' 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}}.
#' 
#' @author Benjamin Nutter
#' 
#' @export

sprinkle_font <- function(x, rows = NULL, cols = NULL,
                          bold = NULL, italic = NULL,
                          font_size = NULL, font_size_units = NULL,
                          font_color = NULL, font_family = NULL,
                          ...,
                          part = c("body", "head", "foot", "interfoot", "table"),
                          fixed = FALSE,
                          recycle = "none")
{
  UseMethod("sprinkle_font")
}

#' @rdname sprinkle_font
#' @export

sprinkle_font.default <- function(x, rows = NULL, cols = NULL,
                               bold = NULL, italic = NULL,
                               font_size = NULL, font_size_units = NULL,
                               font_color = NULL, font_family = NULL,
                               ...,
                               part = c("body", "head", "foot", "interfoot", "table"),
                               fixed = FALSE,
                               recycle = "none")
{
  coll <- checkmate::makeAssertCollection()
  
  checkmate::assert_class(x = x,
                          classes = "dust",
                          add = coll)
  
  indices <- index_to_sprinkle(x = x, 
                               rows = rows, 
                               cols = cols, 
                               fixed = fixed,
                               part = part,
                               recycle = recycle,
                               coll = coll)
  
  recycle <- recycle[1]
  
  sprinkle_font_index_assert(bold = bold, 
                             italic = italic,
                             font_size = font_size, 
                             font_size_units = font_size_units,
                             font_color = font_color, 
                             font_family = font_family,
                             recycle = recycle,
                             coll = coll)
  
  checkmate::reportAssertions(coll)
  
  part <- part[1]
  
  sprinkle_font_index(x = x, 
                      indices = indices, 
                      bold = bold, 
                      italic = italic,
                      font_size = font_size, 
                      font_size_units = font_size_units,
                      font_color = font_color, 
                      font_family = font_family, 
                      part = part)
}

#' @rdname sprinkle_font
#' @export

sprinkle_font.dust_list <- function(x, rows = NULL, cols = NULL,
                                    bold = NULL, italic = NULL,
                                    font_size = NULL, font_size_units = NULL,
                                    font_color = NULL, font_family = NULL,
                                    ...,
                                    part = c("body", "head", "foot", "interfoot", "table"),
                                    fixed = FALSE,
                                    recycle = "none")
{
  structure(
    lapply(x,
           sprinkle_font.default,
           rows = rows,
           cols = cols,
           bold = bold,
           italic = italic,
           font_size = font_size,
           font_size_units = font_size_units,
           font_color = font_color,
           font_family = font_family,
           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 `halign` and `valign` arguments needs to be validated. 
# The assert function is kept separate so it may be called earlier
# without attempting to perform the assignment.

sprinkle_font_index_assert <- function(bold = NULL, italic = NULL,
                                       font_size = NULL, font_size_units = NULL,
                                       font_color = NULL, font_family = NULL,
                                       recycle = "none",
                                       coll = coll)
{
  if (!is.null(bold))
  {
    checkmate::assert_logical(x = bold,
                              add = coll,
                              .var.name = "bold")
    
    if (recycle == "none" && length(bold) != 1)
      coll$push("When `recycle` = 'none', bold must have length 1.")
  }
  
  if (!is.null(italic))
  {
    checkmate::assert_logical(x = italic,
                              add = coll,
                              .var.name = "italic")
    
    if (recycle == "none" && length(italic) != 1)
      coll$push("When `recycle` = 'none', italic must have length 1.")
  }
  
  if (!is.null(font_size))
  {
    checkmate::assert_numeric(x = font_size,
                              add = coll,
                              .var.name = "font_size")
    
    if (recycle == "none" && length(font_size) != 1)
      coll$push("When `recycle` = 'none', font_size must have length 1.")
  }
  
  if (!is.null(font_size_units))
  {
    checkmate::assert_character(x = font_size_units,
                                add = coll,
                                .var.name = "font_size_units")
    
    checkmate::assert_subset(x = font_size_units,
                             choices = c("px", "pt", "em", "%"),
                             add = coll,
                             .var.name = "font_size_units")
    
    if (recycle == "none" && length(font_size_units) != 1)
      coll$push("When `recycle` = 'none', font_size_units must have length 1.")
  }
  
  if (!is.null(font_color))
  {
    checkmate::assert_character(x = font_color,
                                add = coll,
                                .var.name = "font_color")
    
    if (recycle == "none" && length(font_color) != 1)
      coll$push("When `recycle` = 'none', font_color must have length 1.")
    
    if (!all(is_valid_color(font_color)))
    {
      coll$push(sprintf("`font_color` has invalid colors: %s",
                        font_color[!is_valid_color(font_color)]))
    }
  }
  
  if (!is.null(font_family))
  {
    checkmate::assert_character(x = font_family,
                                add = coll,
                                .var.name = "font_family")
    
    if (recycle == "none" && length(font_family) != 1)
      coll$push("When `recycle` = 'none', font_family must have length 1.")
  }
}

sprinkle_font_index <- function(x, indices, 
                                bold = NULL, italic = NULL,
                                font_size = NULL, font_size_units = NULL,
                                font_color = NULL, font_family = NULL, part)
{
  if (!is.null(bold))
  {
    x[[part]][["bold"]][indices] <- bold
  }
  
  if (!is.null(italic))
  {
    x[[part]][["italic"]][indices] <- italic
  }
  
  if (!is.null(font_size))
  {
    x[[part]][["font_size"]][indices] <- font_size
  }
  
  if (!is.null(font_size_units))
  {
    x[[part]][["font_size_units"]][indices] <- font_size_units
  }
  
  if (!is.null(font_color))
  {
    x[[part]][["font_color"]][indices] <- font_color
  }
  
  if (!is.null(font_family))
  {
    x[[part]][["font_family"]][indices] <- font_family
  }
  
  x
}