mirror of
https://github.com/rstudio/shiny.git
synced 2026-02-06 20:55:24 -05:00
121 lines
4.4 KiB
R
121 lines
4.4 KiB
R
#' Table Output (Bootstrap)
|
|
#'
|
|
#' Creates a reactive table using the Bootstrap design that is suitable for assigning to
|
|
#' an \code{output} slot.
|
|
#'
|
|
#' The corresponding HTML output tag should be \code{div} and have the CSS class
|
|
#' name \code{shiny-html-output}.
|
|
#'
|
|
#' @param expr An expression that returns an R object that can be used with
|
|
#' \code{\link[xtable]{xtable}}.
|
|
#' @param ... Arguments to be passed through to \code{\link[xtable]{xtable}} and
|
|
#' \code{\link[xtable]{print.xtable}}.
|
|
#' @param format An optional string with the Bootstrap table format to apply to the
|
|
#' table (options: basic, striped, bordered, hover, condensed).
|
|
#'@param width An optional string with the width of the table, as a percentage of
|
|
#' the total width of the page.
|
|
#' @param env The environment in which to evaluate \code{expr}.
|
|
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
|
|
#' is useful if you want to save an expression in a variable.
|
|
#' @param func A function that returns an R object that can be used with
|
|
#' \code{\link[xtable]{xtable}} (deprecated; use \code{expr} instead).
|
|
#'
|
|
#' @export
|
|
renderBootstrapTable <- function(expr, format="basic", width="auto",
|
|
rownames=FALSE, colnames=TRUE, align=NULL,
|
|
digits=NULL, na="NA", ...,
|
|
env=parent.frame(), quoted=FALSE, func=NULL) {
|
|
if (!is.null(func)) {
|
|
shinyDeprecated(msg="renderTable: argument 'func' is deprecated. Please use 'expr' instead.")
|
|
} else {
|
|
installExprFunction(expr, "func", env, quoted)
|
|
}
|
|
|
|
# Create wrappers for most arguments so that functions can also be passed
|
|
# in, rather than only literals (useful for shiny apps)
|
|
formatWrapper <- createWrapper( format )
|
|
widthWrapper <- createWrapper( width )
|
|
rownamesWrapper <- createWrapper( rownames )
|
|
colnamesWrapper <- createWrapper( colnames )
|
|
alignWrapper <- createWrapper( align )
|
|
digitsWrapper <- createWrapper( digits )
|
|
naWrapper <- createWrapper( na )
|
|
|
|
# Main render function
|
|
markRenderFunction(tableOutput, function() {
|
|
format <- formatWrapper()
|
|
width <- widthWrapper()
|
|
rownames <- rownamesWrapper()
|
|
colnames <- colnamesWrapper()
|
|
align <- alignWrapper()
|
|
digits <- digitsWrapper()
|
|
na <- naWrapper()
|
|
|
|
# For css styling
|
|
classNames <- "table shiny-table"
|
|
classNames <- paste0( classNames, " table-", format )
|
|
data <- func()
|
|
|
|
# Return empty string if no data is provided
|
|
if (is.null(data) || identical(data, data.frame()))
|
|
return("")
|
|
|
|
# Separate the ... args to pass to xtable() vs print.xtable()
|
|
dots <- list(...)
|
|
xtable_argnames <- setdiff(names(formals(xtable)), c("x", "..."))
|
|
xtable_args <- dots[intersect(names(dots), xtable_argnames)]
|
|
non_xtable_args <- dots[setdiff(names(dots), xtable_argnames)]
|
|
|
|
# Figure out column alignment
|
|
if ( is.null(align) ) xtable_args <- c( xtable_args, align = NULL )
|
|
else {
|
|
num_cols <- ifelse( rownames, nchar(align), nchar(align) + 1 )
|
|
valid <- !grepl( "[^lcr]", align )
|
|
|
|
if ( num_cols == ncol(data) + 1 && valid ){
|
|
if ( !rownames ) align <- paste0( "r", align )
|
|
xtable_args <- c( xtable_args, align = align )
|
|
}
|
|
else if ( nchar(align) == 1 && valid ){
|
|
cols <- paste0( rep( align, ncol(data) + 1 ), collapse = "" )
|
|
xtable_args <- c( xtable_args, align = cols )
|
|
}
|
|
else {
|
|
stop("`align` must contain only the characters `l`, `c` and/or `r` and have
|
|
length either equal to 1 or to the total number of columns")
|
|
}
|
|
}
|
|
|
|
# Call xtable with its args
|
|
xtable_res <- do.call( xtable, c(list(data), xtable_args, digits = digits ))
|
|
|
|
# Set up print args
|
|
print_args <- list(
|
|
xtable_res,
|
|
type = 'html',
|
|
include.rownames = rownames,
|
|
include.colnames = colnames,
|
|
NA.string = na,
|
|
html.table.attributes = paste0('class="', htmlEscape(classNames, TRUE), '"
|
|
style="width:', noquote(validateCssUnit(width)),';"'))
|
|
|
|
print_args <- c(print_args, non_xtable_args)
|
|
|
|
return(paste(
|
|
utils::capture.output(
|
|
do.call(print, print_args)
|
|
),
|
|
collapse="\n"
|
|
))
|
|
})
|
|
}
|
|
|
|
|
|
|
|
# Create a wrapper for an argument passed to renderTable
|
|
createWrapper <- function( arg ){
|
|
if ( is.function( arg )) wrapper <- reactive( {arg()} )
|
|
else wrapper <- function() { arg }
|
|
return( wrapper )
|
|
}
|