R/sprinkle_border.R

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

#' @name sprinkle_border
#' @title Sprinkle Changes to Cell Borders
#' 
#' @description Cell borders may be used to give visual structure to a table.
#'   Borders may generate distinction between sets of results, groups, 
#'   or types of output.
#'   
#' @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 border One or more of \code{"all"}, \code{"bottom"}, \code{"left"},
#'   \code{"top"}, or \code{"right"}. Partial matching is supported. Designates
#'   the side of the chosen cells for which borders should be modified.
#' @param border_color \code{character(1)} A character string giving a color for the 
#'   background of the chosen cells. \code{NULL} makes no change to the current
#'   value.
#' @param border_style \code{character(1)} setting the border style for the 
#'   cell.  One of \code{"solid"}, \code{"dashed"}, \code{"dotted"}, 
#'   \code{"double"}, \code{"groove"}, \code{"ridge"}, \code{"inset"},
#'   \code{"outset"}, \code{"hidden"}, or \code{"none"}. \code{NULL} makes no 
#'   change to the current value.
#' @param border_thickness \code{numeric(1)}. Sets the thickness of the border.
#'   \code{NULL} makes no change to the current value.
#' @param border_units \code{character(1)}. Sets the unit of measure for the
#'   border thickness.  May be either \code{"pt"}, \code{"px"}. \code{NULL} 
#'   makes no change to the current value.
#' @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 has no effect on console and markdown output.
#' 
#' HTML output accepts all of the possible values of \code{border_style}.
#' 
#' For LaTeX output, when \code{hhline = FALSE}, \code{"solid"}, \code{"dashed"},
#' \code{"dotted"}, \code{"hidden"}, and \code{"none"} are accepted.  
#' \code{"dotted"} will silently be treated as \code{"dashed"}, and 
#' \code{"hidden"} is the equivalent of \code{"none"}.
#' 
#' For LaTeX output when \code{hhline = TRUE}, \code{"solid"}, \code{"double"},
#' \code{"hidden"}, and \code{"none"} are accepted.  \code{"hidden"} is the
#' equivalent of \code{"none"}.
#' 
#' When a value of \code{border_style} is not recognized by an output format, 
#' it is silently ignored.
#' 
#' @section Functional Requirements:
#' \enumerate{
#'  \item Correctly reassigns the \code{left_border}, \code{right_border},
#'    \code{top_border} and \code{bottom_border} columns in the table part.
#'  \item Casts an error if \code{x} is not a \code{dust} object.
#'  \item Casts an error if any element of \code{border} is not one of 
#'    \code{"all"}, \code{"bottom"}, \code{"left"}, \code{"top"}, or 
#'    \code{"right"}.
#'  \item Casts an error if \code{border_color} is not a \code{character(1)}
#'  \item Casts an error if \code{border_color} is not a valid color format.
#'  \item Casts an error if \code{border_style} is not one of \code{"solid"}, 
#'    \code{"dashed"}, \code{"dotted"}, \code{"double"}, \code{"groove"},
#'    \code{"ridge"}, \code{"inset"}, \code{"outset"}, \code{"hidden"}, 
#'    \code{"none"}
#'  \item Casts an error if \code{border_thickness} is not a \code{numeric(1)}.
#'  \item Casts an error if \code{border_units} is not one of \code{"pt"} or 
#'    \code{"px"}.
#'  \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 Cast an error if \code{recycle = "none"} and \code{border_color}
#'    does not have length 1.
#'  \item Cast an error if \code{recycle = "none"} and \code{border_style}
#'    does not have length 1.
#'  \item Cast an error if \code{recycle = "none"} and \code{border_thickness}
#'    does not have length 1.
#'  \item Quietly restrict \code{border_units} to just the first element if
#'    is has length > 1 and \code{recycle = "none"}.
#' }
#' 
#' @author Benjamin Nutter
#' 
#' @seealso \code{\link{sprinkle}}, \code{\link{index_to_sprinkle}}
#' 
#' @export

sprinkle_border <- function(x, rows, cols, 
                            border = c("all", "bottom", "left", "top", "right"), 
                            border_color = "black",
                            border_style = "solid", border_thickness = 1,
                            border_units = c("pt", "px"), 
                            part = c("body", "head", "foot", "interfoot", "table"),
                            fixed = FALSE, 
                            recycle = c("none", "rows", "cols", "columns"), 
                            ...)
{
  UseMethod("sprinkle_border")
}

#' @rdname sprinkle_border
#' @export

