From 949bee7e222445a46e6ca9dfd4922a433049e58c Mon Sep 17 00:00:00 2001 From: Your Name Date: Sat, 4 Jun 2022 18:51:40 +0000 Subject: [PATCH 1/7] adding attributes list to the table for columns --- R/useful-items.R | 40 ++++++++++++++++++++++++---------------- man/table.Rd | 15 ++++++++++++++- 2 files changed, 38 insertions(+), 17 deletions(-) diff --git a/R/useful-items.R b/R/useful-items.R index 40953c43..4e352312 100644 --- a/R/useful-items.R +++ b/R/useful-items.R @@ -2652,6 +2652,11 @@ bs4Sortable <- function(..., width = 12) { #' @param bordered Whether to display border between elements. FALSE by default. #' @param striped Whether to displayed striped in elements. FALSE by default. #' @param width Table width. 12 by default. +#' @param header_attributes a named list of attributes for each +#' header, which need to be the length of the number of columns +#' in the data. For example, +#' `list(list(class = "col-3"), list(class = "col-5"))` +#' changes with width fo the column, or you can use `list(width="25%)`. #' #' @examples #' if (interactive()) { @@ -2717,7 +2722,8 @@ bs4Sortable <- function(..., width = 12) { #' #' @export bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE, - striped = FALSE, width = 12) { + striped = FALSE, width = 12, + header_attributes = NULL) { # handle theme tableCl <- "table" @@ -2728,18 +2734,26 @@ bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE, !inherits(data, "data.frame")) { stop("data must be a dataframe, tibble or list") } - - if (inherits(data, "data.frame")) { - - # column headers - tableHead <- shiny::tags$thead( + make_table_header = function(x, header_attributes = NULL) { + if (!is.null(header_attributes)) { + stopifnot(length(header_attributes) == length(x)) + } + shiny::tags$thead( shiny::tags$tr( lapply( - seq_along(colnames(data)), - function(i) shiny::tags$th(colnames(data)[[i]]) + seq_along(x), + function(i) shiny::tags$th(x[[i]], + header_attributes[[i]]) ) ) ) + } + + if (inherits(data, "data.frame")) { + + # column headers + tableHead <- make_table_header(colnames(data), + header_attributes = header_attributes) table <- lapply(seq_len(nrow(data)), function(i) { bs4TableItems( @@ -2754,14 +2768,8 @@ bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE, } else if (inherits(data, "list")) { # column headers - tableHead <- shiny::tags$thead( - shiny::tags$tr( - lapply( - seq_along(names(data[[1]])), - function(i) shiny::tags$th(names(data[[1]])[[i]]) - ) - ) - ) + tableHead <- make_table_header(names(data[[1]]), + header_attributes = header_attributes) table <- lapply(seq_along(data), function(i) { bs4TableItems( diff --git a/man/table.Rd b/man/table.Rd index 32e12e27..8b0c724d 100644 --- a/man/table.Rd +++ b/man/table.Rd @@ -6,7 +6,14 @@ \alias{bs4TableItem} \title{Boostrap 4 table container} \usage{ -bs4Table(data, cardWrap = FALSE, bordered = FALSE, striped = FALSE, width = 12) +bs4Table( + data, + cardWrap = FALSE, + bordered = FALSE, + striped = FALSE, + width = 12, + header_attributes = NULL +) bs4TableItems(...) @@ -23,6 +30,12 @@ bs4TableItem(..., dataCell = FALSE) \item{width}{Table width. 12 by default.} +\item{header_attributes}{a named list of attributes for each +header, which need to be the length of the number of columns +in the data. For example, +`list(list(class = "col-3"), list(class = "col-5"))` +changes with width fo the column, or you can use `list(width="25%)`.} + \item{...}{Any HTML element.} \item{dataCell}{Whether the cell should be contain data or text. by default.} From 3bc852cdbf19359a78dc079dd6d83289243f91a0 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sat, 4 Jun 2022 19:08:16 +0000 Subject: [PATCH 2/7] added the example for header attributes --- R/useful-items.R | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/R/useful-items.R b/R/useful-items.R index 4e352312..1e31a6d0 100644 --- a/R/useful-items.R +++ b/R/useful-items.R @@ -317,7 +317,7 @@ bs4Carousel <- function(..., id, indicators = TRUE, width = 12, .list = NULL) { navs <- lapply(seq_along(items), FUN = function(i) { # if we found an active item, all other active items are ignored. active <- if (found_active) { - FALSE + FALSE } else { sum(grep(x = items[[i]]$attribs$class, pattern = "active")) == 1 } @@ -363,7 +363,7 @@ bs4Carousel <- function(..., id, indicators = TRUE, width = 12, .list = NULL) { # previous shiny::tags$a( class = "carousel-control-prev", - `data-target` = paste0("#", id), + `data-target` = paste0("#", id), href = "#", role = "button", `data-slide` = "prev", @@ -1484,7 +1484,7 @@ bs4ListGroupItem <- function(..., title = NULL, subtitle = NULL, if (active && disabled) { stop("active and disabled cannot be TRUE at the same time!") } - + list( body = ..., title = title, @@ -2681,6 +2681,12 @@ bs4Sortable <- function(..., width = 12) { #' server = function(input, output) { } #' ) #' +#' +#' header_attributes = rep(list(list(width = "20%")), 5) +#' header_attributes[2] = list( +#' c(header_attributes[[2]], +#' list(style="background-color:#FF0000") +#' )) #' # with shiny tags as input #' shinyApp( #' ui = dashboardPage( @@ -2708,7 +2714,8 @@ bs4Sortable <- function(..., width = 12) { #' ) #' ), #' list("$2,500 USD", "NA", "NA", "test", "NA") -#' ) +#' ), +#' header_attributes = header_attributes #' ) #' ), #' footer = dashboardFooter() @@ -2737,13 +2744,17 @@ bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE, make_table_header = function(x, header_attributes = NULL) { if (!is.null(header_attributes)) { stopifnot(length(header_attributes) == length(x)) + } else { + header_attributes = list() } shiny::tags$thead( shiny::tags$tr( lapply( seq_along(x), - function(i) shiny::tags$th(x[[i]], - header_attributes[[i]]) + function(i) { + args = append(x[[i]], header_attributes[[i]]) + do.call(shiny::tags$th, args = args) + } ) ) ) From f417c433451ef94324183eb5f6cf3c9b7819e6ba Mon Sep 17 00:00:00 2001 From: Your Name Date: Sat, 4 Jun 2022 19:21:01 +0000 Subject: [PATCH 3/7] fixing doicumentation --- R/useful-items.R | 2 +- man/table.Rd | 11 +++++++++-- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/R/useful-items.R b/R/useful-items.R index 1e31a6d0..a6114f6b 100644 --- a/R/useful-items.R +++ b/R/useful-items.R @@ -2656,7 +2656,7 @@ bs4Sortable <- function(..., width = 12) { #' header, which need to be the length of the number of columns #' in the data. For example, #' `list(list(class = "col-3"), list(class = "col-5"))` -#' changes with width fo the column, or you can use `list(width="25%)`. +#' changes with width fo the column, or you can use `list(width="25\%)`. #' #' @examples #' if (interactive()) { diff --git a/man/table.Rd b/man/table.Rd index 8b0c724d..07d8c84d 100644 --- a/man/table.Rd +++ b/man/table.Rd @@ -34,7 +34,7 @@ bs4TableItem(..., dataCell = FALSE) header, which need to be the length of the number of columns in the data. For example, `list(list(class = "col-3"), list(class = "col-5"))` -changes with width fo the column, or you can use `list(width="25%)`.} +changes with width fo the column, or you can use `list(width="25\%)`.} \item{...}{Any HTML element.} @@ -73,6 +73,12 @@ if (interactive()) { server = function(input, output) { } ) + + header_attributes = rep(list(list(width = "20\%")), 5) + header_attributes[2] = list( + c(header_attributes[[2]], + list(style="background-color:#FF0000") + )) # with shiny tags as input shinyApp( ui = dashboardPage( @@ -100,7 +106,8 @@ if (interactive()) { ) ), list("$2,500 USD", "NA", "NA", "test", "NA") - ) + ), + header_attributes = header_attributes ) ), footer = dashboardFooter() From 1ff18160335f793fc9380f13e0b2d0415481fd93 Mon Sep 17 00:00:00 2001 From: John Muschelli Date: Tue, 7 Jun 2022 19:53:25 +0000 Subject: [PATCH 4/7] no footer if href and footer = NULL --- R/cards.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/cards.R b/R/cards.R index df482658..fe845aa0 100644 --- a/R/cards.R +++ b/R/cards.R @@ -802,7 +802,8 @@ bs4ValueBox <- function(value, subtitle, icon = NULL, color = NULL, width = 3, shiny::icon("arrow-circle-right") ) } else { - shiny::tags$div(class = "small-box-footer", style = "height: 30px;") + NULL + # shiny::tags$div(class = "small-box-footer", style = "height: 30px;") } } From 25741a6b065f8eba83d158e62ef5239bb49c0d86 Mon Sep 17 00:00:00 2001 From: John Muschelli Date: Tue, 7 Jun 2022 20:22:48 +0000 Subject: [PATCH 5/7] need header_attributes to be null --- R/useful-items.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/useful-items.R b/R/useful-items.R index a6114f6b..ea69b4cd 100644 --- a/R/useful-items.R +++ b/R/useful-items.R @@ -2744,9 +2744,7 @@ bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE, make_table_header = function(x, header_attributes = NULL) { if (!is.null(header_attributes)) { stopifnot(length(header_attributes) == length(x)) - } else { - header_attributes = list() - } + } shiny::tags$thead( shiny::tags$tr( lapply( From 902f9a659175aa470a1059b3996bb2ad5d8294c2 Mon Sep 17 00:00:00 2001 From: John Muschelli Date: Tue, 7 Jun 2022 20:29:39 +0000 Subject: [PATCH 6/7] fixing bug with appending and NULL --- R/useful-items.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/useful-items.R b/R/useful-items.R index ea69b4cd..c6399174 100644 --- a/R/useful-items.R +++ b/R/useful-items.R @@ -2742,6 +2742,9 @@ bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE, stop("data must be a dataframe, tibble or list") } make_table_header = function(x, header_attributes = NULL) { + if (is.null(header_attributes)) { + header_attributes = lapply(1:length(x), function(r) NULL) + } if (!is.null(header_attributes)) { stopifnot(length(header_attributes) == length(x)) } @@ -2751,6 +2754,7 @@ bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE, seq_along(x), function(i) { args = append(x[[i]], header_attributes[[i]]) + args = as.list(args) do.call(shiny::tags$th, args = args) } ) From 4ebe7ee6b00171b0dab48016093fda618ac4913c Mon Sep 17 00:00:00 2001 From: Your Name Date: Wed, 8 Jun 2022 17:44:54 +0000 Subject: [PATCH 7/7] added subtitle = NULL option --- R/cards.R | 6 ++++-- man/appButton.Rd | 2 +- man/box.Rd | 2 -- man/dashboardUser.Rd | 4 ++-- man/infoBox.Rd | 2 +- man/renderMenu.Rd | 4 ++-- man/valueBox.Rd | 6 +++--- 7 files changed, 13 insertions(+), 13 deletions(-) diff --git a/R/cards.R b/R/cards.R index df482658..e43249c4 100644 --- a/R/cards.R +++ b/R/cards.R @@ -731,7 +731,7 @@ dropdownDivider <- function() { #' ) #' } #' @export -bs4ValueBox <- function(value, subtitle, icon = NULL, color = NULL, width = 3, +bs4ValueBox <- function(value, subtitle = NULL, icon = NULL, color = NULL, width = 3, href = NULL, footer = NULL, gradient = FALSE, elevation = NULL) { if (!is.null(icon)) { tagAssert(icon, type = "i") @@ -775,7 +775,9 @@ bs4ValueBox <- function(value, subtitle, icon = NULL, color = NULL, width = 3, innerTag <- shiny::tags$div( class = "inner", value, - shiny::tags$p(class = "small-box-subtitle", subtitle) + if (!is.null(subtitle)) { + shiny::tags$p(class = "small-box-subtitle", subtitle) + } ) iconTag <- if (!is.null(icon)) { diff --git a/man/appButton.Rd b/man/appButton.Rd index 43ec3450..552cb53f 100644 --- a/man/appButton.Rd +++ b/man/appButton.Rd @@ -17,7 +17,7 @@ you could also use any other HTML, like an image.} \item{icon}{An optional \code{\link[shiny:icon]{icon()}} to appear on the button.} \item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'}; -see \code{\link[shiny:reexports]{validateCssUnit()}}.} +see \code{\link[shiny:validateCssUnit]{validateCssUnit()}}.} \item{color}{Button backgroun color. Valid statuses are defined as follows: \itemize{ diff --git a/man/box.Rd b/man/box.Rd index 087d565f..b7b9694b 100644 --- a/man/box.Rd +++ b/man/box.Rd @@ -552,8 +552,6 @@ Other cards: \code{\link{renderbs4ValueBox}()} } \author{ -David Granjon, \email{dgranjon@ymail.com} - David Granjon, \email{dgranjon@ymail.com} } \concept{boxWidgets} diff --git a/man/dashboardUser.Rd b/man/dashboardUser.Rd index b2456903..f04e8bbf 100644 --- a/man/dashboardUser.Rd +++ b/man/dashboardUser.Rd @@ -79,7 +79,7 @@ dashboardUser( \item{tag}{A tag function, like \code{tags$li} or \code{tags$ul}.} -\item{expr}{An expression that returns a Shiny tag object, \code{\link[shiny:reexports]{HTML()}}, +\item{expr}{An expression that returns a Shiny tag object, \code{\link[shiny:HTML]{HTML()}}, or a list of such objects.} \item{env}{The parent environment for the reactive expression. By default, @@ -93,7 +93,7 @@ would like to use its expression as a value for \code{expr}, then you must set \code{quoted} to \code{TRUE}.} \item{outputArgs}{A list of arguments to be passed through to the implicit -call to \code{\link[shiny:htmlOutput]{uiOutput()}} when \code{renderUI} is used in an +call to \code{\link[shiny:uiOutput]{uiOutput()}} when \code{renderUI} is used in an interactive R Markdown document.} } \description{ diff --git a/man/infoBox.Rd b/man/infoBox.Rd index 1de2b6a2..d18b9780 100644 --- a/man/infoBox.Rd +++ b/man/infoBox.Rd @@ -48,7 +48,7 @@ infoBoxOutput(outputId, width = 4) renderInfoBox(expr, env = parent.frame(), quoted = FALSE) } \arguments{ -\item{expr}{An expression that returns a Shiny tag object, \code{\link[shiny:reexports]{HTML()}}, +\item{expr}{An expression that returns a Shiny tag object, \code{\link[shiny:HTML]{HTML()}}, or a list of such objects.} \item{env}{The parent environment for the reactive expression. By default, diff --git a/man/renderMenu.Rd b/man/renderMenu.Rd index 0089f07f..ee136f3e 100644 --- a/man/renderMenu.Rd +++ b/man/renderMenu.Rd @@ -7,7 +7,7 @@ renderMenu(expr, env = parent.frame(), quoted = FALSE, outputArgs = list()) } \arguments{ -\item{expr}{An expression that returns a Shiny tag object, \code{\link[shiny:reexports]{HTML()}}, +\item{expr}{An expression that returns a Shiny tag object, \code{\link[shiny:HTML]{HTML()}}, or a list of such objects.} \item{env}{The parent environment for the reactive expression. By default, @@ -21,7 +21,7 @@ would like to use its expression as a value for \code{expr}, then you must set \code{quoted} to \code{TRUE}.} \item{outputArgs}{A list of arguments to be passed through to the implicit -call to \code{\link[shiny:htmlOutput]{uiOutput()}} when \code{renderUI} is used in an +call to \code{\link[shiny:uiOutput]{uiOutput()}} when \code{renderUI} is used in an interactive R Markdown document.} } \description{ diff --git a/man/valueBox.Rd b/man/valueBox.Rd index 0754d864..d1963684 100644 --- a/man/valueBox.Rd +++ b/man/valueBox.Rd @@ -15,7 +15,7 @@ bs4ValueBoxOutput(outputId, width = 4) bs4ValueBox( value, - subtitle, + subtitle = NULL, icon = NULL, color = NULL, width = 3, @@ -27,7 +27,7 @@ bs4ValueBox( valueBox( value, - subtitle, + subtitle = NULL, icon = NULL, color = NULL, width = 3, @@ -42,7 +42,7 @@ valueBoxOutput(outputId, width = 4) renderValueBox(expr, env = parent.frame(), quoted = FALSE) } \arguments{ -\item{expr}{An expression that returns a Shiny tag object, \code{\link[shiny:reexports]{HTML()}}, +\item{expr}{An expression that returns a Shiny tag object, \code{\link[shiny:HTML]{HTML()}}, or a list of such objects.} \item{env}{The parent environment for the reactive expression. By default,