R/sprinkle_fixed_header.R

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

#' @name sprinkle_fixed_header
#' @title Assign a Fixed Header to an HTML Table
#'
#' @description Long tables to be displayed on-screen may benefit by keeping
#'   the header fixed in position while scrolling through the body of the
#'   table.  This allows the user to maintain visual contact between the
#'   column name and the data.
#'
#' @param x An object of class \code{dust}
#' @param fixed_header \code{logical(1)}. When \code{TRUE}, HTML output will
#'   produce a table with a fixed header and a scrollable body.
#' @param scroll_body_height \code{integerish(1)}. Sets the height of the scrollable
#'   table body.
#' @param scroll_body_height_units \code{character(1)}. Determines the units for the
#'   height of the scrollable table.  Defaults to \code{"px"}.  Must be one
#'   of \code{c("px", "pt", "\%", "em")}.
#' @param scroll_body_background_color \code{character(1)}. The color of the background
#'   of the body.  Must be a valid color.  It defaults to white, which may
#'   override CSS settings provided by the user.  If this needs to be avoided,
#'   you may use the \code{\link{fixed_header_css}} function to assist in
#'   generating CSS code to use to define the CSS. See Avoiding CSS Conflicts.
#' @param fixed_header_height \code{integerish(1)}. Sets the height of the header
#'   row.
#' @param fixed_header_height_units \code{character(1)}. Determines the units for the
#'   height of the header row. Defaults to \code{"px"}. Must be one of
#'   \code{c("px", "pt", "\%", "em")}.
#' @param fixed_header_text_height \code{numeric(1)}. Sets the height at which the
#'   header text appears.  By default it is set to half of the header height.
#'   This should be approximately centered, but you may alter this to get the
#'   precise look you want.
#' @param fixed_header_text_height_units \code{character(1)}. Determines the units for
#'   placing the header text.  Defaults to \code{"px"}. Must be one of
#'   \code{c("px", "pt", "\%", "em")}.
#' @param fixed_header_background_color \code{character(1)}. Sets the background color for
#'   the header row.  This defaults to white and may override the user's CSS
#'   settings.  See Avoiding CSS Conflicts.
#' @param include_fixed_header_css \code{logical(1)}. When \code{TRUE}, the CSS code to
#'   produce the table is inserted directly ahead of the HTML code for the
#'   table.  When \code{FALSE}, the CSS is omitted and assumed to be provided
#'   by the user.  This may be beneficial if the user has defined CSS styles
#'   for their tables.  In this case, the user will need to add CSS classes
#'   to their customized CSS to accomodate the fixed headers.  See Avoiding
#'   CSS Conflicts.
#' @param fixed_header_class_name \code{character(1)}. When 
#'   \code{include_fixed_header_css = FALSE}, this
#'   class name is used to reference CSS classes provided by the user to
#'   format the table correctly.
#' @param ... Arguments to pass to other methods.
#'
#' @details CSS doesn't make this kind of table natural.  The solution to 
#'   generate the fixed headers used by \code{pixiedust} is probably not the 
#'   best solution in terms of CSS design.  It is, however, the most conducive 
#'   to generating dynamically on the fly. 
#'   
#'   The fixed header table requires nesting several HTML elements. 
#'   \enumerate{
#'    \item a \code{div} tag is used to control the alignment of the table
#'    \item a \code{section} tag is used to set up the header row that remains fixed.
#'    \item a \code{div} that sets the height of the scrollable body
#'    \item the \code{table} tag establishes the actual table.
#'    \item The \code{th} tags inside the table are set to full transparency and
#'      the content of the headers is duplicated in a \code{div} within the 
#'      \code{th} tag to display the content.
#'   }
#'   
#'   To accomplish these tasks, some CSS is exported with the table and placed
#'   in the document immediately before the table.  Read further to understand
#'   the conflicts that may arise if you are using custom CSS specifications 
#'   in your documents.
#'
#' @section Avoiding CSS Conflicts: 
#' Because of all of the shenanigans involved, exporting the CSS with the tables
#' may result in conflicts with your custom CSS. Most importantly, any CSS
#' you have applied to the \code{th} or \code{td} tags may be overwritten.
#' If you are using custom CSS, you may want to consider using 
#' \code{include_fixed_header_css = FALSE} and then utilizing 
#' \code{\link{fixed_header_css}} to generate CSS you can include in your 
#' CSS file to provide the fixed headers.  The code generated by 
#' \code{fixed_header_css} ought to be placed before your definitions for
#' \code{td} and \code{th}.  
#' 
#' To get the same header design in the fixed table, you will want to modify 
#' the \code{.th-pixie-fixed div} definition in the CSS to match your desired
#' \code{th} definition.
#' 
#' The code produced by \code{fixed_header_css} will include comments where
#' there is potential for a CSS conflict.
#'
#' @section Functional Requirements:
#' \enumerate{
#'  \item Set the \code{fixed_header} element of the \code{dust} object correctly.
#'  \item Set the \code{include_fixed_header_css} element of the \code{dust}
#'    object correctly.
#'  \item Set the \code{fixed_header_param} element of the \code{dust} object
#'    correctly.
#'  \item Cast an error if \code{x} does not inherit class \code{dust}
#'  \item Cast an error if \code{scroll_body_height} is not \code{integerish(1)}
#'  \item Cast an error if \code{scroll_body_height_units} is not \code{character(1)}
#'  \item Cast an error if \code{scroll_body_background_color} is not \code{character(1)}
#'  \item Cast an error if \code{scroll_body_background_color} is not a valid color.
#'  \item Cast an error if \code{fixed_header_height} is not \code{integerish(1)}
#'  \item Cast an error if \code{fixed_header_height_units} is not \code{character(1)}
#'  \item Cast an error if \code{fixed_header_text_height} is not \code{numeric(1)}
#'  \item Cast an error if \code{fixed_header_text_height_units} is not \code{character(1)}
#'  \item Cast an error if \code{fixed_header_background_color} is not \code{character(1)}
#'  \item Cast an error if \code{fixed_header_background_color} is not a valid color.
#'  \item Cast an error if \code{include_fixed_header_css} is not \code{logical(1)}
#'  \item Cast an error if \code{fixed_header_class_name} is not \code{character(1)}
#' }
#'
#' @export

