R/sprinkle_width.R

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

#' @name sprinkle_width
#' @title Adjust Table Cell Width
#' 
#' @description Customize the width of a cell in a table. This may be done
#'   to improve the appearance of cells with long text.
#'   
#' @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 width \code{numeric(1)}. Gives the width of the cell.
#' @param width_units \code{character(1)}. Gives the units for \code{width}.
#'   One of \code{c("pt", "px", "cm", "in", "\%")}
#' @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{width_units} values are recognized by HTML.  For LaTeX, \code{"px"}
#'   is converted to \code{"pt"}. 
#'   
#' @section Functional Requirements:
#' \enumerate{
#'  \item Correctly reassigns the appropriate elements of \code{width} 
#'    and \code{width_units} columns in the table part.
#'  \item Casts an error if \code{x} is not a \code{dust} object.
#'  \item Casts an error if \code{width} is not \code{numeric}
#'  \item Casts an error if \code{width_units} is not one of
#'    \code{c("px", "pt", "in", "cm", "\%")}.
#'  \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"}
#'  \item Casts an error if \code{recycle = "none"} and \code{width} does
#'    not have length 1.
#'  \item Correctly assigns values when \code{recycle} is not \code{"none"}
#'    and multiple values are given.
#'  \item Quietly accepts only the first value in \code{width_units} when
#'    \code{recycle = "none"}.
#' }
#' 
#' 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_width <- function(x, rows = NULL, cols = NULL, 
                            width = NULL, width_units = NULL,
                            part = c("body", "head", "foot", "interfoot", "table"),
                            fixed = FALSE, 
                            recycle = c("none", "rows", "cols", "columns"),
                            ...)
{
  UseMethod("sprinkle_width")
}

#' @rdname sprinkle_width
#' @export

sprinkle_width.default <- function(x, rows = NULL, cols = NULL, 
                                 width = NULL, width_units = NULL,
                                 part = c("body", "head", "foot", "interfoot", "table"),
                                 fixed = FALSE, 
                                 recycle = c("none", "rows", "cols", "columns"),
                                 ...)
{
  coll <- checkmate::makeAssertCollection()

  indices <- index_to_sprinkle(x = x, 
                               rows = rows, 
                               cols = cols, 
                               fixed = fixed,
                               part = part,
                               recycle = recycle,
                               coll = coll)
  
  recycle <- recycle[1]
  
  width_units <- sprinkle_width_index_assert(width = width,
                                             width_units = width_units, 
                                             recycle = recycle,
                                             coll = coll)

  checkmate::reportAssertions(coll)
  
  part <- part[1]
  
  sprinkle_width_index(x = x, 
                       indices = indices, 
                       width = width, 
                       width_units = width_units, 
                       part = part)
}

#' @rdname sprinkle_width
#' @export

sprinkle_width.dust_list <- function(x, rows = NULL, cols = NULL, 
                                      width = NULL, width_units = NULL,
                                      part = c("body", "head", "foot", "interfoot", "table"),
                                      fixed = FALSE, 
                                      recycle = c("none", "rows", "cols", "columns"),
                                      ...)
{
  structure(
    lapply(X = x,
           FUN = sprinkle_width.default,
           rows = rows,
           cols = cols,
           width = width,
           width_units = width_units,
           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 `width` and `width_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_width_index_assert <- function(width = NULL, width_units = NULL, recycle = "none", coll)
{
  if (!is.null(width))
  {
    checkmate::assert_numeric(x = width,
                              add = coll,
                              .var.name = "width")
    
    if (recycle == "none" && length(width) != 1)
      coll$push(paste0("When `recycle = none`, `width` must have length 1"))
  }
  
  if (!is.null(width_units))
  {
    if (recycle == "none")
    {
      width_units <- width_units[1]
    }

    checkmate::assert_subset(x = width_units,
                             choices = c("px", "pt", "in", "cm", "%"),
                             add = coll,
                             .var.name = "width_units")
  }
  
  width_units
}

sprinkle_width_index <- function(x, indices, width = "", width_units = "", part)
{
  if (!is.null(width))
  {
    x[[part]][["width"]][indices] <- width
  }
  
  if (!is.null(width_units))
  {
    x[[part]][["width_units"]][indices] <- width_units
  }
  
  x
}