mirror of
https://github.com/rstudio/shiny.git
synced 2026-01-10 15:38:19 -05:00
Fix various rendering bugs
This commit is contained in:
Joe Cheng
264
R/render-table.R
264
R/render-table.R
@@ -81,148 +81,148 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
|
||||
|
||||
dots <- list(...) ## used later (but defined here because of scoping)
|
||||
|
||||
renderFunc <- function(shinysession, name, ...) {
|
||||
striped <- stripedWrapper()
|
||||
hover <- hoverWrapper()
|
||||
bordered <- borderedWrapper()
|
||||
format <- c(striped = striped, hover = hover, bordered = bordered)
|
||||
spacing <- spacingWrapper()
|
||||
width <- widthWrapper()
|
||||
align <- alignWrapper()
|
||||
rownames <- rownamesWrapper()
|
||||
colnames <- colnamesWrapper()
|
||||
digits <- digitsWrapper()
|
||||
na <- naWrapper()
|
||||
createRenderFunction(
|
||||
func,
|
||||
function(data, session, name, ...) {
|
||||
striped <- stripedWrapper()
|
||||
hover <- hoverWrapper()
|
||||
bordered <- borderedWrapper()
|
||||
format <- c(striped = striped, hover = hover, bordered = bordered)
|
||||
spacing <- spacingWrapper()
|
||||
width <- widthWrapper()
|
||||
align <- alignWrapper()
|
||||
rownames <- rownamesWrapper()
|
||||
colnames <- colnamesWrapper()
|
||||
digits <- digitsWrapper()
|
||||
na <- naWrapper()
|
||||
|
||||
spacing_choices <- c("s", "xs", "m", "l")
|
||||
if (!(spacing %in% spacing_choices)) {
|
||||
stop(paste("`spacing` must be one of",
|
||||
paste0("'", spacing_choices, "'", collapse=", ")))
|
||||
}
|
||||
spacing_choices <- c("s", "xs", "m", "l")
|
||||
if (!(spacing %in% spacing_choices)) {
|
||||
stop(paste("`spacing` must be one of",
|
||||
paste0("'", spacing_choices, "'", collapse=", ")))
|
||||
}
|
||||
|
||||
# For css styling
|
||||
classNames <- paste0("table shiny-table",
|
||||
paste0(" table-", names(format)[format], collapse = "" ),
|
||||
paste0(" spacing-", spacing))
|
||||
# For css styling
|
||||
classNames <- paste0("table shiny-table",
|
||||
paste0(" table-", names(format)[format], collapse = "" ),
|
||||
paste0(" spacing-", spacing))
|
||||
|
||||
data <- func()
|
||||
data <- as.data.frame(data)
|
||||
data <- as.data.frame(data)
|
||||
|
||||
# Return NULL if no data is provided
|
||||
if (is.null(data) ||
|
||||
(is.data.frame(data) && nrow(data) == 0 && ncol(data) == 0))
|
||||
return(NULL)
|
||||
# Return NULL if no data is provided
|
||||
if (is.null(data) ||
|
||||
(is.data.frame(data) && nrow(data) == 0 && ncol(data) == 0))
|
||||
return(NULL)
|
||||
|
||||
# Separate the ... args to pass to xtable() vs print.xtable()
|
||||
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)]
|
||||
# Separate the ... args to pass to xtable() vs print.xtable()
|
||||
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)]
|
||||
|
||||
# By default, numbers are right-aligned and everything else is left-aligned.
|
||||
defaultAlignment <- function(col) {
|
||||
if (is.numeric(col)) "r" else "l"
|
||||
}
|
||||
# By default, numbers are right-aligned and everything else is left-aligned.
|
||||
defaultAlignment <- function(col) {
|
||||
if (is.numeric(col)) "r" else "l"
|
||||
}
|
||||
|
||||
# Figure out column alignment
|
||||
## Case 1: default alignment
|
||||
if (is.null(align) || align == "?") {
|
||||
names <- defaultAlignment(attr(data, "row.names"))
|
||||
cols <- paste(vapply(data, defaultAlignment, character(1)), collapse = "")
|
||||
cols <- paste0(names, cols)
|
||||
} else {
|
||||
## Case 2: user-specified alignment
|
||||
num_cols <- if (rownames) nchar(align) else nchar(align)+1
|
||||
valid <- !grepl("[^lcr\\?]", align)
|
||||
if (num_cols == ncol(data)+1 && valid) {
|
||||
cols <- if (rownames) align else paste0("r", align)
|
||||
defaults <- grep("\\?", strsplit(cols,"")[[1]])
|
||||
if (length(defaults) != 0) {
|
||||
vals <- vapply(data[,defaults-1], defaultAlignment, character(1))
|
||||
for (i in seq_len(length(defaults))) {
|
||||
substr(cols, defaults[i], defaults[i]) <- vals[i]
|
||||
}
|
||||
}
|
||||
} else if (nchar(align) == 1 && valid) {
|
||||
cols <- paste0(rep(align, ncol(data)+1), collapse="")
|
||||
# Figure out column alignment
|
||||
## Case 1: default alignment
|
||||
if (is.null(align) || align == "?") {
|
||||
names <- defaultAlignment(attr(data, "row.names"))
|
||||
cols <- paste(vapply(data, defaultAlignment, character(1)), collapse = "")
|
||||
cols <- paste0(names, cols)
|
||||
} else {
|
||||
stop("`align` must contain only the characters `l`, `c`, `r` and/or `?` and",
|
||||
"have length either equal to 1 or to the total number of columns")
|
||||
## Case 2: user-specified alignment
|
||||
num_cols <- if (rownames) nchar(align) else nchar(align)+1
|
||||
valid <- !grepl("[^lcr\\?]", align)
|
||||
if (num_cols == ncol(data)+1 && valid) {
|
||||
cols <- if (rownames) align else paste0("r", align)
|
||||
defaults <- grep("\\?", strsplit(cols,"")[[1]])
|
||||
if (length(defaults) != 0) {
|
||||
vals <- vapply(data[,defaults-1], defaultAlignment, character(1))
|
||||
for (i in seq_len(length(defaults))) {
|
||||
substr(cols, defaults[i], defaults[i]) <- vals[i]
|
||||
}
|
||||
}
|
||||
} else if (nchar(align) == 1 && valid) {
|
||||
cols <- paste0(rep(align, ncol(data)+1), collapse="")
|
||||
} else {
|
||||
stop("`align` must contain only the characters `l`, `c`, `r` and/or `?` and",
|
||||
"have length either equal to 1 or to the total number of columns")
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Call xtable with its (updated) args
|
||||
xtable_args <- c(xtable_args, align = cols, digits = digits)
|
||||
xtable_res <- do.call(xtable, c(list(data), xtable_args))
|
||||
# Call xtable with its (updated) args
|
||||
xtable_args <- c(xtable_args, align = cols, digits = digits)
|
||||
xtable_res <- do.call(xtable, c(list(data), xtable_args))
|
||||
|
||||
# Set up print args
|
||||
print_args <- list(
|
||||
x = xtable_res,
|
||||
type = 'html',
|
||||
include.rownames = {
|
||||
if ("include.rownames" %in% names(dots)) dots$include.rownames
|
||||
else rownames
|
||||
},
|
||||
include.colnames = {
|
||||
if ("include.colnames" %in% names(dots)) dots$include.colnames
|
||||
else colnames
|
||||
},
|
||||
NA.string = {
|
||||
if ("NA.string" %in% names(dots)) dots$NA.string
|
||||
else na
|
||||
},
|
||||
html.table.attributes =
|
||||
paste0({
|
||||
if ("html.table.attributes" %in% names(dots)) dots$html.table.attributes
|
||||
else ""
|
||||
}, " ",
|
||||
"class = '", htmlEscape(classNames, TRUE), "' ",
|
||||
"style = 'width:", validateCssUnit(width), ";'"),
|
||||
comment = {
|
||||
if ("comment" %in% names(dots)) dots$comment
|
||||
else FALSE
|
||||
# Set up print args
|
||||
print_args <- list(
|
||||
x = xtable_res,
|
||||
type = 'html',
|
||||
include.rownames = {
|
||||
if ("include.rownames" %in% names(dots)) dots$include.rownames
|
||||
else rownames
|
||||
},
|
||||
include.colnames = {
|
||||
if ("include.colnames" %in% names(dots)) dots$include.colnames
|
||||
else colnames
|
||||
},
|
||||
NA.string = {
|
||||
if ("NA.string" %in% names(dots)) dots$NA.string
|
||||
else na
|
||||
},
|
||||
html.table.attributes =
|
||||
paste0({
|
||||
if ("html.table.attributes" %in% names(dots)) dots$html.table.attributes
|
||||
else ""
|
||||
}, " ",
|
||||
"class = '", htmlEscape(classNames, TRUE), "' ",
|
||||
"style = 'width:", validateCssUnit(width), ";'"),
|
||||
comment = {
|
||||
if ("comment" %in% names(dots)) dots$comment
|
||||
else FALSE
|
||||
}
|
||||
)
|
||||
|
||||
print_args <- c(print_args, non_xtable_args)
|
||||
print_args <- print_args[unique(names(print_args))]
|
||||
|
||||
# Capture the raw html table returned by print.xtable(), and store it in
|
||||
# a variable for further processing
|
||||
tab <- paste(utils::capture.output(do.call(print, print_args)),collapse = "\n")
|
||||
|
||||
# Add extra class to cells with NA value, to be able to style them separately
|
||||
tab <- gsub(paste(">", na, "<"), paste(" class='NA'>", na, "<"), tab)
|
||||
|
||||
# All further processing concerns the table headers, so we don't need to run
|
||||
# any of this if colnames=FALSE
|
||||
if (colnames) {
|
||||
# Make sure that the final html table has a proper header (not included
|
||||
# in the print.xtable() default)
|
||||
tab <- sub("<tr>", "<thead> <tr>", tab)
|
||||
tab <- sub("</tr>", "</tr> </thead> <tbody>", tab)
|
||||
tab <- sub("</table>$", "</tbody> </table>", tab)
|
||||
|
||||
# Update the `cols` string (which stores the alignment of each column) so
|
||||
# that it only includes the alignment for the table variables (and not
|
||||
# for the row.names)
|
||||
cols <- if (rownames) cols else substr(cols, 2, nchar(cols))
|
||||
|
||||
# Create a vector whose i-th entry corresponds to the i-th table variable
|
||||
# alignment (substituting "l" by "left", "c" by "center" and "r" by "right")
|
||||
cols <- strsplit(cols, "")[[1]]
|
||||
cols[cols == "l"] <- "left"
|
||||
cols[cols == "r"] <- "right"
|
||||
cols[cols == "c"] <- "center"
|
||||
|
||||
# Align each header accordingly (this guarantees that each header and its
|
||||
# corresponding column have the same alignment)
|
||||
for (i in seq_len(length(cols))) {
|
||||
tab <- sub("<th>", paste0("<th style='text-align: ", cols[i], ";'>"), tab)
|
||||
}
|
||||
}
|
||||
)
|
||||
|
||||
print_args <- c(print_args, non_xtable_args)
|
||||
print_args <- print_args[unique(names(print_args))]
|
||||
|
||||
# Capture the raw html table returned by print.xtable(), and store it in
|
||||
# a variable for further processing
|
||||
tab <- paste(utils::capture.output(do.call(print, print_args)),collapse = "\n")
|
||||
|
||||
# Add extra class to cells with NA value, to be able to style them separately
|
||||
tab <- gsub(paste(">", na, "<"), paste(" class='NA'>", na, "<"), tab)
|
||||
|
||||
# All further processing concerns the table headers, so we don't need to run
|
||||
# any of this if colnames=FALSE
|
||||
if (colnames) {
|
||||
# Make sure that the final html table has a proper header (not included
|
||||
# in the print.xtable() default)
|
||||
tab <- sub("<tr>", "<thead> <tr>", tab)
|
||||
tab <- sub("</tr>", "</tr> </thead> <tbody>", tab)
|
||||
tab <- sub("</table>$", "</tbody> </table>", tab)
|
||||
|
||||
# Update the `cols` string (which stores the alignment of each column) so
|
||||
# that it only includes the alignment for the table variables (and not
|
||||
# for the row.names)
|
||||
cols <- if (rownames) cols else substr(cols, 2, nchar(cols))
|
||||
|
||||
# Create a vector whose i-th entry corresponds to the i-th table variable
|
||||
# alignment (substituting "l" by "left", "c" by "center" and "r" by "right")
|
||||
cols <- strsplit(cols, "")[[1]]
|
||||
cols[cols == "l"] <- "left"
|
||||
cols[cols == "r"] <- "right"
|
||||
cols[cols == "c"] <- "center"
|
||||
|
||||
# Align each header accordingly (this guarantees that each header and its
|
||||
# corresponding column have the same alignment)
|
||||
for (i in seq_len(length(cols))) {
|
||||
tab <- sub("<th>", paste0("<th style='text-align: ", cols[i], ";'>"), tab)
|
||||
}
|
||||
}
|
||||
return(tab)
|
||||
}
|
||||
|
||||
# Main render function
|
||||
markRenderFunction(tableOutput, renderFunc, outputArgs = outputArgs)
|
||||
return(tab)
|
||||
},
|
||||
tableOutput, outputArgs
|
||||
)
|
||||
}
|
||||
|
||||
@@ -282,7 +282,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
|
||||
extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
|
||||
|
||||
# Return a list with src, and other img attributes
|
||||
c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
|
||||
c(src = session$fileUrl(name, file=imageinfo$src, contentType=contentType),
|
||||
extra_attr)
|
||||
},
|
||||
imageOutput, outputArgs)
|
||||
@@ -333,8 +333,14 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
|
||||
renderFunc <- function(shinysession, name, ...) {
|
||||
domain <- createRenderPrintPromiseDomain(width)
|
||||
p1 <- promise::with_promise_domain(domain, {
|
||||
p2 <- promise::resolved(func())
|
||||
p2 <- promise::resolved(TRUE)
|
||||
p2 <- promise::then(p2, function(value) {
|
||||
func()
|
||||
})
|
||||
p2 <- promise::then(p2, function(value, .visible) {
|
||||
if (.visible) {
|
||||
cat(file = domain$conn, paste(capture.output(value, append = TRUE), collapse = "\n"))
|
||||
}
|
||||
res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
|
||||
res
|
||||
})
|
||||
@@ -342,6 +348,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
|
||||
p2 <- promise::catch(p2,
|
||||
function(err) { cat(file=stderr(), "ERROR", err$message) }
|
||||
)
|
||||
p2
|
||||
})
|
||||
p1 <- promise::finally(p1, ~close(domain$conn))
|
||||
p1
|
||||
@@ -360,7 +367,22 @@ createRenderPrintPromiseDomain <- function(width) {
|
||||
op <- options(width = width)
|
||||
on.exit(options(op), add = TRUE)
|
||||
|
||||
capture.output(onFulfilled(...), file = f, append = TRUE, split = TRUE)
|
||||
sink(f, append = TRUE)
|
||||
on.exit(sink(NULL), add = TRUE)
|
||||
|
||||
onFulfilled(...)
|
||||
}
|
||||
},
|
||||
wrapOnRejected = function(onRejected) {
|
||||
force(onRejected)
|
||||
function(...) {
|
||||
op <- options(width = width)
|
||||
on.exit(options(op), add = TRUE)
|
||||
|
||||
sink(f, append = TRUE)
|
||||
on.exit(sink(NULL), add = TRUE)
|
||||
|
||||
onRejected(...)
|
||||
}
|
||||
},
|
||||
conn = f
|
||||
|
||||
@@ -6,3 +6,4 @@
|
||||
- [ ] ..stacktraceon../..stacktraceoff.. and stack traces in general
|
||||
- [ ] Non-async render functions should have their code all execute on the current tick. Otherwise order of execution will be surprising if they have side effects and explicit priorities.
|
||||
- [x] Respect execOnResize
|
||||
- [ ] Accidentally did then(cars) instead of then(~cars), which caused an *unhandled* promise exception
|
||||
|
||||
Reference in New Issue
Block a user