sprinkle_fixed_header <- function(x,
                                  fixed_header = TRUE,
                                  include_fixed_header_css = TRUE,
                                  fixed_header_class_name = "pixie-fixed",
                                  scroll_body_height = 300,
                                  scroll_body_height_units = "px",
                                  scroll_body_background_color = "white",
                                  fixed_header_height = 20,
                                  fixed_header_height_units = "px",
                                  fixed_header_text_height = fixed_header_height / 2,
                                  fixed_header_text_height_units = "px",
                                  fixed_header_background_color = "white", ...)
{
  UseMethod("sprinkle_fixed_header")
}

#' @rdname sprinkle_fixed_header
#' @export

sprinkle_fixed_header.default <- function(x,
                                          fixed_header = TRUE,
                                          include_fixed_header_css = TRUE,
                                          fixed_header_class_name = "pixie-fixed",
                                          scroll_body_height = 300,
                                          scroll_body_height_units = "px",
                                          scroll_body_background_color = "white",
                                          fixed_header_height = 20,
                                          fixed_header_height_units = "px",
                                          fixed_header_text_height = fixed_header_height / 2,
                                          fixed_header_text_height_units = "px",
                                          fixed_header_background_color = "white", 
                                          ...)
{
  coll <- checkmate::makeAssertCollection()
  
  checkmate::assert_class(x = x,
                          classes = "dust",
                          add = coll)
  
  sprinkle_fixed_header_index_assert(
    fixed_header = fixed_header,
    include_fixed_header_css = include_fixed_header_css,
    fixed_header_class_name = fixed_header_class_name,
    scroll_body_height = scroll_body_height,
    scroll_body_height_units = scroll_body_height_units,
    scroll_body_background_color = scroll_body_background_color,
    fixed_header_height = fixed_header_height,
    fixed_header_height_units = fixed_header_height_units,
    fixed_header_text_height = fixed_header_text_height,
    fixed_header_text_height_units = fixed_header_text_height_units,
    fixed_header_background_color = fixed_header_background_color,
    coll = coll
  )
  
  checkmate::reportAssertions(coll)
  
  sprinkle_fixed_header_index(
    x = x,
    fixed_header = fixed_header,
    include_fixed_header_css = include_fixed_header_css,
    fixed_header_class_name = fixed_header_class_name,
    scroll_body_height = scroll_body_height,
    scroll_body_height_units = scroll_body_height_units,
    scroll_body_background_color = scroll_body_background_color,
    fixed_header_height = fixed_header_height,
    fixed_header_height_units = fixed_header_height_units,
    fixed_header_text_height = fixed_header_text_height,
    fixed_header_text_height_units = fixed_header_text_height_units,
    fixed_header_background_color = fixed_header_background_color
  )
}

#' @rdname sprinkle_fixed_header
#' @export