sprinkle_border.default <- function(x, rows = NULL, cols = NULL, 
                                    border = c("all", "bottom", "left", "top", "right"), 
                                    border_color = "black",
                                    border_style = "solid", border_thickness = 1,
                                    border_units = c("pt", "px"),  
                                    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")

  indices <- index_to_sprinkle(x = x, 
                               rows = rows, 
                               cols = cols, 
                               fixed = fixed,
                               part = part,
                               recycle = recycle,
                               coll = coll)
    
  recycle <- recycle[1]
  
  sprinkle_border_index_assert(border = border,
                               border_color = border_color,
                               border_style = border_style,
                               border_thickness = border_thickness,
                               border_units = border_units,
                               recycle = recycle,
                               coll = coll)
  

  
  checkmate::reportAssertions(coll)
  
  # At this point, part should have passed the assertions in 
  # index_to_sprinkle. The first element is expected to be valid.
  
  sprinkle_border_index(x = x,
                        indices = indices,
                        border = border,
                        border_color = border_color,
                        border_style = border_style,
                        border_thickness = border_thickness,
                        border_units = border_units,
                        part = part)
}

#' @rdname sprinkle_border
#' @export

sprinkle_border.dust_list <- function(x, rows = NULL, cols = NULL, 
                                      border = c("all", "bottom", "left", "top", "right"), 
                                      border_color = "black",
                                      border_style = "solid", border_thickness = 1,
                                      border_units = c("pt", "px"),  
                                      part = c("body", "head", "foot", "interfoot", "table"),
                                      fixed = FALSE, 
                                      recycle = c("none", "rows", "cols", "columns"), 
                                      ...)
{
  structure(
    lapply(X = x,
           FUN = sprinkle_border.default,
           rows = rows,
           cols = cols,
           border = border,
           border_color = border_color,
           border_style = border_style,
           border_units = border_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 `bg` argument needs to be validated. 
# The assert function is kept separate so it may be called earlier
# without attempting to perform the assignment.

sprinkle_border_index_assert <- function(border = c("all", "bottom", "left", "top", "right"), 
                                         border_color = "black",
                                         border_style = "solid", 
                                         border_thickness = 1,
                                         border_units = c("pt", "px"),
                                         recycle = "none",
                                         coll)
{
  checkmate::assert_subset(x = border,
                           choices = c("all", "bottom", "left", "top", "right"),
                           add = coll)
  
  checkmate::assert_character(x = border_color,
                              add = coll)
  
  if (recycle == "none" && length(border_color) != 1)
    coll$push("When `recycle` = 'none', border_color must have length 1.")
  
  if (!any(is_valid_color(border_color)))
  {
    invalid_color <- border_color[!is_valid_color(border_color)]
    coll$push(sprintf("The following colors are not valid: %s",
                      paste0(invalid_color, collapse = ", ")))
  }
  
  checkmate::assert_subset(x = border_style,
                           choices = c("solid", "dashed", "dotted", 
                                       "double", "groove", "ridge", "inset",
                                       "outset", "hidden", "none"),
                           add = coll)
  
  if (recycle == "none" && length(border_style) != 1)
    coll$push("When `recycle` = 'none', border_style must have length 1.")
  
  checkmate::assert_numeric(x = border_thickness,
                            add = coll)
  if (recycle == "none" && length(border_thickness) != 1)
    coll$push("When `recycle` = 'none', border_thickness must have length 1.")
  
  checkmate::assert_subset(x = border_units,
                           choices = c("pt", "px"),
                           add = coll)
  
  if (recycle == "none" && length(border_units) != 1)
    border_units <- border_units[1]
}



sprinkle_border_index <- function(x, indices, border = NULL, 
                                  border_color = NULL, border_style = NULL,
                                  border_thickness = NULL, border_units = NULL,
                                  part)
{
  if (is.null(border)) border <- "all"
  if (is.null(border_color)) border_color <- "black"
  if (is.null(border_style)) border_style <- "solid"
  if (is.null(border_thickness)) border_thickness <- 1
  if (is.null(border_units)) border_units <- "pt"
  
  part <- part[1]
  border_units <- border_units[1]
  
  if (any(border == "all")) border <- c("bottom", "left", "top", "right")
  
  border_define <- sprintf("%s%s %s %s",
                           border_thickness,
                           border_units,
                           border_style,
                           border_color)
  for (side in border){
    x[[part]][[sprintf("%s_border", side)]][indices] <- border_define
  }
  
  x
}