R/sprinkle_merge.R

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

#' @name sprinkle_merge
#' @title Sprinkle Table Cells to Merge
#' 
#' @description Merging cells creates more space for values to be displayed
#'   without disrupting the appearance of other cells in the same row or 
#'   column.  The downside is that the content from only one of the cells
#'   in the merge range will be displayed.
#'   
#' @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 merge \code{logical} Defaults to \code{FALSE}, prompting no 
#'   merging action.
#' @param merge_rowval The row position of the cell whose content will be
#'   displayed.  Defaults to the minimum of \code{rows}.
#' @param merge_colval The column position of the cell whose content will 
#'   be displayed.  Deafults to the minimum of \code{cols}.
#' @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.
#' 
#' @section Functional Requirements:
#' \enumerate{
#'  \item Correctly reassigns the appropriate elements of \code{merge}, 
#'    \code{merge_rowval} and \code{merge_colval} columns in the table part.
#'  \item Casts an error if \code{x} is not a \code{dust} object.
#'  \item Casts an error if \code{merge} is not a \code{logical(1)}
#'  \item Casts an error if \code{merge_rowval} is not a \code{numeric(1)}
#'  \item Casts an error if \code{merge_colval} is not a \code{numeric(1)}
#'  \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_merge <- function(x, rows = NULL, cols = NULL, 
                           merge = FALSE, 
                           merge_rowval = NULL, merge_colval = NULL,
                           part = c("body", "head", "foot", "interfoot", "table"),
                           fixed = FALSE, 
                           recycle = c("none", "rows", "cols", "columns"),
                           ...)
{
  UseMethod("sprinkle_merge")
}

#' @rdname sprinkle_merge
#' @export

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

  sprinkle_merge_index_assert(merge = merge,
                              merge_rowval = merge_rowval,
                              merge_colval = merge_colval,
                              coll = coll)

  indices <- index_to_sprinkle(x = x, 
                               rows = rows, 
                               cols = cols, 
                               fixed = fixed,
                               part = part,
                               recycle = recycle,
                               coll = coll)

  checkmate::reportAssertions(coll)
  
  if (!merge)
  {
    return(x)
  }
  
  # At this point, part should have passed the assertions in 
  # index_to_sprinkle. The first element is expected to be valid.
  
  part <- part[1]

  sprinkle_merge_index(x = x, 
                      indices = indices, 
                      merge = merge,
                      merge_rowval = merge_rowval,
                      merge_colval = merge_colval,
                      part = part)
}

#' @rdname sprinkle_merge
#' @export

sprinkle_merge.dust_list <- function(x, rows = NULL, cols = NULL,
                                     merge = FALSE, 
                                     merge_rowval = NULL, merge_colval = NULL,
                                     part = c("body", "head", "foot", "interfoot", "table"),
                                     fixed = FALSE, 
                                     recycle = c("none", "rows", "cols", "columns"),
                                     ...)
{
  structure(
    lapply(X = x,
           FUN = sprinkle_merge.default,
           rows = rows,
           cols = cols,
           merge = merge,
           merge_rowval = merge_rowval,
           merge_colval = merge_colval,
           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_merge_index_assert <- function(merge = FALSE, 
                                        merge_rowval = NULL, merge_colval = NULL,
                                        coll)
{
  checkmate::assert_logical(x = merge,
                            len = 1,
                            .var.name = "merge",
                            add = coll)
  
  checkmate::assert_numeric(x = merge_rowval,
                            len = 1,
                            .var.name = "merge_rowval",
                            null.ok = TRUE,
                            add = coll)
  
  checkmate::assert_numeric(x = merge_colval,
                            len = 1,
                            .var.name = "merge_colval",
                            null.ok = TRUE,
                            add = coll)
  
  if (!merge[1] & (!is.null(merge_rowval[1]) || !is.null(merge_colval[1])))
  {
    message("merge = FALSE while merge_rowval or merge_colval has a value. ",
            "No action is performed")
  }
}

sprinkle_merge_index <- function(x, indices, 
                                 merge = FALSE, 
                                 merge_rowval = NULL, merge_colval = NULL,
                                 part)
{
  if (!merge) return(x)
  
  # convert the index positions to a logical vector.
  # This was necessary after fixing the recycling in #111
  i <- logical(nrow(x[[part]]))
  i[indices] <- TRUE
  indices <- i
  
  x[[part]][["merge"]][indices] <- TRUE
  
  #* If the display row and column aren't specified, choose the 
  #* minimum row or cell.
  if (is.null(merge_rowval)) merge_rowval <- min(x[[part]][["row"]][indices])
  if (is.null(merge_colval)) merge_colval <- min(x[[part]][["col"]][indices])
  
  #* Map the cells to the display cell
  x[[part]][["html_row"]][indices] <- as.integer(merge_rowval)
  x[[part]][["html_col"]][indices] <- as.integer(merge_colval)
  
  #* Set colspan and rowspan of non-display cells to 0.  This suppresses 
  #* them from display.
  x[[part]][["rowspan"]][indices] [x[[part]][["row"]][indices] != merge_rowval] <- 0L
  x[[part]][["colspan"]][indices] [x[[part]][["col"]][indices] != merge_colval] <- 0L
  
  #* Record the upper left most cell of the merged area.
  #* This will be needed for HTML table to place the cell in the correct
  #* location.
  x[[part]][["html_row_pos"]][indices] <- as.integer(min(x[[part]][["row"]][indices]))
  x[[part]][["html_col_pos"]][indices] <- as.integer(min(x[[part]][["col"]][indices]))
  
  #* Set the colspan and rowspan of the display cells.
  x[[part]][["rowspan"]][indices] [x[[part]][["row"]][indices] == merge_rowval] <- 
    as.integer(
      length(
        unique(
          x[[part]][["row"]][indices]
        )
      )
    )
    
  x[[part]][["colspan"]][indices] [x[[part]][["col"]][indices] == merge_colval] <- 
    as.integer(
      length(
        unique(
          x[[part]][["col"]][indices]
        )
      )
    )

  x
}