sprinkle_fixed_header.dust_list <- function(x,
                                            fixed_header = TRUE,
                                            include_fixed_header_css = TRUE,
                                            fixed_header_class_name = "pixie-fixed",
                                            scroll_body_height = 300,
                                            scroll_body_height_units = "px",
                                            scroll_body_background_color = "white",
                                            fixed_header_height = 20,
                                            fixed_header_height_units = "px",
                                            fixed_header_text_height = fixed_header_height / 2,
                                            fixed_header_text_height_units = "px",
                                            fixed_header_background_color = "white", 
                                            ...)
{
  structure(
    lapply(x,
           sprinkle_fixed_header.default,
           fixed_header = fixed_header,
           include_fixed_header_css = include_fixed_header_css,
           fixed_header_class_name = fixed_header_class_name,
           scroll_body_height = scroll_body_height,
           scroll_body_height_units = scroll_body_height_units,
           scroll_body_background_color = scroll_body_background_color,
           fixed_header_height = fixed_header_height,
           fixed_header_height_units = fixed_header_height_units,
           fixed_header_text_height = fixed_header_text_height,
           fixed_header_text_height_units = fixed_header_text_height_units,
           fixed_header_background_color = fixed_header_background_color),
    class = "dust_list"
  )
}

# Unexported utilities ----------------------------------------------
# These functions carry the the `_index` suffix for consistency with 
# the cell-valued sprinkles, but they don't actually require an 
# index, since they change table-valued sprinkles


sprinkle_fixed_header_index_assert <- function(x,
                                               fixed_header = TRUE,
                                               include_fixed_header_css = TRUE,
                                               fixed_header_class_name = "pixie-fixed",
                                               scroll_body_height = 300,
                                               scroll_body_height_units = "px",
                                               scroll_body_background_color = "white",
                                               fixed_header_height = 20,
                                               fixed_header_height_units = "px",
                                               fixed_header_text_height = fixed_header_height / 2,
                                               fixed_header_text_height_units = "px",
                                               fixed_header_background_color = "white",
                                               coll)
{
  checkmate::assert_logical(x = fixed_header,
                            len = 1,
                            .var.name = "fixed_header",
                            add = coll)
  
  checkmate::assert_integerish(x = scroll_body_height,
                               len = 1,
                               add = coll,
                               .var.name = "scroll_body_height")
  
  checkmate::assert_character(x = scroll_body_height_units,
                              len = 1,
                              add = coll,
                              .var.name = "scroll_body_height_units")
  
  checkmate::assert_character(x = scroll_body_background_color,
                              len = 1,
                              add = coll,
                              .var.name = "scroll_body_background_color")
  
  if (any(!is_valid_color(scroll_body_background_color))){
    coll$push("'scroll_body_background_color' is not a valid color")
  }
  
  checkmate::assert_integerish(x = fixed_header_height,
                               len = 1,
                               .var.name = "fixed_header_height",
                               add = coll)
  
  checkmate::assert_character(x = fixed_header_height_units,
                              len = 1,
                              .var.name = "fixed_header_height_units",
                              add = coll)
  
  checkmate::assert_numeric(x = fixed_header_text_height,
                            len = 1,
                            .var.name = "fixed_header_text_height",
                            add = coll)
  
  checkmate::assert_character(x = fixed_header_text_height_units,
                              len = 1,
                              .var.name = "fixed_header_text_height_units",
                              add = coll)
  
  checkmate::assert_character(x = fixed_header_background_color,
                              len = 1,
                              .var.name = "fixed_header_background_color",
                              add = coll)
  
  if (!any(is_valid_color(fixed_header_background_color))){
    coll$push("'fixed_header_background_color' is not a valid color")
  }
  
  checkmate::assert_logical(x = include_fixed_header_css,
                            len = 1,
                            .var.name = "include_fixed_header_css",
                            add = coll)
  
  checkmate::assert_character(x = fixed_header_class_name,
                              len = 1,
                              .var.name = "fixed_header_class_name",
                              add = coll)

}

# indices argument is only present to avoid errors when the argument is passed 
# from sprinkle

sprinkle_fixed_header_index <- function(x,
                                        fixed_header = TRUE,
                                        include_fixed_header_css = TRUE,
                                        fixed_header_class_name = "pixie-fixed",
                                        scroll_body_height = 300,
                                        scroll_body_height_units = "px",
                                        scroll_body_background_color = "white",
                                        fixed_header_height = 20,
                                        fixed_header_height_units = "px",
                                        fixed_header_text_height = fixed_header_height / 2,
                                        fixed_header_text_height_units = "px",
                                        fixed_header_background_color = "white",
                                        indices = NULL,
                                        part = NULL)
{
  x[["fixed_header"]] <- fixed_header
  x[["include_fixed_header_css"]] <- include_fixed_header_css
  x[["fixed_header_param"]] <- 
    list(fixed_header_class_name = fixed_header_class_name,
         scroll_body_height = scroll_body_height,
         scroll_body_height_units = scroll_body_height_units,
         scroll_body_background_color = scroll_body_background_color,
         fixed_header_height = fixed_header_height,
         fixed_header_height_units = fixed_header_height_units,
         fixed_header_text_height = fixed_header_text_height,
         fixed_header_text_height_units = fixed_header_text_height_units,
         fixed_header_background_color = fixed_header_background_color)
  
  x
}