Nothing
R/useful-items.R
In bs4Dash: A 'Bootstrap 4' Version of 'shinydashboard'
Defines functions
updatePagination
pagination
getAdminLTEColors
bs4Quote
bs4Ribbon
bs4TableItem
bs4TableItems
bs4Table
bs4Sortable
userPostMedia
userPostTagItem
userPostTagItems
userPost
updateUserMessages
userMessage
userMessages
userListItem
userList
productListItem
productList
cardPad
descriptionBlock
attachmentBlock
ionicon
bs4ListGroupItem
bs4ListGroup
bs4Jumbotron
bs4Stars
bs4TimelineEnd
bs4TimelineStart
bs4TimelineItemMedia
bs4TimelineItem
bs4TimelineLabel
bs4Timeline
bs4Loading
bs4Callout
verify_compatible_lengths
bs4MultiProgressBar
bs4CarouselItem
bs4Carousel
updateAccordion
bs4AccordionItem
bs4Accordion
bs4Badge
Documented in
attachmentBlock
bs4Accordion
bs4AccordionItem
bs4Badge
bs4Callout
bs4Carousel
bs4CarouselItem
bs4Jumbotron
bs4ListGroup
bs4ListGroupItem
bs4Loading
bs4MultiProgressBar
bs4Quote
bs4Ribbon
bs4Sortable
bs4Stars
bs4Table
bs4TableItem
bs4TableItems
bs4Timeline
bs4TimelineEnd
bs4TimelineItem
bs4TimelineItemMedia
bs4TimelineLabel
bs4TimelineStart
cardPad
descriptionBlock
getAdminLTEColors
ionicon
pagination
productList
productListItem
updateAccordion
updatePagination
updateUserMessages
userList
userListItem
userMessage
userMessages
userPost
userPostMedia
userPostTagItem
userPostTagItems
#' Create a Bootstrap 4 dashboard badge item
#'
#' \link{dashboardBadge} creates a badge. It may be inserted in any element like inside
#' a \link[shiny]{actionButton} or a \link{dashboardSidebar}.
#'
#' @param ... Badge content.
#' @param color Badge color. Valid colors:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' }
#' @param position Badge position: "left" or "right".
#' @param rounded Whether the badge is rounded instead of square. FALSE by default.
#'
#' @rdname badge
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' dashboardBadge("Badge 1", color = "danger"),
#' actionButton(
#' inputId = "badge",
#' label = "Hello",
#' icon = NULL,
#' width = NULL,
#' dashboardBadge(1, color = "primary")
#' )
#' )
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
bs4Badge <- function(..., color, position = c("left", "right"),
rounded = FALSE) {
validateStatus(color)
position <- match.arg(position)
shiny::tags$span(
class = paste0(position, " badge", " badge-", color, if (rounded) " badge-pill"),
...
)
}
#' Bootstrap 4 accordion container
#'
#' \link{accordion} creates an accordion container.
#' Accordions are part of collapsible elements.
#'
#' @param ... slot for \link{accordionItem}.
#' @param id Unique accordion id.
#' @param width The width of the accordion.
#' @param .list To pass \link{accordionItem} within a list.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname accordion
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' accordion(
#' id = "accordion1",
#' accordionItem(
#' title = "Accordion 1 Item 1",
#' status = "danger",
#' collapsed = TRUE,
#' "This is some text!"
#' ),
#' accordionItem(
#' title = "Accordion 1 Item 2",
#' status = "indigo",
#' collapsed = FALSE,
#' "This is some text!"
#' )
#' ),
#' accordion(
#' id = "accordion2",
#' accordionItem(
#' title = "Accordion 2 Item 1",
#' status = "info",
#' collapsed = TRUE,
#' "This is some text!"
#' ),
#' accordionItem(
#' title = "Accordion 2 Item 2",
#' status = "success",
#' collapsed = FALSE,
#' "This is some text!"
#' )
#' ),
#' accordion(
#' id = "accordion_dynamic",
#' .list = lapply(
#' 1:2,
#' function(i)
#' accordionItem(
#' title = paste('Accordion 1 Item', i),
#' status = "danger",
#' collapsed = ifelse (i == 1, TRUE, FALSE),
#' "This is some text!"
#' )
#' )
#' )
#' ),
#' title = "Accordion"
#' ),
#' server = function(input, output) {
#' observe({
#' print(input$accordion1)
#' print(input$accordion2)
#' print(input$accordion_dynamic)
#' })
#' }
#' )
#' }
#'
#' @export
bs4Accordion <- function(..., id, width = 12, .list = NULL) {
items <- c(list(...), .list)
# patch that enables a proper accordion behavior
# we add the data-parent non standard attribute to each
# item. Each accordion must have a unique id.
lapply(seq_along(items), FUN = function(i) {
items[[i]]$children[[2]]$attribs[["data-parent"]] <<- paste0("#", id)
items[[i]]$children[[1]]$children[[1]]$children[[1]]$attribs$`data-target` <<- paste0("#collapse_", id, "_", i)
items[[i]]$children[[2]]$attribs[["id"]] <<- paste0("collapse_", id, "_", i)
})
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
shiny::tags$div(
class = "accordion",
id = id,
items
)
)
}
#' Bootstrap 4 accordion item
#'
#' \link{accordionItem} is to be inserted in a \link{accordion}.
#'
#' @inheritParams bs4Card
#'
#' @rdname accordion
#'
#' @export
bs4AccordionItem <- function(..., title, status = NULL,
collapsed = TRUE, solidHeader = TRUE) {
cl <- "card"
if (!is.null(status)) {
validateStatusPlus(status)
cl <- paste0(cl, " card-", status)
}
if (!solidHeader) cl <- paste0(cl, " card-outline")
shiny::tags$div(
class = cl,
# box header
shiny::tags$div(
class = "card-header",
shiny::tags$h4(
class = "card-title w-100",
shiny::tags$a(
class = "d-block w-100",
href = "#",
`data-toggle` = "collapse",
`aria-expanded` = if (collapsed) "false" else "true",
class = if (collapsed) "collapsed",
title
)
)
),
shiny::tags$div(
id = NULL,
`data-parent` = NULL,
class = if (collapsed) {
"collapse"
} else {
"collapse show"
},
#`aria-expanded` = if (isTRUE(collapsed)) "false" else "true",
#style = if (isTRUE(collapsed)) "height: 0px;" else NULL,
shiny::tags$div(class = "card-body", ...)
)
)
}
#' Update an accordion on the client
#'
#' \link{updateAccordion} toggles an \link{accordion} on the client.
#'
#' @param id Accordion to target.
#' @param selected Index of the newly selected \link{accordionItem}.
#' @param session Shiny session object.
#'
#' @export
#' @rdname accordion
#' @examples
#'
#' # Update accordion
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' radioButtons("controller", "Controller", choices = c(1, 2)),
#' br(),
#' accordion(
#' id = "accordion1",
#' accordionItem(
#' title = "Accordion 1 Item 1",
#' status = "danger",
#' collapsed = TRUE,
#' "This is some text!"
#' ),
#' accordionItem(
#' title = "Accordion 1 Item 2",
#' status = "warning",
#' collapsed = TRUE,
#' "This is some text!"
#' )
#' )
#' ),
#' title = "Update Accordion"
#' ),
#' server = function(input, output, session) {
#' observeEvent(input$controller, {
#' updateAccordion(id = "accordion1", selected = input$controller)
#' })
#' observe(print(input$accordion1))
#' observeEvent(input$accordion1, {
#' showNotification(sprintf("You selected accordion N° %s", input$accordion1), type = "message")
#' })
#' }
#' )
#' }
updateAccordion <- function(id, selected, session = shiny::getDefaultReactiveDomain()) {
session$sendInputMessage(id, selected)
}
#' Bootstrap 4 carousel
#'
#' \link{carousel} creates a carousel container to display media content.
#'
#' @param ... Slot for \link{carouselItem}.
#' @param id Unique carousel id.
#' @param indicators Whether to display left and right indicators.
#' @param width Carousel width. Between 1 and 12.
#' @param .list Should you need to pass \link{carouselItem} via \link{lapply} or similar,
#' put these item here instead of passing them in ...
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' carousel(
#' id = "mycarousel",
#' carouselItem(
#' caption = "Item 1",
#' tags$img(src = "https://via.placeholder.com/500")
#' ),
#' carouselItem(
#' caption = "Item 2",
#' tags$img(src = "https://via.placeholder.com/500")
#' )
#' )
#' ),
#' title = "Carousel"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @rdname carousel
#' @family boxWidgets
#'
#' @export
bs4Carousel <- function(..., id, indicators = TRUE, width = 12, .list = NULL) {
items <- c(list(...), .list)
generateCarouselNav <- function(items) {
found_active <- FALSE
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
} else {
sum(grep(x = items[[i]]$attribs$class, pattern = "active")) == 1
}
# if the item has active class and no item was found before, we found the active item
if (active && !found_active) found_active <- TRUE
shiny::tags$li(
`data-target` = paste0("#", id),
`data-slide-to` = i - 1,
class = if (active) "active"
)
})
actives <- dropNulls(lapply(navs, function(nav) {
nav$attribs$class
}))
# Make sure at least the first item is active
if (length(actives) == 0) {
navs[[1]]$attribs$class <- "active"
items[[1]]$attribs$class <<- paste0(
items[[1]]$attribs$class,
" active"
)
}
navs
}
indicatorsTag <- shiny::tags$ol(
class = "carousel-indicators",
generateCarouselNav(items)
)
bodyTag <- shiny::tags$div(
class = "carousel-inner",
items
)
controlButtons <- if (indicators) {
shiny::tagList(
# previous
shiny::tags$a(
class = "carousel-control-prev",
`data-target` = paste0("#", id),
href = "#",
role = "button",
`data-slide` = "prev",
shiny::tags$span(
class = "carousel-control-prev-icon",
`aria-hidden` = "true"
),
shiny::tags$span(class = "sr-only", "Previous")
),
# next
shiny::tags$a(
class = "carousel-control-next",
href = paste0("#", id),
role = "button",
`data-slide` = "next",
shiny::tags$span(
class = "carousel-control-next-icon",
`aria-hidden` = "true"
),
shiny::tags$span(class = "sr-only", "Next")
)
)
} else {
NULL
}
carouselTag <- shiny::tags$div(
class = "carousel slide",
`data-ride` = "carousel",
id = id
)
carouselTag <- shiny::tagAppendChildren(carouselTag, indicatorsTag, bodyTag, controlButtons)
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
carouselTag
)
}
#' Bootstrap 4 carousel item
#'
#' \link{carouselItem} creates a carousel item to insert in a \link{carousel}
#'
#' @param ... Element such as images, iframe, ...
#' @param caption Item caption.
#' @param active Whether the item is active or not at start.
#'
#' @rdname carousel
#'
#' @export
bs4CarouselItem <- function(..., caption = NULL, active = FALSE) {
shiny::tags$div(
class = if (active) "carousel-item active" else "carousel-item",
...,
if (!is.null(caption)) {
shiny::tags$div(class = "carousel-caption", caption)
}
)
}
#' AdminLTE3 progress bar
#'
#' Create a Bootstrap 4 progress bar.
#'
#' @param value Progress bar value.
#' @param min Progress bar minimum value.
#' @param max Progress bar maximum value.
#' @param vertical Whether to display the progress bar in vertical mode. FALSE by default.
#' @param striped Whether the progress bar is striped or not. FALSE by default.
#' @param animated Whether to animate the progress bar. Default to FALSE.
#' @param status Progress bar status. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @param size Progress bar size. NULL, "sm", "xs" or "xxs".
#' @param label Progress label. NULL by default.
#'
#' @md
#' @details For `multiProgressBar()`, `value` can be a vector which
#' corresponds to the progress for each segment within the progress bar.
#' If supplied, `striped`, `animated`, `status`, and `label` must be the
#' same length as `value` or length 1, in which case vector recycling is
#' used.
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' box(
#' title = "Horizontal",
#' progressBar(
#' value = 10,
#' striped = TRUE,
#' animated = TRUE
#' ),
#' progressBar(
#' value = 50,
#' status = "warning",
#' size = "xs"
#' ),
#' progressBar(
#' value = 20,
#' status = "danger",
#' size = "sm"
#' ),
#' multiProgressBar(
#' value = c(50, 20),
#' status = c("warning", "danger"),
#' size = "sm"
#' )
#' ),
#' box(
#' title = "Vertical",
#' progressBar(
#' value = 10,
#' striped = TRUE,
#' animated = TRUE,
#' vertical = TRUE
#' ),
#' progressBar(
#' value = 50,
#' status = "warning",
#' size = "xs",
#' vertical = TRUE
#' ),
#' progressBar(
#' value = 20,
#' status = "danger",
#' size = "sm",
#' vertical = TRUE
#' ),
#' multiProgressBar(
#' value = c(50, 20),
#' status = c("warning", "danger"),
#' size = "sm",
#' vertical = TRUE
#' )
#' )
#' ),
#' title = "Progress bars"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname progress
#'
#' @export
bs4ProgressBar <- function (value, min = 0, max = 100, vertical = FALSE, striped = FALSE,
animated = FALSE, status = "primary", size = NULL,
label = NULL) {
if (!is.null(status)) validateStatusPlus(status)
stopifnot(value >= min)
stopifnot(value <= max)
# wrapper class
progressCl <- if (isTRUE(vertical)) "progress vertical" else "progress mb-3"
if (!is.null(size)) progressCl <- paste0(progressCl, " progress-", size)
# bar class
barCl <- "progress-bar"
if (!is.null(status)) barCl <- paste0(barCl, " bg-", status)
if (striped) barCl <- paste0(barCl, " progress-bar-striped")
if (animated) barCl <- paste0(barCl, " progress-bar-animated")
# wrapper
barTag <- shiny::tags$div(
class = barCl,
role = "progressbar",
`aria-valuenow` = value,
`aria-valuemin` = min,
`aria-valuemax` = max,
style = if (vertical) {
paste0("height: ", paste0(value, "%"))
}
else {
paste0("width: ", paste0(value, "%"))
},
if(!is.null(label)) label
)
progressTag <- shiny::tags$div(class = progressCl)
progressTag <- shiny::tagAppendChild(progressTag, barTag)
progressTag
}
#' @rdname progress
#' @export
bs4MultiProgressBar <-
function(
value,
min = 0,
max = 100,
vertical = FALSE,
striped = FALSE,
animated = FALSE,
status = "primary",
size = NULL,
label = NULL
) {
status <- verify_compatible_lengths(value, status)
striped <- verify_compatible_lengths(value, striped)
animated <- verify_compatible_lengths(value, animated)
if (!is.null(label)) label <- verify_compatible_lengths(value, label)
if (!is.null(status)) lapply(status, function(x) validateStatusPlus(x))
stopifnot(all(value >= min))
stopifnot(all(value <= max))
stopifnot(sum(value) <= max)
bar_segment <- function(value, striped, animated, status, label) {
# bar class
barCl <- "progress-bar"
if (!is.null(status)) barCl <- paste0(barCl, " bg-", status)
if (striped) barCl <- paste0(barCl, " progress-bar-striped")
if (animated) barCl <- paste0(barCl, " progress-bar-animated")
shiny::tags$div(
class = barCl,
role = "progressbar",
`aria-valuenow` = value,
`aria-valuemin` = min,
`aria-valuemax` = max,
style = if (vertical) {
paste0("height: ", paste0(value, "%"))
}
else {
paste0("width: ", paste0(value, "%"))
},
if(!is.null(label)) label
)
}
barSegs <- list()
# progress bar segments
for (i in seq_along(value)) {
barSegs[[i]] <-
bar_segment(
value[[i]],
striped[[i]],
animated[[i]],
status[[i]],
label[[i]]
)
}
# wrapper class
progressCl <- if (isTRUE(vertical)) "progress vertical" else "progress mb-3"
if (!is.null(size)) progressCl <- paste0(progressCl, " progress-", size)
progressTag <- shiny::tags$div(class = progressCl)
progressTag <- shiny::tagAppendChild(progressTag, barSegs)
progressTag
}
verify_compatible_lengths <- function(x, y) {
if (length(x) == length(y)) return(y)
else if (length(y) == 1) return(rep(y, length(x)))
else {
name_x <- deparse(substitute(x))
name_y <- deparse(substitute(y))
error_msg <-
paste0("`", name_x, "` and `", name_y, "` must have compatible sizes. `",
name_y, "` must be size ", length(x), " or 1.")
stop(error_msg)
}
}
#' Create a Bootstrap 4 callout
#'
#' AdminLTE3 callout
#'
#' @param ... Callout content.
#' @param title Callout title.
#' @param status Callout status. Valid statuses:
#' \itemize{
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' }
#' @param width Callout width. Between 1 and 12.
#' @param elevation Callout elevation.
#'
#' @rdname callout
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "Callout",
#' body = bs4DashBody(
#' title = "Callouts",
#' callout(
#' title = "I am a danger callout!",
#' elevation = 4,
#' status = "danger",
#' "There is a problem that we need to fix.
#' A wonderful serenity has taken possession of
#' my entire soul, like these sweet mornings of
#' spring which I enjoy with my whole heart."
#' ),
#' callout(
#' title = "I am a danger callout!",
#' status = "warning",
#' "This is a yellow callout."
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
bs4Callout <- function(..., title, status = c("warning", "danger", "info", "success"),
width = 6, elevation = NULL) {
validateStatus(status)
status <- match.arg(status)
calloutCl <- "callout"
if (!is.null(status)) calloutCl <- paste0(calloutCl, " callout-", status)
if (!is.null(elevation)) calloutCl <- paste0(calloutCl, " elevation-", elevation)
calloutTag <- shiny::tags$div(
class = calloutCl,
shiny::tags$h5(title),
...
)
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
calloutTag
)
}
#' @title AdminLTE3 loading state element
#'
#' @description When a section is still work in progress or a computation is running
#'
#' @note Loading state can be programmatically used when a conputation is running for instance.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @rdname loading
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "loading spinner",
#' loadingState()
#' )
#' ),
#' title = "Loading State"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
bs4Loading <- function() {
shiny::tags$div(
class = "overlay",
shiny::tags$i(class = "fa fa-refresh fa-spin")
)
}
#' AdminLTE3 timeline block
#'
#' \link{timelineBlock} creates a timeline block that may be inserted in a \link{box} or outside.
#'
#' @param ... slot for \link{bs4TimelineLabel} or \link{bs4TimelineItem}.
#' @param reversed Whether the timeline is reversed or not.
#' @param width Timeline width. Between 1 and 12.
#'
#' @note reversed is useful when the user wants to use the timeline
#' inside a box.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname timeline
#' @family boxWidgets
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = bs4DashPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "test",
#' body = dashboardBody(
#' box(
#' title = "Timeline",
#' timelineBlock(
#' width = 12,
#' reversed = TRUE,
#' timelineEnd(color = "danger"),
#' timelineLabel("10 Feb. 2014", color = "pink"),
#' timelineItem(
#' elevation = 4,
#' title = "Item 1",
#' icon = icon("gears"),
#' color = "olive",
#' time = "now",
#' footer = "Here is the footer",
#' "This is the body"
#' ),
#' timelineItem(
#' title = "Item 2",
#' border = FALSE
#' ),
#' timelineLabel("3 Jan. 2014", color = "lightblue"),
#' timelineItem(
#' elevation = 2,
#' title = "Item 3",
#' icon = icon("paint-brush"),
#' status = "orange",
#' timelineItemMedia(image = "https://via.placeholder.com/150x100"),
#' timelineItemMedia(image = "https://via.placeholder.com/150x100")
#' ),
#' timelineStart(color = "secondary")
#' )
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
bs4Timeline <- function(..., reversed = TRUE, width = 6) {
cl <- "timeline"
if (isTRUE(reversed)) cl <- paste0(cl, " timeline-inverse")
timelineTag <- shiny::tags$div(
class = cl,
...
)
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
timelineTag
)
}
#' AdminLTE3 timeline label
#'
#' \link{timelineLabel} creates a timeline label element to highlight an event.
#'
#' @param ... Any element.
#' @param color Label color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @rdname timeline
#'
#' @export
bs4TimelineLabel <- function(..., color = NULL) {
cl <- NULL
if (!is.null(color)) {
validateStatusPlus(color)
cl <- paste0("bg-", color)
}
shiny::tags$div(
class = "time-label",
shiny::tags$span(
class = cl,
...
)
)
}
#' AdminLTE3 timeline item
#'
#' \link{timelineItem} creates a timeline item that contains information for a
#' given event like the title, description, date, ...
#'
#' @param ... Any element such as \link{timelineItemMedia} ...
#' @param icon Item icon. Expect \code{\link[shiny]{icon}}.
#' @param color Item color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @param time Item date or time.
#' @param title Item title.
#' @param border Whether to display a border between the header and the body. TRUE by default.
#' @param footer Item footer if any.
#' @param elevation Timeline elevation (numeric). NULL by default.
#'
#' @rdname timeline
#'
#' @export
bs4TimelineItem <- function(..., icon = NULL,
color = NULL, time = NULL, title = NULL,
border = TRUE, footer = NULL, elevation = NULL) {
if (!is.null(color)) {
validateStatusPlus(color)
icon$attribs$class <- paste0(icon$attribs$class, " bg-", color)
}
if (!is.null(elevation)) {
icon$attribs$class <- paste0(icon$attribs$class, " elevation-", elevation)
}
itemCl <- "timeline-header no-border"
if (isTRUE(border)) itemCl <- "timeline-header"
shiny::tags$div(
# timelineItem icon and status
icon,
# timelineItem container
shiny::tags$div(
class = "timeline-item",
#timelineItem time/date
shiny::tags$span(
class = "time",
shiny::icon("clock"),
time
),
# timelineItem title
shiny::tags$h3(
class = if (!is.null(elevation)) {
paste0(itemCl, " elevation-", elevation)
} else {
itemCl
},
title
),
# timelineItem body
shiny::tags$div(
class = "timeline-body",
...
),
# timelineItem footer
shiny::tags$div(
class = "timeline-footer",
footer
)
)
)
}
#' AdminLTE2 timeline media item
#'
#' \link{timelineItemMedia} create a specific container for images.
#'
#' @param image Media url or path.
#' @param height Media height in pixels.
#' @param width Media width in pixels.
#'
#' @rdname timeline
#'
#' @export
bs4TimelineItemMedia <- function(image = NULL, height = NULL, width = NULL) {
shiny::img(
class = "margin",
src = image,
height = height,
width = width
)
}
#' AdminLTE3 timeline starting point
#'
#' \link{timelineStart} indicates a starting point.
#'
#' @param icon Item icon such as "clock", "times", ...
#' @param color Item color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @rdname timeline
#'
#' @export
bs4TimelineStart <- function(icon = shiny::icon("clock"), color = NULL) {
iconTag <- icon
if (!is.null(color)) {
validateStatusPlus(color)
iconTag$attribs$class <- paste0(iconTag$attribs$class, " bg-", color)
}
shiny::tags$div(iconTag)
}
#' AdminLTE3 timeline ending point
#'
#' \link{timelineEnd} indicates an end point.
#'
#' @param icon Item icon such as "clock", "times", ...
#' @param color Item color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @rdname timeline
#'
#' @export
bs4TimelineEnd <- function(icon = shiny::icon("hourglass-end"), color = NULL) {
iconTag <- icon
if (!is.null(color)) {
validateStatusPlus(color)
iconTag$attribs$class <- paste0(iconTag$attribs$class, " bg-", color)
}
shiny::tagList(
shiny::tags$div(iconTag),
shiny::br(),
shiny::br()
)
}
#' @title AdminLTE3 stars
#'
#' @description Create a block of stars (ideal for rating)
#'
#' @param value Current value. Should be positive and lower or equal to max.
#' @param max Maximum number of stars by block.
#' @param color Star color. Valid colors are listed below:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @rdname stars
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Star example",
#' starBlock(5),
#' starBlock(5, color = "fuchsia"),
#' starBlock(1, color = "danger"),
#' starBlock(3, color = "secondary")
#' )
#' ),
#' title = "starBlock"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
bs4Stars <- function(value, max = 5, color = "warning") {
stopifnot(!is.null(color))
validateStatusPlus(color)
stopifnot(!is.null(value))
stopifnot(value >= 0)
stopifnot(value <= max)
shiny::tags$td(
class = "mailbox-star",
shiny::tags$a(
href = "javascript:void(0)",
if (value > 0) {
full_star <- lapply(seq_len(value), FUN = function(i) {
shiny::tags$i(class = paste0("fa text-", color, " fa-star"))
})
},
if (value < max) {
empty_star <- lapply(seq_len(max - value), FUN = function(i) {
shiny::tags$i(class = paste0("fa text-", color, " fa-star-o"))
})
}
),
shiny::tags$br()
)
}
#' @title BS4 jumbotron for AdminLTE3
#'
#' @description Create a jumbotron
#'
#' @param ... Any content.
#' @param title Jumbotron title.
#' @param lead Jumbotron lead.
#' @param href Jumbrotron external link.
#' @param btnName Jumbotron button name.
#' @param status Jumbotron background color. "primary", "success", "warning", "danger" or "info".
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname jumbotron
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "Jumbotron",
#' body = dashboardBody(
#' jumbotron(
#' title = "Hello, world!",
#' lead = "This is a simple hero unit, a simple jumbotron-style
#' component for calling extra attention to featured
#' content or information.",
#' "It uses utility classes for typography and spacing
#' to space content out within the larger container.",
#' status = "primary",
#' href = "https://www.google.com"
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
bs4Jumbotron <- function(..., title = NULL, lead = NULL, href = NULL, btnName = "More",
status = c("primary", "warning", "danger", "info", "success")) {
status <- match.arg(status)
# uncomment below if more status are enabled
#if (status == "dark") btnStatus <- "gray" else btnStatus <- "dark"
btnStatus <- "secondary"
jumboCl <- "jumbotron"
if (!is.null(status)) jumboCl <- paste0(jumboCl, " bg-", status)
# no need to wrap this tag in an external div to set a custom width
# since the jumbotron will take the whole page width
shiny::tags$div(
class = jumboCl,
shiny::tags$h1(class = "display-4", title),
shiny::tags$p(class = "lead", lead),
shiny::tags$hr(class = "my-4"),
shiny::tags$p(...),
if (!is.null(btnName)) {
shiny::tags$a(
class = paste0("btn btn-", btnStatus, " btn-lg"),
href = href,
target = "_blank",
role = "button",
btnName
)
}
)
}
#' @title BS4 list group for AdminLTE3
#'
#' @description Create a list group
#'
#' @param ... Slot for \link{listGroupItem}.
#' @param type List group type.
#' @param width List group width. 4 by default. Between 1 and 12.
#' @param .list Slot for programmatically generated items.
#'
#' @rdname listgroup
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "test",
#' body = dashboardBody(
#' fluidRow(
#' listGroup(
#' type = "basic",
#' listGroupItem("Cras justo odio"),
#' listGroupItem("Dapibus ac facilisis in"),
#' listGroupItem("Morbi leo risus")
#' ),
#' listGroup(
#' type = "action",
#' listGroupItem(
#' "Cras justo odio",
#' active = TRUE,
#' disabled = FALSE,
#' href = "https://www.google.com"
#' ),
#' listGroupItem(
#' active = FALSE,
#' disabled = FALSE,
#' "Dapibus ac facilisis in",
#' href = "https://www.google.com"
#' ),
#' listGroupItem(
#' "Morbi leo risus",
#' active = FALSE,
#' disabled = TRUE,
#' href = "https://www.google.com"
#' )
#' ),
#' listGroup(
#' type = "heading",
#' listGroupItem(
#' "Donec id elit non mi porta gravida at eget metus.
#' Maecenas sed diam eget risus varius blandit.",
#' active = TRUE,
#' disabled = FALSE,
#' title = "List group item heading",
#' subtitle = "3 days ago",
#' footer = "Donec id elit non mi porta."
#' ),
#' listGroupItem(
#' "Donec id elit non mi porta gravida at eget metus.
#' Maecenas sed diam eget risus varius blandit.",
#' active = FALSE,
#' disabled = FALSE,
#' title = "List group item heading",
#' subtitle = "3 days ago",
#' footer = "Donec id elit non mi porta."
#' )
#' )
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
bs4ListGroup <- function(..., type = c("basic", "action", "heading"), width = 4,
.list = NULL) {
items <- c(list(...), .list)
type <- match.arg(type)
# item class depends on selected type
itemCl <- switch(
type,
"basic" = "list-group-item d-flex justify-content-between align-items-center",
"action" = "list-group-item list-group-item-action",
"heading" = "list-group-item list-group-item-action flex-column align-items-start"
)
# build items based on type and options passed
itemsTag <- lapply(items, function(item) {
names(item)[1] <- "body"
if (item$active) itemCl <- paste0(itemCl, " active")
if (item$disabled) itemCl <- paste0(itemCl, " disabled")
# item tag
if (type == "basic") {
shiny::tags$li(
class = itemCl,
item$body
)
} else if (type == "action") {
shiny::tags$a(
class = itemCl,
href = item$href,
target = if (!is.null(item$href)) "_blank",
item$body
)
} else {
shiny::tags$a(
class = itemCl,
href = item$href,
target = if (!is.null(item$href)) "_blank",
shiny::tags$div(
class = "d-flex w-100 justify-content-between",
shiny::tags$h5(class = "mb-1", item$title),
if (!is.null(item$subtitle)) {
shiny::tags$small(item$subtitle)
}
),
shiny::tags$p(class = "mb-1", item$body),
if (!is.null(item$footer)) {
shiny::tags$small(class = if (item$active) NULL else "text-muted", item$footer)
}
)
}
})
listGroupTag <- shiny::tags$ul(
class = "list-group",
itemsTag
)
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
listGroupTag
)
}
#' @title BS4 list group item for AdminLTE3
#'
#' @description Create a list group item
#'
#' @param ... Item content.
#' @param title Item title (only if type is "heading").
#' @param subtitle Item subtitle (only if type is "heading").
#' @param footer Item footer content (only if type is "heading").
#' @param active Whether the item is active or not. FALSE by default.
#' Only if type is "action" or "heading".
#' @param disabled Whether the item is disabled or not. FALSE by default.
#' Only if type is "action" or "heading".
#' @param href Item external link.
#'
#'
#' @rdname listgroup
#'
#' @export
bs4ListGroupItem <- function(..., title = NULL, subtitle = NULL,
footer = NULL, active = FALSE, disabled = FALSE,
href = NULL) {
if (active && disabled) {
stop("active and disabled cannot be TRUE at the same time!")
}
list(
body = ...,
title = title,
subtitle = subtitle,
footer = footer,
active = active,
disabled = disabled,
href = href
)
}
#' @title BS4 ionicons
#'
#' @description Create a ionicon.
#'
#' @param name Name of icon. See \url{https://ionic.io/ionicons/}.
#'
#' @note Similar to the icon function from shiny.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "Ionicons",
#' body = dashboardBody(
#' ionicon(name ="heart"),
#' ionicon(name ="beer")
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
ionicon <- function(name) {
if (is.null(name)) stop("Missing icon name")
cl <- paste0("icon ion-md-", name)
shiny::tags$i(class = cl)
}
#' AdminLTE3 attachment container
#'
#' \link{attachmentBlock} create an attachment container, nice to wrap articles...
#' and insert in a \link{box}.
#'
#' @param ... Any element.
#' @param image url or path to the image.
#' @param title Attachment title.
#' @param href External link.
#'
#' @family boxWidgets
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "attachmentBlock example",
#' attachmentBlock(
#' image = "https://adminlte.io/themes/v3/dist/img/user1-128x128.jpg",
#' title = "Test",
#' href = "https://google.com",
#' "This is the content"
#' )
#' )
#' ),
#' title = "attachmentBlock"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
attachmentBlock <- function(..., image, title = NULL, href = NULL) {
shiny::tags$div(
class = "attachment-block clearfix",
shiny::img(
class = "attachment-img",
src = image
),
shiny::tags$div(
class = "attachment-pushed",
if (!is.null(title)) {
shiny::tags$h4(
class = "attachment-heading",
shiny::tags$a(
href = if (!is.null(href)) {
href
} else {
"#"
},
target = if (!is.null(href)) {
"_blank"
},
title
)
)
},
shiny::tags$div(
class = "attachment-text",
...
)
)
)
}
#' AdminLTE3 description block
#'
#' \link{descriptionBlock} creates a description block, perfect for writing statistics
#' to insert in a \link{box}.
#'
#' @param number Any number.
#' @param numberColor Number color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @param numberIcon Number icon, if any. Expect \code{\link[shiny]{icon}}.
#' @param header Bold text.
#' @param text Additional text.
#' @param rightBorder TRUE by default. Whether to display a right border to
#' separate two blocks. The last block on the right should not have a right border.
#' @param marginBottom FALSE by default. Set it to TRUE when the
#' descriptionBlock is used in a \link{boxPad} context.
#'
#' @rdname box
#' @family boxWidgets
#'
#' @examples
#' # Box with descriptionBlock
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' solidHeader = FALSE,
#' title = "Status summary",
#' background = NULL,
#' width = 4,
#' status = "danger",
#' footer = fluidRow(
#' column(
#' width = 6,
#' descriptionBlock(
#' number = "17%",
#' numberColor = "pink",
#' numberIcon = icon("caret-up"),
#' header = "$35,210.43",
#' text = "TOTAL REVENUE",
#' rightBorder = TRUE,
#' marginBottom = FALSE
#' )
#' ),
#' column(
#' width = 6,
#' descriptionBlock(
#' number = "18%",
#' numberColor = "secondary",
#' numberIcon = icon("caret-down"),
#' header = "1200",
#' text = "GOAL COMPLETION",
#' rightBorder = FALSE,
#' marginBottom = FALSE
#' )
#' )
#' )
#' )
#' ),
#' title = "Description Blocks"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
descriptionBlock <- function(number = NULL, numberColor = NULL, numberIcon = NULL,
header = NULL, text = NULL, rightBorder = TRUE,
marginBottom = FALSE) {
cl <- "description-block"
if (rightBorder) cl <- paste0(cl, " border-right")
if (marginBottom) cl <- paste0(cl, " mb-4")
numcl <- "description-percentage"
if (!is.null(numberColor)) {
validateStatusPlus(numberColor)
numcl <- paste0(numcl, " text-", numberColor)
}
shiny::tags$div(
class = cl,
shiny::tags$span(
class = numcl,
number,
if (!is.null(numberIcon)) numberIcon
),
shiny::tags$h5(class = "description-header", header),
shiny::tags$span(class = "description-text", text)
)
}
#' AdminLTE3 vertical block container
#'
#' \link{boxPad} creates a vertical container for \link{descriptionBlock}.
#' It has to be included in a \link{box}.
#'
#' @param ... Any element such as \link{descriptionBlock}.
#' @param color Background color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @param style Custom CSS, if any.
#'
#' @rdname box
#' @family boxWidgets
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Box with right pad",
#' status = "warning",
#' fluidRow(
#' column(width = 6),
#' column(
#' width = 6,
#' boxPad(
#' color = "purple",
#' descriptionBlock(
#' header = "8390",
#' text = "VISITS",
#' rightBorder = FALSE,
#' marginBottom = TRUE
#' ),
#' descriptionBlock(
#' header = "30%",
#' text = "REFERRALS",
#' rightBorder = FALSE,
#' marginBottom = TRUE
#' ),
#' descriptionBlock(
#' header = "70%",
#' text = "ORGANIC",
#' rightBorder = FALSE,
#' marginBottom = FALSE
#' )
#' )
#' )
#' )
#' )
#' ),
#' title = "boxPad"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
cardPad <- function(..., color = NULL, style = NULL) {
cl <- "card-pane-right pt-2 pb-2 pl-4 pr-4"
if (!is.null(color)) {
validateStatusPlus(color)
cl <- paste0(cl, " bg-", color)
}
shiny::tags$div(
class = cl,
style = style,
...
)
}
#' AdminLTE3 product list container
#'
#' \link{productList} creates a container to display commercial items in an elegant container.
#' Insert in a \link{box}.
#'
#' @param ... slot for \link{productListItem}.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname productList
#'
#' @examples
#'
#' # Box with productList
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Product List",
#' status = "primary",
#' productList(
#' productListItem(
#' image = "https://www.pngmart.com/files/1/Haier-TV-PNG.png",
#' title = "Samsung TV",
#' subtitle = "$1800",
#' color = "warning",
#' "This is an amazing TV, but I don't like TV!"
#' ),
#' productListItem(
#' image = "https://upload.wikimedia.org/wikipedia/commons/7/77/IMac_Pro.svg",
#' title = "Imac 27",
#' subtitle = "$4999",
#' color = "danger",
#' "This is were I spend most of my time!"
#' )
#' )
#' )
#' ),
#' title = "Product List"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
productList <- function(...) {
shiny::tags$ul(
class = "products-list product-list-in-card pl-2 pr-2",
...
)
}
#' AdminLTE3 product item
#'
#' \link{productListItem} creates a product item to insert in \link{productList}.
#'
#' @param ... product description.
#' @param image image url, if any.
#' @param title product name.
#' @param subtitle product price.
#' @param color price color. Valid color are listed below:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' }
#' @rdname productList
#'
#' @export
productListItem <- function(..., image = NULL, title = NULL,
subtitle = NULL, color = NULL) {
cl <- "badge float-right"
if (!is.null(color)) {
validateStatus(color)
cl <- paste0(cl, " badge-", color)
}
shiny::tags$li(
class = "item",
shiny::tags$div(
class = "product-img",
shiny::tags$img(src = image, alt = "Product Image")
),
shiny::tags$div(
class = "product-info",
shiny::tags$a(
href = "javascript:void(0)",
class = "product-title",
title,
if (!is.null(subtitle)) shiny::tags$span(class = cl, subtitle)
),
shiny::tags$span(
class = "product-description",
...
)
)
)
}
#' AdminLTE3 user list container
#'
#' \link{userList} creates a user list container to be inserted in a \link{box}.
#'
#' @param ... slot for \link{userListItem}.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname userList
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "User List example",
#' status = "success",
#' userList(
#' userListItem(
#' image = "https://adminlte.io/themes/v3/dist/img/user1-128x128.jpg",
#' title = "Shiny",
#' subtitle = "Package 1"
#' ),
#' userListItem(
#' image = "https://adminlte.io/themes/v3/dist/img/user8-128x128.jpg",
#' title = "Tidyverse",
#' subtitle = "Package 2"
#' ),
#' userListItem(
#' image = "https://adminlte.io/themes/v3/dist/img/user7-128x128.jpg",
#' title = "tidyr",
#' subtitle = "Package 3"
#' )
#' )
#' )
#' ),
#' title = "User List"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
userList <- function(...) {
shiny::tags$ul(
class = "users-list clearfix",
...
)
}
#' AdminLTE3 user list item
#'
#' \link{userListItem} creates a user list item.
#'
#' @param image image url or path.
#' @param title Item title.
#' @param subtitle Item subtitle.
#'
#' @rdname userList
#'
#' @export
userListItem <- function(image, title, subtitle = NULL) {
shiny::tags$li(
shiny::tags$img(
src = image,
alt = "User Image",
shiny::tags$a(class = "users-list-name", title),
if (!is.null(subtitle)) {
shiny::tags$span(class = "users-list-date", subtitle)
}
)
)
}
#' AdminLTE3 user message container
#'
#' \link{userMessages} creates a user message container. Maybe inserted in a \link{box}.
#'
#' @param ... Slot for \link{userMessage}.
#' @param id Optional. To use with \link{updateUserMessages}.
#' @param status Messages status. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @param width Container width: between 1 and 12.
#' @param height Container height.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname userMessage
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Box with messages",
#' solidHeader = TRUE,
#' status = "warning",
#' userMessages(
#' width = 12,
#' status = "teal",
#' userMessage(
#' author = "Alexander Pierce",
#' date = "20 Jan 2:00 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user1-128x128.jpg",
#' type = "sent",
#' "Is this template really for free? That's unbelievable!"
#' ),
#' userMessage(
#' author = "Sarah Bullock",
#' date = "23 Jan 2:05 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user3-128x128.jpg",
#' type = "received",
#' "You better believe it!"
#' )
#' )
#' ),
#' userMessages(
#' width = 6,
#' status = "danger",
#' userMessage(
#' author = "Alexander Pierce",
#' date = "20 Jan 2:00 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user1-128x128.jpg",
#' type = "received",
#' "Is this template really for free? That's unbelievable!"
#' ),
#' userMessage(
#' author = "Sarah Bullock",
#' date = "23 Jan 2:05 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user3-128x128.jpg",
#' type = "sent",
#' "You better believe it!"
#' )
#' )
#' ),
#' title = "user Message"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
userMessages <- function(..., id = NULL, status, width = 4, height = NULL) {
cl <- "direct-chat-messages direct-chat"
if (!is.null(height)) shiny::validateCssUnit(height)
if (!is.null(status)) {
validateStatusPlus(status)
cl <- paste0(cl, " direct-chat-", status)
}
msgtag <- shiny::tags$div(
class = cl,
...,
style = if (!is.null(height)) {
sprintf("height: %s; overflow-y: auto;", height)
} else {
"height: 100%;"
}
)
shiny::tags$div(
id = id,
class = if (!is.null(width)) paste0("col-sm-", width),
msgtag
)
}
#' AdminLTE3 user message
#'
#' \link{userMessage} creates a user message html element.
#'
#' @param ... Message text.
#' @param author Message author.
#' @param date Message date.
#' @param image Message author image path or url.
#' @param type Message type: \code{c("sent", "received")}.
#'
#' @rdname userMessage
#'
#' @export
userMessage <- function(..., author = NULL, date = NULL,
image = NULL, type = c("sent", "received")) {
type <- match.arg(type)
messageCl <- "direct-chat-msg"
if (type == "sent") messageCl <- paste0(messageCl, " right")
# message info
messageInfo <- shiny::tags$div(
class = "direct-chat-info clearfix",
shiny::tags$span(
class = if (type == "right") {
"direct-chat-name float-right"
} else {
"direct-chat-name"
},
author
),
if (!is.null(date)) {
shiny::tags$span(
class = if (type == "right") {
"direct-chat-timestamp float-right"
} else {
"direct-chat-timestamp"
},
date
)
}
)
# message Text
messageTxt <- shiny::tags$div(class = "direct-chat-text", ...)
# message author image
messageImg <- shiny::tags$img(class = "direct-chat-img", src = image)
shiny::tags$div(
class = messageCl,
messageInfo,
messageImg,
messageTxt
)
}
#' Update a messages container in the server side
#'
#' \link{updateUserMessages} allows to interact with a \link{userMessages} container,
#' such as sending, removing or editing messages.
#'
#' @param id \link{userMessages} to target.
#' @param action Action to perform: add, remove or update.
#' @param index Index of item to update or remove.
#' @param content New message content in a list. For actions like add and update only! See example.
#' @param session Shiny session object.
#' @export
#' @rdname userMessage
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' fluidRow(
#' actionButton("remove", "Remove message"),
#' actionButton("add", "Add message"),
#' actionButton("update", "Update message")
#' ),
#' numericInput("index", "Message index:", 1, min = 1, max = 3),
#' br(),
#' br(),
#' userMessages(
#' width = 6,
#' status = "danger",
#' id = "message",
#' userMessage(
#' author = "Alexander Pierce",
#' date = "20 Jan 2:00 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user1-128x128.jpg",
#' type = "received",
#' "Is this template really for free? That's unbelievable!"
#' ),
#' userMessage(
#' author = "Sarah Bullock",
#' date = "23 Jan 2:05 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user3-128x128.jpg",
#' type = "sent",
#' "You better believe it!"
#' )
#' )
#' ),
#' title = "user Message"
#' ),
#' server = function(input, output, session) {
#' observeEvent(input$remove, {
#' updateUserMessages("message", action = "remove", index = input$index)
#' })
#' observeEvent(input$add, {
#' updateUserMessages(
#' "message",
#' action = "add",
#' content = list(
#' author = "David",
#' date = "Now",
#' image = "https://i.pinimg.com/originals/f1/15/df/f115dfc9cab063597b1221d015996b39.jpg",
#' type = "received",
#' text = tagList(
#' sliderInput(
#' "obs",
#' "Number of observations:",
#' min = 0,
#' max = 1000,
#' value = 500
#' ),
#' plotOutput("distPlot")
#' )
#' )
#' )
#' })
#'
#' output$distPlot <- renderPlot({
#' hist(rnorm(input$obs))
#' })
#'
#' observeEvent(input$update, {
#' updateUserMessages(
#' "message",
#' action = "update",
#' index = input$index,
#' content = list(
#' text = tagList(
#' appButton(
#' inputId = "reload",
#' label = "Click me!",
#' icon = icon("arrows-rotate"),
#' dashboardBadge(1, color = "primary")
#' )
#' )
#' )
#' )
#' })
#'
#' observeEvent(input$reload, {
#' showNotification("Yeah!", duration = 1, type = "default")
#' })
#' }
#' )
#' }
updateUserMessages <- function(id, action = c("add", "remove", "update"),
index = NULL, content = NULL,
session = shiny::getDefaultReactiveDomain()) {
action <- match.arg(action)
content <- lapply(content, function(c) {
if (inherits(c, "shiny.tag") || inherits(c, "shiny.tag.list")) {
# necessary if the user pass input/output with deps
# that are not yet available in the page before inserting the new tag
c <- htmltools::renderTags(c)
}
c
})
session$sendCustomMessage(
"user-messages",
list(
id = id,
action = action,
index = index,
body = content
)
)
}
#' AdminLTE3 user post
#'
#' Creates a user post. This content may be inserted in a \link{box}.
#'
#' @param ... Post content, slot for \link{userPostTagItems}, \link{userPostMedia}.
#' @param id Unique id of the post.
#' @param image Profile image, if any.
#' @param author Post author.
#' @param description Post description.
#' @param collapsible If TRUE, display a button in the upper right that allows the user to collapse the comment.
#' @param collapsed Whether the comment is collapsed when the application starts, FALSE by default.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname userPost
#' @family boxWidgets
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Box with user comment",
#' status = "primary",
#' userPost(
#' id = 1,
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user1-128x128.jpg",
#' author = "Jonathan Burke Jr.",
#' description = "Shared publicly - 7:30 PM today",
#' "Lorem ipsum represents a long-held tradition for designers,
#' typographers and the like. Some people hate it and argue for
#' its demise, but others ignore the hate as they create awesome
#' tools to help create filler text for everyone from bacon
#' lovers to Charlie Sheen fans.",
#' collapsible = FALSE,
#' userPostTagItems(
#' userPostTagItem(dashboardBadge("item 1", color = "info")),
#' userPostTagItem(dashboardBadge("item 2", color = "danger"), side = "right")
#' )
#' ),
#' userPost(
#' id = 2,
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user6-128x128.jpg",
#' author = "Adam Jones",
#' userPostMedia(image = "https://adminlte.io/themes/AdminLTE/dist/img/photo2.png"),
#' userPostTagItems(
#' userPostTagItem(dashboardBadge("item 1", color = "success")),
#' userPostTagItem(dashboardBadge("item 2", color = "danger"), side = "right")
#' )
#' )
#' )
#' ),
#' title = "userPost"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
userPost <- function(..., id = NULL, image, author,
description = NULL, collapsible = TRUE,
collapsed = FALSE) {
id <- paste0("post-", id)
btnCl <- "btn-tool float-right"
# if the input tag is an image, it is better to center it...
items <- list(...)
items <- lapply(seq_along(items), function(i) {
# do not apply to other things than tags
if (inherits(items[[i]], "shiny.tag")) {
if (items[[i]]$name == "img") {
# wrap the image item in a div to align its content
shiny::tags$div(
style = "text-align: center;",
items[[i]]
)
} else {
items[[i]]
}
} else {
items[[i]]
}
})
shiny::tags$div(
class = "post",
shiny::tags$div(
class = "user-block",
shiny::img(class = "img-circle img-bordered-sm", src = image),
shiny::tags$span(
class = "username",
author,
# box tool
if (collapsible) {
shiny::tags$a(
class = btnCl,
`data-toggle` = "collapse",
`data-target` = paste0("#", id),
`aria-expanded` = tolower(!collapsed),
`aria-controls` = id,
if (collapsed) {
shiny::tags$i(class = "fa fa-plus")
} else {
shiny::tags$i(class = "fa fa-minus")
}
)
}
),
if (!is.null(description)) {
shiny::tags$span(class = "description", description)
}
),
shiny::tags$div(
class = if (collapsible) {
if (!collapsed) {
"collapse show"
} else {
"collapse"
}
},
id = id,
items
)
)
}
#' AdminLTE3 user post tool item container
#'
#' \link{userPostTagItems} creates a container to host \link{userPostTagItem}.
#'
#' @param ... Slot for \link{userPostTagItem}.
#'
#' @rdname userPost
#'
#' @export
userPostTagItems<- function(...) {
shiny::tags$ul(
class = "list-inline d-flex",
...
)
}
#' AdminLTE3 user post tool item
#'
#' \link{userPostTagItem} creates a user post tool item
#'
#' @param ... Tool content such as label, button, ...
#'
#' @rdname userPost
#'
#' @export
userPostTagItem <- function(...) {
shiny::tags$li(
class = "mx-2",
...
)
}
#' AdminLTE3 user post media
#'
#' \link{userPostMedia} creates a container to include an image in \link{userPost}.
#'
#' @param image Image path or url ...
#' @param height Media height in pixels.
#' @param width Media width in pixels.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
userPostMedia <- function(image, height = NULL, width = NULL) {
shiny::img(
style = "margin: auto;",
class = "img-fluid",
src = image,
height = height,
width = width
)
}
#' @title BS4 sortable section
#'
#' @description Create a sortable UI section
#'
#' @param ... Slot for UI elements such as \link{box}.
#' @param width Section width: between 1 and 12.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname sortable
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "Sortable UI",
#' body = dashboardBody(
#' fluidRow(
#' lapply(1:3, FUN = function(i) {
#' sortable(
#' width = 4,
#' p(class = "text-center", paste("Column", i)),
#' lapply(1:2, FUN = function(j) {
#' box(
#' title = paste0("I am the ", j,"-th card of the ", i, "-th column"),
#' width = 12,
#' "Click on my header"
#' )
#' })
#' )
#' })
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
bs4Sortable <- function(..., width = 12) {
sectionCl <- "connectedSortable ui-sortable"
if (!is.null(width)) sectionCl <- paste0(sectionCl, " col-lg-", width)
shiny::tagList(
shiny::singleton(
shiny::tags$head(
shiny::tags$script(
"$(function() {
// Make the dashboard widgets sortable Using jquery UI
$('.connectedSortable').sortable({
placeholder: 'sort-highlight',
connectWith: '.connectedSortable',
handle: '.card-header, .nav-tabs',
forcePlaceholderSize: true,
zIndex: 999999
});
$('.connectedSortable .card-header, .connectedSortable .nav-tabs-custom').css('cursor', 'move');
});
"
)
)
),
shiny::tags$section(
class = sectionCl,
...
)
)
}
#' Boostrap 4 table container
#'
#' Build an Bootstrap 4 table container
#'
#' @param data Expect dataframe, tibble or list of shiny tags... See examples.
#' @param cardWrap Whether to wrap the table in a card. FALSE by default.
#' @param headTitles Table header names. Must have the same length as the number of
#' \link{bs4TableItem} in \link{bs4TableItems}. Set "" to have an empty title field.
#' @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.
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' # width dataframe as input
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' bs4Table(
#' cardWrap = TRUE,
#' bordered = TRUE,
#' striped = TRUE,
#' iris
#' )
#' ),
#' footer = dashboardFooter()
#' ),
#' server = function(input, output) { }
#' )
#'
#' # with shiny tags as input
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' bs4Table(
#' cardWrap = TRUE,
#' bordered = TRUE,
#' striped = TRUE,
#' list(
#' list(
#' income = "$2,500 USD",
#' status = dashboardBadge(
#' "Pending",
#' position = "right",
#' color = "danger",
#' rounded = TRUE
#' ),
#' progress = progressBar(value = 50, status = "pink", size = "xxs"),
#' text = "test",
#' confirm = actionButton(
#' "go",
#' "Go"
#' )
#' ),
#' list("$2,500 USD", "NA", "NA", "test", "NA")
#' )
#' )
#' ),
#' footer = dashboardFooter()
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname table
#'
#' @export
bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE,
striped = FALSE, width = 12) {
# handle theme
tableCl <- "table"
if (bordered) tableCl <- paste0(tableCl, " table-bordered")
if (striped) tableCl <- paste0(tableCl, " table-striped")
if (!inherits(data, "list") &&
!inherits(data, "data.frame")) {
stop("data must be a dataframe, tibble or list")
}
if (inherits(data, "data.frame")) {
# column headers
tableHead <- shiny::tags$thead(
shiny::tags$tr(
lapply(
seq_along(colnames(data)),
function(i) shiny::tags$th(colnames(data)[[i]])
)
)
)
table <- lapply(seq_len(nrow(data)), function(i) {
bs4TableItems(
lapply(seq_len(ncol(data)), function(j) {
bs4TableItem(
data[i, j],
dataCell = TRUE
)
})
)
})
} 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]])
)
)
)
table <- lapply(seq_along(data), function(i) {
bs4TableItems(
lapply(seq_along(data[[i]]), function(j) {
bs4TableItem(
data[[i]][[j]],
dataCell = TRUE
)
})
)
})
}
# body rows
tableBody <- shiny::tags$tbody(table)
# table tag
tableTag <- shiny::tags$table(
class = tableCl,
tableHead,
tableBody
)
# card wrapper or not
if (cardWrap) {
shiny::column(
width = width,
shiny::tags$div(
class = "card",
shiny::tags$div(
class = "card-body",
tableTag
)
)
)
} else {
tableTag
}
}
#' Boostrap 4 table item row
#'
#' Build an bs4 table item row
#'
#' @param ... Slot for \link{tableItem}.
#'
#' @rdname table
#' @keywords internal
bs4TableItems <- function(...) {
shiny::tags$tr(...)
}
#' Bootstrap 4 table item
#'
#' Build an bs4 table item
#'
#' @param ... Any HTML element.
#' @param dataCell Whether the cell should be contain data or text. <td> by default.
#'
#' @rdname table
#' @keywords internal
bs4TableItem <- function(..., dataCell = FALSE) {
if (dataCell) {
shiny::tags$td(...)
} else {
shiny::tags$th(...)
}
}
# #' @title AdminLTE3 todo list container
# #'
# #' @description Create a todo list container
# #'
# #' @param ... slot for todoListItem.
# #' @param sortable Whether the list elements are sortable or not.
# #'
# #' @author David Granjon, \email{dgranjon@@ymail.com}
# #'
# #' @examples
# #' if (interactive()) {
# #' library(shiny)
# #' library(bs4Dash)
# #' shinyApp(
# #' ui = dashboardPage(
# #' dashboardHeader(),
# #' dashboardSidebar(),
# #' dashboardBody(
# #' box(
# #' "Sortable todo list demo",
# #' status = "warning",
# #' todoList(
# #' todoListItem(
# #' label = "Design a nice theme",
# #' "Some text here"
# #' ),
# #' todoListItem(
# #' label = "Make the theme responsive",
# #' "Some text here"
# #' ),
# #' todoListItem(
# #' checked = TRUE,
# #' label = "Let theme shine like a star"
# #' )
# #' )
# #' ),
# #' box(
# #' "Simple todo list demo",
# #' status = "warning",
# #' todoList(
# #' sortable = FALSE,
# #' todoListItem(
# #' label = "Design a nice theme",
# #' "Some text here"
# #' ),
# #' todoListItem(
# #' label = "Make the theme responsive",
# #' "Some text here"
# #' ),
# #' todoListItem(
# #' checked = TRUE,
# #' label = "Let theme shine like a star"
# #' )
# #' )
# #' )
# #' ),
# #' title = "Todo Lists"
# #' ),
# #' server = function(input, output) { }
# #' )
# #' }
# #'
# #' @export
# todoList <- function(..., sortable = TRUE) {
#
# items <- list(...)
#
# if (sortable) {
# for (i in seq_along(items)) {
# items[[i]]$children[[1]]$attribs$class <- paste(items[[i]]$children[[1]]$attribs$class, "ui-sortable-handle")
# }
# }
#
# todoListTag <- shiny::tags$ul(
# class = if (sortable) "todo-list ui-sortable" else "todo-list",
# `data-widget` = "todo-list",
# items
# )
#
# todoListTag
#
# }
#
#
#
# #' @title AdminLTE2 todo list item
# #'
# #' @description Create a todo list item
# #'
# #' @param ... any element such as labels, ...
# #' @param checked Whether the list item is checked or not.
# #' @param label item label.
# #'
# #' @author David Granjon, \email{dgranjon@@ymail.com}
# #'
# #' @export
# todoListItem <- function(..., checked = FALSE, label = NULL) {
# cl <- NULL
# if (checked) cl <- "done"
#
# shiny::tags$li(
# class = cl,
#
# # sortable icon
# shiny::tags$span(
# class = "handle",
# shiny::tags$i(class = "fa fa-ellipsis-v"),
# shiny::tags$i(class = "fa fa-ellipsis-v")
# ),
#
# # checkbox trigger
# # need to be implemented (custom binding js)
# #shiny::tags$input(type = "checkbox"),
#
# # label
# shiny::tags$span(class = "text", label),
#
# # any element
# shiny::tags$small(
# ...
# )
# )
#
# }#
#' Boostrap 4 ribbon
#'
#' \link{bs4Ribbon} build a bootstrap 4 ribbon
#'
#' @param text Ribbon text.
#' @param color Ribbon color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' fluidRow(
#' box(
#' width = 4,
#' title = "Blue ribbon",
#' bs4Ribbon(
#' text = "New",
#' color = "primary"
#' )
#' ),
#' box(
#' width = 4,
#' title = "Purple ribbon",
#' bs4Ribbon(
#' text = "New",
#' color = "indigo"
#' )
#' ),
#' box(
#' width = 4,
#' title = "Orange ribbon",
#' bs4Ribbon(
#' text = "New",
#' color = "orange"
#' )
#' )
#' )
#' ),
#' footer = dashboardFooter()
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname ribbon
#'
#' @export
bs4Ribbon <- function(text, color) {
validateStatusPlus(color)
ribbonCl <- paste0("ribbon bg-", color)
ribbonWrapperCl <- "ribbon-wrapper"
shiny::tags$div(
class = ribbonWrapperCl,
shiny::tags$div(class = ribbonCl, text)
)
}
#' Boostrap 4 block quote
#'
#' Build a bootstrap 4 block quote
#'
#' @param ... Content.
#' @param color Block color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @rdname quote
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' fluidRow(
#' blockQuote("Blablabla", color = "indigo"),
#' blockQuote("Blablabla", color = "danger"),
#' blockQuote("Blablabla", color = "teal"),
#' blockQuote("Blablabla", color = "orange"),
#' blockQuote("Blablabla", color = "warning"),
#' blockQuote("Blablabla", color = "fuchsia")
#' )
#' ),
#' footer = dashboardFooter()
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
bs4Quote <- function(..., color) {
validateStatusPlus(color)
shiny::tags$blockquote(
class = paste0("quote-", color),
...
)
}
#' Get all AdminLTE colors.
#' @export
getAdminLTEColors <- function() {
c(validStatuses, validNuances, validColors)
}
#' Bootstrap 4 pagination widget
#'
#' See \url{https://getbootstrap.com/docs/4.0/components/pagination/}.
#'
#' @param ... Slot for \link{paginationItem}.
#' @param id Unique widget id. For programmatic update.
#' See \link{updatePagination}.
#' @param selected Which element to select at start.
#' @param align Alignment.
#' @param size Buttons size.
#' @param previousBtn Previous button text.
#' @param nextBtn Next button text.
#' @param .list Programmatically generated \link{paginationItem}.
#'
#' @rdname pagination
#'
#' @return An HTML pagination container
#' @export
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' pagination(
#' paginationItem("page1", box(title = "This is a box!")),
#' paginationItem("page2", "This is page 2", disabled = TRUE),
#' paginationItem("page3", "This is page 3", disabled = TRUE),
#' paginationItem(
#' "page4",
#' sliderInput(
#' "obs",
#' "Number of observations:",
#' min = 0,
#' max = 1000,
#' value = 500
#' ),
#' plotOutput("distPlot"),
#' icon = icon("cog")
#' )
#' )
#' )
#' ),
#' server = function(input, output, session) {
#' output$distPlot <- renderPlot({
#' hist(rnorm(input$obs))
#' })
#' }
#' )
#' }
pagination <- function(..., id = NULL, selected = NULL,
align = c("center", "left", "right"),
size = c("md", "sm", "lg"),
previousBtn = "\u00ab", nextBtn = "\u00bb",
.list = NULL) {
align <- match.arg(align)
size <- match.arg(size)
# Build temporary tag structure
temp_tag <- bs4Dash::tabsetPanel(
...,
id = id,
selected = selected,
type = "tabs",
vertical = FALSE,
side = "left",
.list = .list
)
# handle style
pagination_cl <- "pagination"
if (align %in% c("center", "right")) {
if (align == "right") align <- "end"
pagination_cl <- paste(
pagination_cl,
sprintf("justify-content-%s", align)
)
}
if (size %in% c("sm", "lg")) {
pagination_cl <- paste(
pagination_cl,
sprintf("pagination-%s", size)
)
}
# Start and end navigation tags
pagination_start <- shiny::tags$li(
class = "page-item",
shiny::tags$a(
class = "page-link pagination-previous",
href = "#",
tabindex = "-1",
shiny::tags$span(`aria-hidden`="true", previousBtn),
shiny::tags$span(class = "sr-only", "Previous")
)
)
pagination_end <- shiny::tags$li(
class = "page-item",
shiny::tags$a(
class = "page-link pagination-next",
href = "#",
shiny::tags$span(`aria-hidden`="true", nextBtn),
shiny::tags$span(class = "sr-only", "Next")
)
)
# Modify tag on the fly to correspond to Bootstrap 4 pagination
temp_tag <- htmltools::tagQuery(temp_tag)$
find("ul")$ # remove old tabs class and add pagination class
addAttrs("style" = "margin-bottom: 16px")$
removeClass("nav-tabs")$ # we still need nav to behave like tabs
addClass(pagination_cl)$
resetSelected()$
find("li")$ # replace li class
removeClass("nav-item")$
addClass("page-item")$
resetSelected()$
find("a")$ # replace a class
removeClass("nav-link")$
addClass("page-link")$
resetSelected()$
find("a.active")$ # move active class to parent li
removeClass("active")$
parent()$
addClass("active")$
resetSelected()$
find("ul.pagination")$ # insert navigation
prepend(pagination_start)$
append(pagination_end)$
allTags()
# Handle disabled tags
disabled_items_idx <- numeric(0)
htmltools::tagQuery(temp_tag)$
find(".tab-pane")$
each(function(x, i) {
if (x$attribs$`data-disabled` == "true") {
disabled_items_idx <<- c(disabled_items_idx, i)
}
})
temp_tag <- htmltools::tagQuery(temp_tag)$
find("li")$
each(function(x, i) {
if (i %in% (disabled_items_idx + 1)) {
x$attribs$class <- paste(x$attribs$class, "disabled")
# recommended by Bootstrap 4 doc
x$attribs$tabindex <- "-1"
}
})$
allTags()
# Wrap ul by tags$nav
temp_tag$children[[1]] <- shiny::tags$nav(
`aria-label` = "Navigation stepper",
temp_tag$children[[1]]
)
temp_tag
}
#' Bootstrap 4 pagination item
#'
#' Insert inside \link{pagination}.
#'
#' @inheritParams shiny::tabPanel
#' @param disabled Whether to disable the item. Default to FALSE.
#'
#' @rdname pagination
#'
#' @return An HTML tag.
#' @export
paginationItem <- function (title, ..., value = title,
icon = NULL, disabled = FALSE) {
shiny::tabPanel(
title = title,
...,
value = value,
icon = icon,
`data-disabled` = tolower(disabled)
)
}
#' Update pagination widget from the server
#'
#' @inheritParams pagination
#' @param session Shiny session object.
#'
#' @rdname pagination
#'
#' @return Send a message from R to JS so as to update
#' the pagination widget on the client.
#' @export
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' fluidRow(
#' actionButton("update", "Select page 4", class = "mx-2"),
#' actionButton("disable", "Disable page 1", class = "mx-2"),
#' actionButton("enable", "Enable page 1", class = "mx-2"),
#' textOutput("selected_page")
#' ),
#' br(),
#' pagination(
#' id = "mypagination",
#' paginationItem("page1", box(title = "This is a box!")),
#' paginationItem("page2", "This is page 2", disabled = TRUE),
#' paginationItem("page3", "This is page 3"),
#' paginationItem(
#' "page4",
#' sliderInput(
#' "obs",
#' "Number of observations:",
#' min = 0,
#' max = 1000,
#' value = 500
#' ),
#' plotOutput("distPlot"),
#' icon = icon("cog")
#' )
#' )
#' )
#' ),
#' server = function(input, output, session) {
#'
#' observeEvent(input$update,{
#' updatePagination("mypagination", selected = "page4")
#' })
#'
#' observeEvent(input$disable,{
#' updatePagination("mypagination", disabled = "page1")
#' })
#'
#' observeEvent(input$enable,{
#' updatePagination("mypagination", selected = "page1")
#' })
#'
#' output$selected_page <- renderText({
#' sprintf("Currently selected page: %s", input$mypagination)
#' })
#'
#' output$distPlot <- renderPlot({
#' hist(rnorm(input$obs))
#' })
#' }
#' )
#' }
updatePagination <- function(id, selected = NULL,
disabled = NULL,
session = shiny::getDefaultReactiveDomain()) {
if (length(selected) > 1) {
stop("Can't select more than one element ...")
}
# make sure we don't have selected and disabled item
# with the same value ...
common_elements <- intersect(selected, disabled)
if (length(common_elements) > 0) {
stop("A selected item cannot be disabled ...")
}
session$sendInputMessage(
id,
message = dropNulls(
list(
selected = selected,
disabled = disabled
)
)
)
}
Try the bs4Dash package in your browser
Any scripts or data that you put into this service are public.
bs4Dash documentation built on July 9, 2023, 7:49 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions updatePagination pagination getAdminLTEColors bs4Quote bs4Ribbon bs4TableItem bs4TableItems bs4Table bs4Sortable userPostMedia userPostTagItem userPostTagItems userPost updateUserMessages userMessage userMessages userListItem userList productListItem productList cardPad descriptionBlock attachmentBlock ionicon bs4ListGroupItem bs4ListGroup bs4Jumbotron bs4Stars bs4TimelineEnd bs4TimelineStart bs4TimelineItemMedia bs4TimelineItem bs4TimelineLabel bs4Timeline bs4Loading bs4Callout verify_compatible_lengths bs4MultiProgressBar bs4CarouselItem bs4Carousel updateAccordion bs4AccordionItem bs4Accordion bs4Badge
Documented in attachmentBlock bs4Accordion bs4AccordionItem bs4Badge bs4Callout bs4Carousel bs4CarouselItem bs4Jumbotron bs4ListGroup bs4ListGroupItem bs4Loading bs4MultiProgressBar bs4Quote bs4Ribbon bs4Sortable bs4Stars bs4Table bs4TableItem bs4TableItems bs4Timeline bs4TimelineEnd bs4TimelineItem bs4TimelineItemMedia bs4TimelineLabel bs4TimelineStart cardPad descriptionBlock getAdminLTEColors ionicon pagination productList productListItem updateAccordion updatePagination updateUserMessages userList userListItem userMessage userMessages userPost userPostMedia userPostTagItem userPostTagItems
#' Create a Bootstrap 4 dashboard badge item
#'
#' \link{dashboardBadge} creates a badge. It may be inserted in any element like inside
#' a \link[shiny]{actionButton} or a \link{dashboardSidebar}.
#'
#' @param ... Badge content.
#' @param color Badge color. Valid colors:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' }
#' @param position Badge position: "left" or "right".
#' @param rounded Whether the badge is rounded instead of square. FALSE by default.
#'
#' @rdname badge
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' dashboardBadge("Badge 1", color = "danger"),
#' actionButton(
#' inputId = "badge",
#' label = "Hello",
#' icon = NULL,
#' width = NULL,
#' dashboardBadge(1, color = "primary")
#' )
#' )
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
bs4Badge <- function(..., color, position = c("left", "right"),
rounded = FALSE) {
validateStatus(color)
position <- match.arg(position)
shiny::tags$span(
class = paste0(position, " badge", " badge-", color, if (rounded) " badge-pill"),
...
)
}
#' Bootstrap 4 accordion container
#'
#' \link{accordion} creates an accordion container.
#' Accordions are part of collapsible elements.
#'
#' @param ... slot for \link{accordionItem}.
#' @param id Unique accordion id.
#' @param width The width of the accordion.
#' @param .list To pass \link{accordionItem} within a list.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname accordion
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' accordion(
#' id = "accordion1",
#' accordionItem(
#' title = "Accordion 1 Item 1",
#' status = "danger",
#' collapsed = TRUE,
#' "This is some text!"
#' ),
#' accordionItem(
#' title = "Accordion 1 Item 2",
#' status = "indigo",
#' collapsed = FALSE,
#' "This is some text!"
#' )
#' ),
#' accordion(
#' id = "accordion2",
#' accordionItem(
#' title = "Accordion 2 Item 1",
#' status = "info",
#' collapsed = TRUE,
#' "This is some text!"
#' ),
#' accordionItem(
#' title = "Accordion 2 Item 2",
#' status = "success",
#' collapsed = FALSE,
#' "This is some text!"
#' )
#' ),
#' accordion(
#' id = "accordion_dynamic",
#' .list = lapply(
#' 1:2,
#' function(i)
#' accordionItem(
#' title = paste('Accordion 1 Item', i),
#' status = "danger",
#' collapsed = ifelse (i == 1, TRUE, FALSE),
#' "This is some text!"
#' )
#' )
#' )
#' ),
#' title = "Accordion"
#' ),
#' server = function(input, output) {
#' observe({
#' print(input$accordion1)
#' print(input$accordion2)
#' print(input$accordion_dynamic)
#' })
#' }
#' )
#' }
#'
#' @export
bs4Accordion <- function(..., id, width = 12, .list = NULL) {
items <- c(list(...), .list)
# patch that enables a proper accordion behavior
# we add the data-parent non standard attribute to each
# item. Each accordion must have a unique id.
lapply(seq_along(items), FUN = function(i) {
items[[i]]$children[[2]]$attribs[["data-parent"]] <<- paste0("#", id)
items[[i]]$children[[1]]$children[[1]]$children[[1]]$attribs$`data-target` <<- paste0("#collapse_", id, "_", i)
items[[i]]$children[[2]]$attribs[["id"]] <<- paste0("collapse_", id, "_", i)
})
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
shiny::tags$div(
class = "accordion",
id = id,
items
)
)
}
#' Bootstrap 4 accordion item
#'
#' \link{accordionItem} is to be inserted in a \link{accordion}.
#'
#' @inheritParams bs4Card
#'
#' @rdname accordion
#'
#' @export
bs4AccordionItem <- function(..., title, status = NULL,
collapsed = TRUE, solidHeader = TRUE) {
cl <- "card"
if (!is.null(status)) {
validateStatusPlus(status)
cl <- paste0(cl, " card-", status)
}
if (!solidHeader) cl <- paste0(cl, " card-outline")
shiny::tags$div(
class = cl,
# box header
shiny::tags$div(
class = "card-header",
shiny::tags$h4(
class = "card-title w-100",
shiny::tags$a(
class = "d-block w-100",
href = "#",
`data-toggle` = "collapse",
`aria-expanded` = if (collapsed) "false" else "true",
class = if (collapsed) "collapsed",
title
)
)
),
shiny::tags$div(
id = NULL,
`data-parent` = NULL,
class = if (collapsed) {
"collapse"
} else {
"collapse show"
},
#`aria-expanded` = if (isTRUE(collapsed)) "false" else "true",
#style = if (isTRUE(collapsed)) "height: 0px;" else NULL,
shiny::tags$div(class = "card-body", ...)
)
)
}
#' Update an accordion on the client
#'
#' \link{updateAccordion} toggles an \link{accordion} on the client.
#'
#' @param id Accordion to target.
#' @param selected Index of the newly selected \link{accordionItem}.
#' @param session Shiny session object.
#'
#' @export
#' @rdname accordion
#' @examples
#'
#' # Update accordion
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' radioButtons("controller", "Controller", choices = c(1, 2)),
#' br(),
#' accordion(
#' id = "accordion1",
#' accordionItem(
#' title = "Accordion 1 Item 1",
#' status = "danger",
#' collapsed = TRUE,
#' "This is some text!"
#' ),
#' accordionItem(
#' title = "Accordion 1 Item 2",
#' status = "warning",
#' collapsed = TRUE,
#' "This is some text!"
#' )
#' )
#' ),
#' title = "Update Accordion"
#' ),
#' server = function(input, output, session) {
#' observeEvent(input$controller, {
#' updateAccordion(id = "accordion1", selected = input$controller)
#' })
#' observe(print(input$accordion1))
#' observeEvent(input$accordion1, {
#' showNotification(sprintf("You selected accordion N° %s", input$accordion1), type = "message")
#' })
#' }
#' )
#' }
updateAccordion <- function(id, selected, session = shiny::getDefaultReactiveDomain()) {
session$sendInputMessage(id, selected)
}
#' Bootstrap 4 carousel
#'
#' \link{carousel} creates a carousel container to display media content.
#'
#' @param ... Slot for \link{carouselItem}.
#' @param id Unique carousel id.
#' @param indicators Whether to display left and right indicators.
#' @param width Carousel width. Between 1 and 12.
#' @param .list Should you need to pass \link{carouselItem} via \link{lapply} or similar,
#' put these item here instead of passing them in ...
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' carousel(
#' id = "mycarousel",
#' carouselItem(
#' caption = "Item 1",
#' tags$img(src = "https://via.placeholder.com/500")
#' ),
#' carouselItem(
#' caption = "Item 2",
#' tags$img(src = "https://via.placeholder.com/500")
#' )
#' )
#' ),
#' title = "Carousel"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @rdname carousel
#' @family boxWidgets
#'
#' @export
bs4Carousel <- function(..., id, indicators = TRUE, width = 12, .list = NULL) {
items <- c(list(...), .list)
generateCarouselNav <- function(items) {
found_active <- FALSE
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
} else {
sum(grep(x = items[[i]]$attribs$class, pattern = "active")) == 1
}
# if the item has active class and no item was found before, we found the active item
if (active && !found_active) found_active <- TRUE
shiny::tags$li(
`data-target` = paste0("#", id),
`data-slide-to` = i - 1,
class = if (active) "active"
)
})
actives <- dropNulls(lapply(navs, function(nav) {
nav$attribs$class
}))
# Make sure at least the first item is active
if (length(actives) == 0) {
navs[[1]]$attribs$class <- "active"
items[[1]]$attribs$class <<- paste0(
items[[1]]$attribs$class,
" active"
)
}
navs
}
indicatorsTag <- shiny::tags$ol(
class = "carousel-indicators",
generateCarouselNav(items)
)
bodyTag <- shiny::tags$div(
class = "carousel-inner",
items
)
controlButtons <- if (indicators) {
shiny::tagList(
# previous
shiny::tags$a(
class = "carousel-control-prev",
`data-target` = paste0("#", id),
href = "#",
role = "button",
`data-slide` = "prev",
shiny::tags$span(
class = "carousel-control-prev-icon",
`aria-hidden` = "true"
),
shiny::tags$span(class = "sr-only", "Previous")
),
# next
shiny::tags$a(
class = "carousel-control-next",
href = paste0("#", id),
role = "button",
`data-slide` = "next",
shiny::tags$span(
class = "carousel-control-next-icon",
`aria-hidden` = "true"
),
shiny::tags$span(class = "sr-only", "Next")
)
)
} else {
NULL
}
carouselTag <- shiny::tags$div(
class = "carousel slide",
`data-ride` = "carousel",
id = id
)
carouselTag <- shiny::tagAppendChildren(carouselTag, indicatorsTag, bodyTag, controlButtons)
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
carouselTag
)
}
#' Bootstrap 4 carousel item
#'
#' \link{carouselItem} creates a carousel item to insert in a \link{carousel}
#'
#' @param ... Element such as images, iframe, ...
#' @param caption Item caption.
#' @param active Whether the item is active or not at start.
#'
#' @rdname carousel
#'
#' @export
bs4CarouselItem <- function(..., caption = NULL, active = FALSE) {
shiny::tags$div(
class = if (active) "carousel-item active" else "carousel-item",
...,
if (!is.null(caption)) {
shiny::tags$div(class = "carousel-caption", caption)
}
)
}
#' AdminLTE3 progress bar
#'
#' Create a Bootstrap 4 progress bar.
#'
#' @param value Progress bar value.
#' @param min Progress bar minimum value.
#' @param max Progress bar maximum value.
#' @param vertical Whether to display the progress bar in vertical mode. FALSE by default.
#' @param striped Whether the progress bar is striped or not. FALSE by default.
#' @param animated Whether to animate the progress bar. Default to FALSE.
#' @param status Progress bar status. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @param size Progress bar size. NULL, "sm", "xs" or "xxs".
#' @param label Progress label. NULL by default.
#'
#' @md
#' @details For `multiProgressBar()`, `value` can be a vector which
#' corresponds to the progress for each segment within the progress bar.
#' If supplied, `striped`, `animated`, `status`, and `label` must be the
#' same length as `value` or length 1, in which case vector recycling is
#' used.
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' box(
#' title = "Horizontal",
#' progressBar(
#' value = 10,
#' striped = TRUE,
#' animated = TRUE
#' ),
#' progressBar(
#' value = 50,
#' status = "warning",
#' size = "xs"
#' ),
#' progressBar(
#' value = 20,
#' status = "danger",
#' size = "sm"
#' ),
#' multiProgressBar(
#' value = c(50, 20),
#' status = c("warning", "danger"),
#' size = "sm"
#' )
#' ),
#' box(
#' title = "Vertical",
#' progressBar(
#' value = 10,
#' striped = TRUE,
#' animated = TRUE,
#' vertical = TRUE
#' ),
#' progressBar(
#' value = 50,
#' status = "warning",
#' size = "xs",
#' vertical = TRUE
#' ),
#' progressBar(
#' value = 20,
#' status = "danger",
#' size = "sm",
#' vertical = TRUE
#' ),
#' multiProgressBar(
#' value = c(50, 20),
#' status = c("warning", "danger"),
#' size = "sm",
#' vertical = TRUE
#' )
#' )
#' ),
#' title = "Progress bars"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname progress
#'
#' @export
bs4ProgressBar <- function (value, min = 0, max = 100, vertical = FALSE, striped = FALSE,
animated = FALSE, status = "primary", size = NULL,
label = NULL) {
if (!is.null(status)) validateStatusPlus(status)
stopifnot(value >= min)
stopifnot(value <= max)
# wrapper class
progressCl <- if (isTRUE(vertical)) "progress vertical" else "progress mb-3"
if (!is.null(size)) progressCl <- paste0(progressCl, " progress-", size)
# bar class
barCl <- "progress-bar"
if (!is.null(status)) barCl <- paste0(barCl, " bg-", status)
if (striped) barCl <- paste0(barCl, " progress-bar-striped")
if (animated) barCl <- paste0(barCl, " progress-bar-animated")
# wrapper
barTag <- shiny::tags$div(
class = barCl,
role = "progressbar",
`aria-valuenow` = value,
`aria-valuemin` = min,
`aria-valuemax` = max,
style = if (vertical) {
paste0("height: ", paste0(value, "%"))
}
else {
paste0("width: ", paste0(value, "%"))
},
if(!is.null(label)) label
)
progressTag <- shiny::tags$div(class = progressCl)
progressTag <- shiny::tagAppendChild(progressTag, barTag)
progressTag
}
#' @rdname progress
#' @export
bs4MultiProgressBar <-
function(
value,
min = 0,
max = 100,
vertical = FALSE,
striped = FALSE,
animated = FALSE,
status = "primary",
size = NULL,
label = NULL
) {
status <- verify_compatible_lengths(value, status)
striped <- verify_compatible_lengths(value, striped)
animated <- verify_compatible_lengths(value, animated)
if (!is.null(label)) label <- verify_compatible_lengths(value, label)
if (!is.null(status)) lapply(status, function(x) validateStatusPlus(x))
stopifnot(all(value >= min))
stopifnot(all(value <= max))
stopifnot(sum(value) <= max)
bar_segment <- function(value, striped, animated, status, label) {
# bar class
barCl <- "progress-bar"
if (!is.null(status)) barCl <- paste0(barCl, " bg-", status)
if (striped) barCl <- paste0(barCl, " progress-bar-striped")
if (animated) barCl <- paste0(barCl, " progress-bar-animated")
shiny::tags$div(
class = barCl,
role = "progressbar",
`aria-valuenow` = value,
`aria-valuemin` = min,
`aria-valuemax` = max,
style = if (vertical) {
paste0("height: ", paste0(value, "%"))
}
else {
paste0("width: ", paste0(value, "%"))
},
if(!is.null(label)) label
)
}
barSegs <- list()
# progress bar segments
for (i in seq_along(value)) {
barSegs[[i]] <-
bar_segment(
value[[i]],
striped[[i]],
animated[[i]],
status[[i]],
label[[i]]
)
}
# wrapper class
progressCl <- if (isTRUE(vertical)) "progress vertical" else "progress mb-3"
if (!is.null(size)) progressCl <- paste0(progressCl, " progress-", size)
progressTag <- shiny::tags$div(class = progressCl)
progressTag <- shiny::tagAppendChild(progressTag, barSegs)
progressTag
}
verify_compatible_lengths <- function(x, y) {
if (length(x) == length(y)) return(y)
else if (length(y) == 1) return(rep(y, length(x)))
else {
name_x <- deparse(substitute(x))
name_y <- deparse(substitute(y))
error_msg <-
paste0("`", name_x, "` and `", name_y, "` must have compatible sizes. `",
name_y, "` must be size ", length(x), " or 1.")
stop(error_msg)
}
}
#' Create a Bootstrap 4 callout
#'
#' AdminLTE3 callout
#'
#' @param ... Callout content.
#' @param title Callout title.
#' @param status Callout status. Valid statuses:
#' \itemize{
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' }
#' @param width Callout width. Between 1 and 12.
#' @param elevation Callout elevation.
#'
#' @rdname callout
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "Callout",
#' body = bs4DashBody(
#' title = "Callouts",
#' callout(
#' title = "I am a danger callout!",
#' elevation = 4,
#' status = "danger",
#' "There is a problem that we need to fix.
#' A wonderful serenity has taken possession of
#' my entire soul, like these sweet mornings of
#' spring which I enjoy with my whole heart."
#' ),
#' callout(
#' title = "I am a danger callout!",
#' status = "warning",
#' "This is a yellow callout."
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
bs4Callout <- function(..., title, status = c("warning", "danger", "info", "success"),
width = 6, elevation = NULL) {
validateStatus(status)
status <- match.arg(status)
calloutCl <- "callout"
if (!is.null(status)) calloutCl <- paste0(calloutCl, " callout-", status)
if (!is.null(elevation)) calloutCl <- paste0(calloutCl, " elevation-", elevation)
calloutTag <- shiny::tags$div(
class = calloutCl,
shiny::tags$h5(title),
...
)
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
calloutTag
)
}
#' @title AdminLTE3 loading state element
#'
#' @description When a section is still work in progress or a computation is running
#'
#' @note Loading state can be programmatically used when a conputation is running for instance.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @rdname loading
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "loading spinner",
#' loadingState()
#' )
#' ),
#' title = "Loading State"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
bs4Loading <- function() {
shiny::tags$div(
class = "overlay",
shiny::tags$i(class = "fa fa-refresh fa-spin")
)
}
#' AdminLTE3 timeline block
#'
#' \link{timelineBlock} creates a timeline block that may be inserted in a \link{box} or outside.
#'
#' @param ... slot for \link{bs4TimelineLabel} or \link{bs4TimelineItem}.
#' @param reversed Whether the timeline is reversed or not.
#' @param width Timeline width. Between 1 and 12.
#'
#' @note reversed is useful when the user wants to use the timeline
#' inside a box.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname timeline
#' @family boxWidgets
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = bs4DashPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "test",
#' body = dashboardBody(
#' box(
#' title = "Timeline",
#' timelineBlock(
#' width = 12,
#' reversed = TRUE,
#' timelineEnd(color = "danger"),
#' timelineLabel("10 Feb. 2014", color = "pink"),
#' timelineItem(
#' elevation = 4,
#' title = "Item 1",
#' icon = icon("gears"),
#' color = "olive",
#' time = "now",
#' footer = "Here is the footer",
#' "This is the body"
#' ),
#' timelineItem(
#' title = "Item 2",
#' border = FALSE
#' ),
#' timelineLabel("3 Jan. 2014", color = "lightblue"),
#' timelineItem(
#' elevation = 2,
#' title = "Item 3",
#' icon = icon("paint-brush"),
#' status = "orange",
#' timelineItemMedia(image = "https://via.placeholder.com/150x100"),
#' timelineItemMedia(image = "https://via.placeholder.com/150x100")
#' ),
#' timelineStart(color = "secondary")
#' )
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
bs4Timeline <- function(..., reversed = TRUE, width = 6) {
cl <- "timeline"
if (isTRUE(reversed)) cl <- paste0(cl, " timeline-inverse")
timelineTag <- shiny::tags$div(
class = cl,
...
)
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
timelineTag
)
}
#' AdminLTE3 timeline label
#'
#' \link{timelineLabel} creates a timeline label element to highlight an event.
#'
#' @param ... Any element.
#' @param color Label color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @rdname timeline
#'
#' @export
bs4TimelineLabel <- function(..., color = NULL) {
cl <- NULL
if (!is.null(color)) {
validateStatusPlus(color)
cl <- paste0("bg-", color)
}
shiny::tags$div(
class = "time-label",
shiny::tags$span(
class = cl,
...
)
)
}
#' AdminLTE3 timeline item
#'
#' \link{timelineItem} creates a timeline item that contains information for a
#' given event like the title, description, date, ...
#'
#' @param ... Any element such as \link{timelineItemMedia} ...
#' @param icon Item icon. Expect \code{\link[shiny]{icon}}.
#' @param color Item color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @param time Item date or time.
#' @param title Item title.
#' @param border Whether to display a border between the header and the body. TRUE by default.
#' @param footer Item footer if any.
#' @param elevation Timeline elevation (numeric). NULL by default.
#'
#' @rdname timeline
#'
#' @export
bs4TimelineItem <- function(..., icon = NULL,
color = NULL, time = NULL, title = NULL,
border = TRUE, footer = NULL, elevation = NULL) {
if (!is.null(color)) {
validateStatusPlus(color)
icon$attribs$class <- paste0(icon$attribs$class, " bg-", color)
}
if (!is.null(elevation)) {
icon$attribs$class <- paste0(icon$attribs$class, " elevation-", elevation)
}
itemCl <- "timeline-header no-border"
if (isTRUE(border)) itemCl <- "timeline-header"
shiny::tags$div(
# timelineItem icon and status
icon,
# timelineItem container
shiny::tags$div(
class = "timeline-item",
#timelineItem time/date
shiny::tags$span(
class = "time",
shiny::icon("clock"),
time
),
# timelineItem title
shiny::tags$h3(
class = if (!is.null(elevation)) {
paste0(itemCl, " elevation-", elevation)
} else {
itemCl
},
title
),
# timelineItem body
shiny::tags$div(
class = "timeline-body",
...
),
# timelineItem footer
shiny::tags$div(
class = "timeline-footer",
footer
)
)
)
}
#' AdminLTE2 timeline media item
#'
#' \link{timelineItemMedia} create a specific container for images.
#'
#' @param image Media url or path.
#' @param height Media height in pixels.
#' @param width Media width in pixels.
#'
#' @rdname timeline
#'
#' @export
bs4TimelineItemMedia <- function(image = NULL, height = NULL, width = NULL) {
shiny::img(
class = "margin",
src = image,
height = height,
width = width
)
}
#' AdminLTE3 timeline starting point
#'
#' \link{timelineStart} indicates a starting point.
#'
#' @param icon Item icon such as "clock", "times", ...
#' @param color Item color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @rdname timeline
#'
#' @export
bs4TimelineStart <- function(icon = shiny::icon("clock"), color = NULL) {
iconTag <- icon
if (!is.null(color)) {
validateStatusPlus(color)
iconTag$attribs$class <- paste0(iconTag$attribs$class, " bg-", color)
}
shiny::tags$div(iconTag)
}
#' AdminLTE3 timeline ending point
#'
#' \link{timelineEnd} indicates an end point.
#'
#' @param icon Item icon such as "clock", "times", ...
#' @param color Item color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @rdname timeline
#'
#' @export
bs4TimelineEnd <- function(icon = shiny::icon("hourglass-end"), color = NULL) {
iconTag <- icon
if (!is.null(color)) {
validateStatusPlus(color)
iconTag$attribs$class <- paste0(iconTag$attribs$class, " bg-", color)
}
shiny::tagList(
shiny::tags$div(iconTag),
shiny::br(),
shiny::br()
)
}
#' @title AdminLTE3 stars
#'
#' @description Create a block of stars (ideal for rating)
#'
#' @param value Current value. Should be positive and lower or equal to max.
#' @param max Maximum number of stars by block.
#' @param color Star color. Valid colors are listed below:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @rdname stars
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Star example",
#' starBlock(5),
#' starBlock(5, color = "fuchsia"),
#' starBlock(1, color = "danger"),
#' starBlock(3, color = "secondary")
#' )
#' ),
#' title = "starBlock"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
bs4Stars <- function(value, max = 5, color = "warning") {
stopifnot(!is.null(color))
validateStatusPlus(color)
stopifnot(!is.null(value))
stopifnot(value >= 0)
stopifnot(value <= max)
shiny::tags$td(
class = "mailbox-star",
shiny::tags$a(
href = "javascript:void(0)",
if (value > 0) {
full_star <- lapply(seq_len(value), FUN = function(i) {
shiny::tags$i(class = paste0("fa text-", color, " fa-star"))
})
},
if (value < max) {
empty_star <- lapply(seq_len(max - value), FUN = function(i) {
shiny::tags$i(class = paste0("fa text-", color, " fa-star-o"))
})
}
),
shiny::tags$br()
)
}
#' @title BS4 jumbotron for AdminLTE3
#'
#' @description Create a jumbotron
#'
#' @param ... Any content.
#' @param title Jumbotron title.
#' @param lead Jumbotron lead.
#' @param href Jumbrotron external link.
#' @param btnName Jumbotron button name.
#' @param status Jumbotron background color. "primary", "success", "warning", "danger" or "info".
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname jumbotron
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "Jumbotron",
#' body = dashboardBody(
#' jumbotron(
#' title = "Hello, world!",
#' lead = "This is a simple hero unit, a simple jumbotron-style
#' component for calling extra attention to featured
#' content or information.",
#' "It uses utility classes for typography and spacing
#' to space content out within the larger container.",
#' status = "primary",
#' href = "https://www.google.com"
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
bs4Jumbotron <- function(..., title = NULL, lead = NULL, href = NULL, btnName = "More",
status = c("primary", "warning", "danger", "info", "success")) {
status <- match.arg(status)
# uncomment below if more status are enabled
#if (status == "dark") btnStatus <- "gray" else btnStatus <- "dark"
btnStatus <- "secondary"
jumboCl <- "jumbotron"
if (!is.null(status)) jumboCl <- paste0(jumboCl, " bg-", status)
# no need to wrap this tag in an external div to set a custom width
# since the jumbotron will take the whole page width
shiny::tags$div(
class = jumboCl,
shiny::tags$h1(class = "display-4", title),
shiny::tags$p(class = "lead", lead),
shiny::tags$hr(class = "my-4"),
shiny::tags$p(...),
if (!is.null(btnName)) {
shiny::tags$a(
class = paste0("btn btn-", btnStatus, " btn-lg"),
href = href,
target = "_blank",
role = "button",
btnName
)
}
)
}
#' @title BS4 list group for AdminLTE3
#'
#' @description Create a list group
#'
#' @param ... Slot for \link{listGroupItem}.
#' @param type List group type.
#' @param width List group width. 4 by default. Between 1 and 12.
#' @param .list Slot for programmatically generated items.
#'
#' @rdname listgroup
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "test",
#' body = dashboardBody(
#' fluidRow(
#' listGroup(
#' type = "basic",
#' listGroupItem("Cras justo odio"),
#' listGroupItem("Dapibus ac facilisis in"),
#' listGroupItem("Morbi leo risus")
#' ),
#' listGroup(
#' type = "action",
#' listGroupItem(
#' "Cras justo odio",
#' active = TRUE,
#' disabled = FALSE,
#' href = "https://www.google.com"
#' ),
#' listGroupItem(
#' active = FALSE,
#' disabled = FALSE,
#' "Dapibus ac facilisis in",
#' href = "https://www.google.com"
#' ),
#' listGroupItem(
#' "Morbi leo risus",
#' active = FALSE,
#' disabled = TRUE,
#' href = "https://www.google.com"
#' )
#' ),
#' listGroup(
#' type = "heading",
#' listGroupItem(
#' "Donec id elit non mi porta gravida at eget metus.
#' Maecenas sed diam eget risus varius blandit.",
#' active = TRUE,
#' disabled = FALSE,
#' title = "List group item heading",
#' subtitle = "3 days ago",
#' footer = "Donec id elit non mi porta."
#' ),
#' listGroupItem(
#' "Donec id elit non mi porta gravida at eget metus.
#' Maecenas sed diam eget risus varius blandit.",
#' active = FALSE,
#' disabled = FALSE,
#' title = "List group item heading",
#' subtitle = "3 days ago",
#' footer = "Donec id elit non mi porta."
#' )
#' )
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
bs4ListGroup <- function(..., type = c("basic", "action", "heading"), width = 4,
.list = NULL) {
items <- c(list(...), .list)
type <- match.arg(type)
# item class depends on selected type
itemCl <- switch(
type,
"basic" = "list-group-item d-flex justify-content-between align-items-center",
"action" = "list-group-item list-group-item-action",
"heading" = "list-group-item list-group-item-action flex-column align-items-start"
)
# build items based on type and options passed
itemsTag <- lapply(items, function(item) {
names(item)[1] <- "body"
if (item$active) itemCl <- paste0(itemCl, " active")
if (item$disabled) itemCl <- paste0(itemCl, " disabled")
# item tag
if (type == "basic") {
shiny::tags$li(
class = itemCl,
item$body
)
} else if (type == "action") {
shiny::tags$a(
class = itemCl,
href = item$href,
target = if (!is.null(item$href)) "_blank",
item$body
)
} else {
shiny::tags$a(
class = itemCl,
href = item$href,
target = if (!is.null(item$href)) "_blank",
shiny::tags$div(
class = "d-flex w-100 justify-content-between",
shiny::tags$h5(class = "mb-1", item$title),
if (!is.null(item$subtitle)) {
shiny::tags$small(item$subtitle)
}
),
shiny::tags$p(class = "mb-1", item$body),
if (!is.null(item$footer)) {
shiny::tags$small(class = if (item$active) NULL else "text-muted", item$footer)
}
)
}
})
listGroupTag <- shiny::tags$ul(
class = "list-group",
itemsTag
)
shiny::tags$div(
class = if (!is.null(width)) paste0("col-sm-", width),
listGroupTag
)
}
#' @title BS4 list group item for AdminLTE3
#'
#' @description Create a list group item
#'
#' @param ... Item content.
#' @param title Item title (only if type is "heading").
#' @param subtitle Item subtitle (only if type is "heading").
#' @param footer Item footer content (only if type is "heading").
#' @param active Whether the item is active or not. FALSE by default.
#' Only if type is "action" or "heading".
#' @param disabled Whether the item is disabled or not. FALSE by default.
#' Only if type is "action" or "heading".
#' @param href Item external link.
#'
#'
#' @rdname listgroup
#'
#' @export
bs4ListGroupItem <- function(..., title = NULL, subtitle = NULL,
footer = NULL, active = FALSE, disabled = FALSE,
href = NULL) {
if (active && disabled) {
stop("active and disabled cannot be TRUE at the same time!")
}
list(
body = ...,
title = title,
subtitle = subtitle,
footer = footer,
active = active,
disabled = disabled,
href = href
)
}
#' @title BS4 ionicons
#'
#' @description Create a ionicon.
#'
#' @param name Name of icon. See \url{https://ionic.io/ionicons/}.
#'
#' @note Similar to the icon function from shiny.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "Ionicons",
#' body = dashboardBody(
#' ionicon(name ="heart"),
#' ionicon(name ="beer")
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
ionicon <- function(name) {
if (is.null(name)) stop("Missing icon name")
cl <- paste0("icon ion-md-", name)
shiny::tags$i(class = cl)
}
#' AdminLTE3 attachment container
#'
#' \link{attachmentBlock} create an attachment container, nice to wrap articles...
#' and insert in a \link{box}.
#'
#' @param ... Any element.
#' @param image url or path to the image.
#' @param title Attachment title.
#' @param href External link.
#'
#' @family boxWidgets
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "attachmentBlock example",
#' attachmentBlock(
#' image = "https://adminlte.io/themes/v3/dist/img/user1-128x128.jpg",
#' title = "Test",
#' href = "https://google.com",
#' "This is the content"
#' )
#' )
#' ),
#' title = "attachmentBlock"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
attachmentBlock <- function(..., image, title = NULL, href = NULL) {
shiny::tags$div(
class = "attachment-block clearfix",
shiny::img(
class = "attachment-img",
src = image
),
shiny::tags$div(
class = "attachment-pushed",
if (!is.null(title)) {
shiny::tags$h4(
class = "attachment-heading",
shiny::tags$a(
href = if (!is.null(href)) {
href
} else {
"#"
},
target = if (!is.null(href)) {
"_blank"
},
title
)
)
},
shiny::tags$div(
class = "attachment-text",
...
)
)
)
}
#' AdminLTE3 description block
#'
#' \link{descriptionBlock} creates a description block, perfect for writing statistics
#' to insert in a \link{box}.
#'
#' @param number Any number.
#' @param numberColor Number color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @param numberIcon Number icon, if any. Expect \code{\link[shiny]{icon}}.
#' @param header Bold text.
#' @param text Additional text.
#' @param rightBorder TRUE by default. Whether to display a right border to
#' separate two blocks. The last block on the right should not have a right border.
#' @param marginBottom FALSE by default. Set it to TRUE when the
#' descriptionBlock is used in a \link{boxPad} context.
#'
#' @rdname box
#' @family boxWidgets
#'
#' @examples
#' # Box with descriptionBlock
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' solidHeader = FALSE,
#' title = "Status summary",
#' background = NULL,
#' width = 4,
#' status = "danger",
#' footer = fluidRow(
#' column(
#' width = 6,
#' descriptionBlock(
#' number = "17%",
#' numberColor = "pink",
#' numberIcon = icon("caret-up"),
#' header = "$35,210.43",
#' text = "TOTAL REVENUE",
#' rightBorder = TRUE,
#' marginBottom = FALSE
#' )
#' ),
#' column(
#' width = 6,
#' descriptionBlock(
#' number = "18%",
#' numberColor = "secondary",
#' numberIcon = icon("caret-down"),
#' header = "1200",
#' text = "GOAL COMPLETION",
#' rightBorder = FALSE,
#' marginBottom = FALSE
#' )
#' )
#' )
#' )
#' ),
#' title = "Description Blocks"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
descriptionBlock <- function(number = NULL, numberColor = NULL, numberIcon = NULL,
header = NULL, text = NULL, rightBorder = TRUE,
marginBottom = FALSE) {
cl <- "description-block"
if (rightBorder) cl <- paste0(cl, " border-right")
if (marginBottom) cl <- paste0(cl, " mb-4")
numcl <- "description-percentage"
if (!is.null(numberColor)) {
validateStatusPlus(numberColor)
numcl <- paste0(numcl, " text-", numberColor)
}
shiny::tags$div(
class = cl,
shiny::tags$span(
class = numcl,
number,
if (!is.null(numberIcon)) numberIcon
),
shiny::tags$h5(class = "description-header", header),
shiny::tags$span(class = "description-text", text)
)
}
#' AdminLTE3 vertical block container
#'
#' \link{boxPad} creates a vertical container for \link{descriptionBlock}.
#' It has to be included in a \link{box}.
#'
#' @param ... Any element such as \link{descriptionBlock}.
#' @param color Background color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @param style Custom CSS, if any.
#'
#' @rdname box
#' @family boxWidgets
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Box with right pad",
#' status = "warning",
#' fluidRow(
#' column(width = 6),
#' column(
#' width = 6,
#' boxPad(
#' color = "purple",
#' descriptionBlock(
#' header = "8390",
#' text = "VISITS",
#' rightBorder = FALSE,
#' marginBottom = TRUE
#' ),
#' descriptionBlock(
#' header = "30%",
#' text = "REFERRALS",
#' rightBorder = FALSE,
#' marginBottom = TRUE
#' ),
#' descriptionBlock(
#' header = "70%",
#' text = "ORGANIC",
#' rightBorder = FALSE,
#' marginBottom = FALSE
#' )
#' )
#' )
#' )
#' )
#' ),
#' title = "boxPad"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
cardPad <- function(..., color = NULL, style = NULL) {
cl <- "card-pane-right pt-2 pb-2 pl-4 pr-4"
if (!is.null(color)) {
validateStatusPlus(color)
cl <- paste0(cl, " bg-", color)
}
shiny::tags$div(
class = cl,
style = style,
...
)
}
#' AdminLTE3 product list container
#'
#' \link{productList} creates a container to display commercial items in an elegant container.
#' Insert in a \link{box}.
#'
#' @param ... slot for \link{productListItem}.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname productList
#'
#' @examples
#'
#' # Box with productList
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Product List",
#' status = "primary",
#' productList(
#' productListItem(
#' image = "https://www.pngmart.com/files/1/Haier-TV-PNG.png",
#' title = "Samsung TV",
#' subtitle = "$1800",
#' color = "warning",
#' "This is an amazing TV, but I don't like TV!"
#' ),
#' productListItem(
#' image = "https://upload.wikimedia.org/wikipedia/commons/7/77/IMac_Pro.svg",
#' title = "Imac 27",
#' subtitle = "$4999",
#' color = "danger",
#' "This is were I spend most of my time!"
#' )
#' )
#' )
#' ),
#' title = "Product List"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
productList <- function(...) {
shiny::tags$ul(
class = "products-list product-list-in-card pl-2 pr-2",
...
)
}
#' AdminLTE3 product item
#'
#' \link{productListItem} creates a product item to insert in \link{productList}.
#'
#' @param ... product description.
#' @param image image url, if any.
#' @param title product name.
#' @param subtitle product price.
#' @param color price color. Valid color are listed below:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' }
#' @rdname productList
#'
#' @export
productListItem <- function(..., image = NULL, title = NULL,
subtitle = NULL, color = NULL) {
cl <- "badge float-right"
if (!is.null(color)) {
validateStatus(color)
cl <- paste0(cl, " badge-", color)
}
shiny::tags$li(
class = "item",
shiny::tags$div(
class = "product-img",
shiny::tags$img(src = image, alt = "Product Image")
),
shiny::tags$div(
class = "product-info",
shiny::tags$a(
href = "javascript:void(0)",
class = "product-title",
title,
if (!is.null(subtitle)) shiny::tags$span(class = cl, subtitle)
),
shiny::tags$span(
class = "product-description",
...
)
)
)
}
#' AdminLTE3 user list container
#'
#' \link{userList} creates a user list container to be inserted in a \link{box}.
#'
#' @param ... slot for \link{userListItem}.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname userList
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "User List example",
#' status = "success",
#' userList(
#' userListItem(
#' image = "https://adminlte.io/themes/v3/dist/img/user1-128x128.jpg",
#' title = "Shiny",
#' subtitle = "Package 1"
#' ),
#' userListItem(
#' image = "https://adminlte.io/themes/v3/dist/img/user8-128x128.jpg",
#' title = "Tidyverse",
#' subtitle = "Package 2"
#' ),
#' userListItem(
#' image = "https://adminlte.io/themes/v3/dist/img/user7-128x128.jpg",
#' title = "tidyr",
#' subtitle = "Package 3"
#' )
#' )
#' )
#' ),
#' title = "User List"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
userList <- function(...) {
shiny::tags$ul(
class = "users-list clearfix",
...
)
}
#' AdminLTE3 user list item
#'
#' \link{userListItem} creates a user list item.
#'
#' @param image image url or path.
#' @param title Item title.
#' @param subtitle Item subtitle.
#'
#' @rdname userList
#'
#' @export
userListItem <- function(image, title, subtitle = NULL) {
shiny::tags$li(
shiny::tags$img(
src = image,
alt = "User Image",
shiny::tags$a(class = "users-list-name", title),
if (!is.null(subtitle)) {
shiny::tags$span(class = "users-list-date", subtitle)
}
)
)
}
#' AdminLTE3 user message container
#'
#' \link{userMessages} creates a user message container. Maybe inserted in a \link{box}.
#'
#' @param ... Slot for \link{userMessage}.
#' @param id Optional. To use with \link{updateUserMessages}.
#' @param status Messages status. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @param width Container width: between 1 and 12.
#' @param height Container height.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname userMessage
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Box with messages",
#' solidHeader = TRUE,
#' status = "warning",
#' userMessages(
#' width = 12,
#' status = "teal",
#' userMessage(
#' author = "Alexander Pierce",
#' date = "20 Jan 2:00 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user1-128x128.jpg",
#' type = "sent",
#' "Is this template really for free? That's unbelievable!"
#' ),
#' userMessage(
#' author = "Sarah Bullock",
#' date = "23 Jan 2:05 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user3-128x128.jpg",
#' type = "received",
#' "You better believe it!"
#' )
#' )
#' ),
#' userMessages(
#' width = 6,
#' status = "danger",
#' userMessage(
#' author = "Alexander Pierce",
#' date = "20 Jan 2:00 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user1-128x128.jpg",
#' type = "received",
#' "Is this template really for free? That's unbelievable!"
#' ),
#' userMessage(
#' author = "Sarah Bullock",
#' date = "23 Jan 2:05 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user3-128x128.jpg",
#' type = "sent",
#' "You better believe it!"
#' )
#' )
#' ),
#' title = "user Message"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
userMessages <- function(..., id = NULL, status, width = 4, height = NULL) {
cl <- "direct-chat-messages direct-chat"
if (!is.null(height)) shiny::validateCssUnit(height)
if (!is.null(status)) {
validateStatusPlus(status)
cl <- paste0(cl, " direct-chat-", status)
}
msgtag <- shiny::tags$div(
class = cl,
...,
style = if (!is.null(height)) {
sprintf("height: %s; overflow-y: auto;", height)
} else {
"height: 100%;"
}
)
shiny::tags$div(
id = id,
class = if (!is.null(width)) paste0("col-sm-", width),
msgtag
)
}
#' AdminLTE3 user message
#'
#' \link{userMessage} creates a user message html element.
#'
#' @param ... Message text.
#' @param author Message author.
#' @param date Message date.
#' @param image Message author image path or url.
#' @param type Message type: \code{c("sent", "received")}.
#'
#' @rdname userMessage
#'
#' @export
userMessage <- function(..., author = NULL, date = NULL,
image = NULL, type = c("sent", "received")) {
type <- match.arg(type)
messageCl <- "direct-chat-msg"
if (type == "sent") messageCl <- paste0(messageCl, " right")
# message info
messageInfo <- shiny::tags$div(
class = "direct-chat-info clearfix",
shiny::tags$span(
class = if (type == "right") {
"direct-chat-name float-right"
} else {
"direct-chat-name"
},
author
),
if (!is.null(date)) {
shiny::tags$span(
class = if (type == "right") {
"direct-chat-timestamp float-right"
} else {
"direct-chat-timestamp"
},
date
)
}
)
# message Text
messageTxt <- shiny::tags$div(class = "direct-chat-text", ...)
# message author image
messageImg <- shiny::tags$img(class = "direct-chat-img", src = image)
shiny::tags$div(
class = messageCl,
messageInfo,
messageImg,
messageTxt
)
}
#' Update a messages container in the server side
#'
#' \link{updateUserMessages} allows to interact with a \link{userMessages} container,
#' such as sending, removing or editing messages.
#'
#' @param id \link{userMessages} to target.
#' @param action Action to perform: add, remove or update.
#' @param index Index of item to update or remove.
#' @param content New message content in a list. For actions like add and update only! See example.
#' @param session Shiny session object.
#' @export
#' @rdname userMessage
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' fluidRow(
#' actionButton("remove", "Remove message"),
#' actionButton("add", "Add message"),
#' actionButton("update", "Update message")
#' ),
#' numericInput("index", "Message index:", 1, min = 1, max = 3),
#' br(),
#' br(),
#' userMessages(
#' width = 6,
#' status = "danger",
#' id = "message",
#' userMessage(
#' author = "Alexander Pierce",
#' date = "20 Jan 2:00 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user1-128x128.jpg",
#' type = "received",
#' "Is this template really for free? That's unbelievable!"
#' ),
#' userMessage(
#' author = "Sarah Bullock",
#' date = "23 Jan 2:05 pm",
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user3-128x128.jpg",
#' type = "sent",
#' "You better believe it!"
#' )
#' )
#' ),
#' title = "user Message"
#' ),
#' server = function(input, output, session) {
#' observeEvent(input$remove, {
#' updateUserMessages("message", action = "remove", index = input$index)
#' })
#' observeEvent(input$add, {
#' updateUserMessages(
#' "message",
#' action = "add",
#' content = list(
#' author = "David",
#' date = "Now",
#' image = "https://i.pinimg.com/originals/f1/15/df/f115dfc9cab063597b1221d015996b39.jpg",
#' type = "received",
#' text = tagList(
#' sliderInput(
#' "obs",
#' "Number of observations:",
#' min = 0,
#' max = 1000,
#' value = 500
#' ),
#' plotOutput("distPlot")
#' )
#' )
#' )
#' })
#'
#' output$distPlot <- renderPlot({
#' hist(rnorm(input$obs))
#' })
#'
#' observeEvent(input$update, {
#' updateUserMessages(
#' "message",
#' action = "update",
#' index = input$index,
#' content = list(
#' text = tagList(
#' appButton(
#' inputId = "reload",
#' label = "Click me!",
#' icon = icon("arrows-rotate"),
#' dashboardBadge(1, color = "primary")
#' )
#' )
#' )
#' )
#' })
#'
#' observeEvent(input$reload, {
#' showNotification("Yeah!", duration = 1, type = "default")
#' })
#' }
#' )
#' }
updateUserMessages <- function(id, action = c("add", "remove", "update"),
index = NULL, content = NULL,
session = shiny::getDefaultReactiveDomain()) {
action <- match.arg(action)
content <- lapply(content, function(c) {
if (inherits(c, "shiny.tag") || inherits(c, "shiny.tag.list")) {
# necessary if the user pass input/output with deps
# that are not yet available in the page before inserting the new tag
c <- htmltools::renderTags(c)
}
c
})
session$sendCustomMessage(
"user-messages",
list(
id = id,
action = action,
index = index,
body = content
)
)
}
#' AdminLTE3 user post
#'
#' Creates a user post. This content may be inserted in a \link{box}.
#'
#' @param ... Post content, slot for \link{userPostTagItems}, \link{userPostMedia}.
#' @param id Unique id of the post.
#' @param image Profile image, if any.
#' @param author Post author.
#' @param description Post description.
#' @param collapsible If TRUE, display a button in the upper right that allows the user to collapse the comment.
#' @param collapsed Whether the comment is collapsed when the application starts, FALSE by default.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname userPost
#' @family boxWidgets
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' dashboardHeader(),
#' dashboardSidebar(),
#' dashboardBody(
#' box(
#' title = "Box with user comment",
#' status = "primary",
#' userPost(
#' id = 1,
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user1-128x128.jpg",
#' author = "Jonathan Burke Jr.",
#' description = "Shared publicly - 7:30 PM today",
#' "Lorem ipsum represents a long-held tradition for designers,
#' typographers and the like. Some people hate it and argue for
#' its demise, but others ignore the hate as they create awesome
#' tools to help create filler text for everyone from bacon
#' lovers to Charlie Sheen fans.",
#' collapsible = FALSE,
#' userPostTagItems(
#' userPostTagItem(dashboardBadge("item 1", color = "info")),
#' userPostTagItem(dashboardBadge("item 2", color = "danger"), side = "right")
#' )
#' ),
#' userPost(
#' id = 2,
#' image = "https://adminlte.io/themes/AdminLTE/dist/img/user6-128x128.jpg",
#' author = "Adam Jones",
#' userPostMedia(image = "https://adminlte.io/themes/AdminLTE/dist/img/photo2.png"),
#' userPostTagItems(
#' userPostTagItem(dashboardBadge("item 1", color = "success")),
#' userPostTagItem(dashboardBadge("item 2", color = "danger"), side = "right")
#' )
#' )
#' )
#' ),
#' title = "userPost"
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#' @export
userPost <- function(..., id = NULL, image, author,
description = NULL, collapsible = TRUE,
collapsed = FALSE) {
id <- paste0("post-", id)
btnCl <- "btn-tool float-right"
# if the input tag is an image, it is better to center it...
items <- list(...)
items <- lapply(seq_along(items), function(i) {
# do not apply to other things than tags
if (inherits(items[[i]], "shiny.tag")) {
if (items[[i]]$name == "img") {
# wrap the image item in a div to align its content
shiny::tags$div(
style = "text-align: center;",
items[[i]]
)
} else {
items[[i]]
}
} else {
items[[i]]
}
})
shiny::tags$div(
class = "post",
shiny::tags$div(
class = "user-block",
shiny::img(class = "img-circle img-bordered-sm", src = image),
shiny::tags$span(
class = "username",
author,
# box tool
if (collapsible) {
shiny::tags$a(
class = btnCl,
`data-toggle` = "collapse",
`data-target` = paste0("#", id),
`aria-expanded` = tolower(!collapsed),
`aria-controls` = id,
if (collapsed) {
shiny::tags$i(class = "fa fa-plus")
} else {
shiny::tags$i(class = "fa fa-minus")
}
)
}
),
if (!is.null(description)) {
shiny::tags$span(class = "description", description)
}
),
shiny::tags$div(
class = if (collapsible) {
if (!collapsed) {
"collapse show"
} else {
"collapse"
}
},
id = id,
items
)
)
}
#' AdminLTE3 user post tool item container
#'
#' \link{userPostTagItems} creates a container to host \link{userPostTagItem}.
#'
#' @param ... Slot for \link{userPostTagItem}.
#'
#' @rdname userPost
#'
#' @export
userPostTagItems<- function(...) {
shiny::tags$ul(
class = "list-inline d-flex",
...
)
}
#' AdminLTE3 user post tool item
#'
#' \link{userPostTagItem} creates a user post tool item
#'
#' @param ... Tool content such as label, button, ...
#'
#' @rdname userPost
#'
#' @export
userPostTagItem <- function(...) {
shiny::tags$li(
class = "mx-2",
...
)
}
#' AdminLTE3 user post media
#'
#' \link{userPostMedia} creates a container to include an image in \link{userPost}.
#'
#' @param image Image path or url ...
#' @param height Media height in pixels.
#' @param width Media width in pixels.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
userPostMedia <- function(image, height = NULL, width = NULL) {
shiny::img(
style = "margin: auto;",
class = "img-fluid",
src = image,
height = height,
width = width
)
}
#' @title BS4 sortable section
#'
#' @description Create a sortable UI section
#'
#' @param ... Slot for UI elements such as \link{box}.
#' @param width Section width: between 1 and 12.
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname sortable
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' controlbar = dashboardControlbar(),
#' footer = dashboardFooter(),
#' title = "Sortable UI",
#' body = dashboardBody(
#' fluidRow(
#' lapply(1:3, FUN = function(i) {
#' sortable(
#' width = 4,
#' p(class = "text-center", paste("Column", i)),
#' lapply(1:2, FUN = function(j) {
#' box(
#' title = paste0("I am the ", j,"-th card of the ", i, "-th column"),
#' width = 12,
#' "Click on my header"
#' )
#' })
#' )
#' })
#' )
#' )
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @export
bs4Sortable <- function(..., width = 12) {
sectionCl <- "connectedSortable ui-sortable"
if (!is.null(width)) sectionCl <- paste0(sectionCl, " col-lg-", width)
shiny::tagList(
shiny::singleton(
shiny::tags$head(
shiny::tags$script(
"$(function() {
// Make the dashboard widgets sortable Using jquery UI
$('.connectedSortable').sortable({
placeholder: 'sort-highlight',
connectWith: '.connectedSortable',
handle: '.card-header, .nav-tabs',
forcePlaceholderSize: true,
zIndex: 999999
});
$('.connectedSortable .card-header, .connectedSortable .nav-tabs-custom').css('cursor', 'move');
});
"
)
)
),
shiny::tags$section(
class = sectionCl,
...
)
)
}
#' Boostrap 4 table container
#'
#' Build an Bootstrap 4 table container
#'
#' @param data Expect dataframe, tibble or list of shiny tags... See examples.
#' @param cardWrap Whether to wrap the table in a card. FALSE by default.
#' @param headTitles Table header names. Must have the same length as the number of
#' \link{bs4TableItem} in \link{bs4TableItems}. Set "" to have an empty title field.
#' @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.
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' # width dataframe as input
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' bs4Table(
#' cardWrap = TRUE,
#' bordered = TRUE,
#' striped = TRUE,
#' iris
#' )
#' ),
#' footer = dashboardFooter()
#' ),
#' server = function(input, output) { }
#' )
#'
#' # with shiny tags as input
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' bs4Table(
#' cardWrap = TRUE,
#' bordered = TRUE,
#' striped = TRUE,
#' list(
#' list(
#' income = "$2,500 USD",
#' status = dashboardBadge(
#' "Pending",
#' position = "right",
#' color = "danger",
#' rounded = TRUE
#' ),
#' progress = progressBar(value = 50, status = "pink", size = "xxs"),
#' text = "test",
#' confirm = actionButton(
#' "go",
#' "Go"
#' )
#' ),
#' list("$2,500 USD", "NA", "NA", "test", "NA")
#' )
#' )
#' ),
#' footer = dashboardFooter()
#' ),
#' server = function(input, output) {}
#' )
#' }
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname table
#'
#' @export
bs4Table <- function(data, cardWrap = FALSE, bordered = FALSE,
striped = FALSE, width = 12) {
# handle theme
tableCl <- "table"
if (bordered) tableCl <- paste0(tableCl, " table-bordered")
if (striped) tableCl <- paste0(tableCl, " table-striped")
if (!inherits(data, "list") &&
!inherits(data, "data.frame")) {
stop("data must be a dataframe, tibble or list")
}
if (inherits(data, "data.frame")) {
# column headers
tableHead <- shiny::tags$thead(
shiny::tags$tr(
lapply(
seq_along(colnames(data)),
function(i) shiny::tags$th(colnames(data)[[i]])
)
)
)
table <- lapply(seq_len(nrow(data)), function(i) {
bs4TableItems(
lapply(seq_len(ncol(data)), function(j) {
bs4TableItem(
data[i, j],
dataCell = TRUE
)
})
)
})
} 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]])
)
)
)
table <- lapply(seq_along(data), function(i) {
bs4TableItems(
lapply(seq_along(data[[i]]), function(j) {
bs4TableItem(
data[[i]][[j]],
dataCell = TRUE
)
})
)
})
}
# body rows
tableBody <- shiny::tags$tbody(table)
# table tag
tableTag <- shiny::tags$table(
class = tableCl,
tableHead,
tableBody
)
# card wrapper or not
if (cardWrap) {
shiny::column(
width = width,
shiny::tags$div(
class = "card",
shiny::tags$div(
class = "card-body",
tableTag
)
)
)
} else {
tableTag
}
}
#' Boostrap 4 table item row
#'
#' Build an bs4 table item row
#'
#' @param ... Slot for \link{tableItem}.
#'
#' @rdname table
#' @keywords internal
bs4TableItems <- function(...) {
shiny::tags$tr(...)
}
#' Bootstrap 4 table item
#'
#' Build an bs4 table item
#'
#' @param ... Any HTML element.
#' @param dataCell Whether the cell should be contain data or text. <td> by default.
#'
#' @rdname table
#' @keywords internal
bs4TableItem <- function(..., dataCell = FALSE) {
if (dataCell) {
shiny::tags$td(...)
} else {
shiny::tags$th(...)
}
}
# #' @title AdminLTE3 todo list container
# #'
# #' @description Create a todo list container
# #'
# #' @param ... slot for todoListItem.
# #' @param sortable Whether the list elements are sortable or not.
# #'
# #' @author David Granjon, \email{dgranjon@@ymail.com}
# #'
# #' @examples
# #' if (interactive()) {
# #' library(shiny)
# #' library(bs4Dash)
# #' shinyApp(
# #' ui = dashboardPage(
# #' dashboardHeader(),
# #' dashboardSidebar(),
# #' dashboardBody(
# #' box(
# #' "Sortable todo list demo",
# #' status = "warning",
# #' todoList(
# #' todoListItem(
# #' label = "Design a nice theme",
# #' "Some text here"
# #' ),
# #' todoListItem(
# #' label = "Make the theme responsive",
# #' "Some text here"
# #' ),
# #' todoListItem(
# #' checked = TRUE,
# #' label = "Let theme shine like a star"
# #' )
# #' )
# #' ),
# #' box(
# #' "Simple todo list demo",
# #' status = "warning",
# #' todoList(
# #' sortable = FALSE,
# #' todoListItem(
# #' label = "Design a nice theme",
# #' "Some text here"
# #' ),
# #' todoListItem(
# #' label = "Make the theme responsive",
# #' "Some text here"
# #' ),
# #' todoListItem(
# #' checked = TRUE,
# #' label = "Let theme shine like a star"
# #' )
# #' )
# #' )
# #' ),
# #' title = "Todo Lists"
# #' ),
# #' server = function(input, output) { }
# #' )
# #' }
# #'
# #' @export
# todoList <- function(..., sortable = TRUE) {
#
# items <- list(...)
#
# if (sortable) {
# for (i in seq_along(items)) {
# items[[i]]$children[[1]]$attribs$class <- paste(items[[i]]$children[[1]]$attribs$class, "ui-sortable-handle")
# }
# }
#
# todoListTag <- shiny::tags$ul(
# class = if (sortable) "todo-list ui-sortable" else "todo-list",
# `data-widget` = "todo-list",
# items
# )
#
# todoListTag
#
# }
#
#
#
# #' @title AdminLTE2 todo list item
# #'
# #' @description Create a todo list item
# #'
# #' @param ... any element such as labels, ...
# #' @param checked Whether the list item is checked or not.
# #' @param label item label.
# #'
# #' @author David Granjon, \email{dgranjon@@ymail.com}
# #'
# #' @export
# todoListItem <- function(..., checked = FALSE, label = NULL) {
# cl <- NULL
# if (checked) cl <- "done"
#
# shiny::tags$li(
# class = cl,
#
# # sortable icon
# shiny::tags$span(
# class = "handle",
# shiny::tags$i(class = "fa fa-ellipsis-v"),
# shiny::tags$i(class = "fa fa-ellipsis-v")
# ),
#
# # checkbox trigger
# # need to be implemented (custom binding js)
# #shiny::tags$input(type = "checkbox"),
#
# # label
# shiny::tags$span(class = "text", label),
#
# # any element
# shiny::tags$small(
# ...
# )
# )
#
# }#
#' Boostrap 4 ribbon
#'
#' \link{bs4Ribbon} build a bootstrap 4 ribbon
#'
#' @param text Ribbon text.
#' @param color Ribbon color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' fluidRow(
#' box(
#' width = 4,
#' title = "Blue ribbon",
#' bs4Ribbon(
#' text = "New",
#' color = "primary"
#' )
#' ),
#' box(
#' width = 4,
#' title = "Purple ribbon",
#' bs4Ribbon(
#' text = "New",
#' color = "indigo"
#' )
#' ),
#' box(
#' width = 4,
#' title = "Orange ribbon",
#' bs4Ribbon(
#' text = "New",
#' color = "orange"
#' )
#' )
#' )
#' ),
#' footer = dashboardFooter()
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#' @rdname ribbon
#'
#' @export
bs4Ribbon <- function(text, color) {
validateStatusPlus(color)
ribbonCl <- paste0("ribbon bg-", color)
ribbonWrapperCl <- "ribbon-wrapper"
shiny::tags$div(
class = ribbonWrapperCl,
shiny::tags$div(class = ribbonCl, text)
)
}
#' Boostrap 4 block quote
#'
#' Build a bootstrap 4 block quote
#'
#' @param ... Content.
#' @param color Block color. Valid colors are defined as follows:
#' \itemize{
#' \item \code{primary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#007bff")}.
#' \item \code{secondary}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6c757d")}.
#' \item \code{info}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#17a2b8")}.
#' \item \code{success}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#28a745")}.
#' \item \code{warning}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ffc107")}.
#' \item \code{danger}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#dc3545")}.
#' \item \code{gray-dark}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#343a40")}.
#' \item \code{gray}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#adb5bd")}.
#' \item \code{white}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#fff")}.
#' \item \code{indigo}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#6610f2")}.
#' \item \code{lightblue}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3c8dbc")}.
#' \item \code{navy}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#001f3f")}.
#' \item \code{purple}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#605ca8")}.
#' \item \code{fuchsia}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#f012be")}.
#' \item \code{pink}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#e83e8c")}.
#' \item \code{maroon}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#d81b60")}.
#' \item \code{orange}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#ff851b")}.
#' \item \code{lime}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#01ff70")}.
#' \item \code{teal}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#39cccc")}.
#' \item \code{olive}: \Sexpr[results=rd, stage=render]{bs4Dash:::rd_color_tag("#3d9970")}.
#' }
#' @rdname quote
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' fluidRow(
#' blockQuote("Blablabla", color = "indigo"),
#' blockQuote("Blablabla", color = "danger"),
#' blockQuote("Blablabla", color = "teal"),
#' blockQuote("Blablabla", color = "orange"),
#' blockQuote("Blablabla", color = "warning"),
#' blockQuote("Blablabla", color = "fuchsia")
#' )
#' ),
#' footer = dashboardFooter()
#' ),
#' server = function(input, output) { }
#' )
#' }
#'
#'
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
bs4Quote <- function(..., color) {
validateStatusPlus(color)
shiny::tags$blockquote(
class = paste0("quote-", color),
...
)
}
#' Get all AdminLTE colors.
#' @export
getAdminLTEColors <- function() {
c(validStatuses, validNuances, validColors)
}
#' Bootstrap 4 pagination widget
#'
#' See \url{https://getbootstrap.com/docs/4.0/components/pagination/}.
#'
#' @param ... Slot for \link{paginationItem}.
#' @param id Unique widget id. For programmatic update.
#' See \link{updatePagination}.
#' @param selected Which element to select at start.
#' @param align Alignment.
#' @param size Buttons size.
#' @param previousBtn Previous button text.
#' @param nextBtn Next button text.
#' @param .list Programmatically generated \link{paginationItem}.
#'
#' @rdname pagination
#'
#' @return An HTML pagination container
#' @export
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' pagination(
#' paginationItem("page1", box(title = "This is a box!")),
#' paginationItem("page2", "This is page 2", disabled = TRUE),
#' paginationItem("page3", "This is page 3", disabled = TRUE),
#' paginationItem(
#' "page4",
#' sliderInput(
#' "obs",
#' "Number of observations:",
#' min = 0,
#' max = 1000,
#' value = 500
#' ),
#' plotOutput("distPlot"),
#' icon = icon("cog")
#' )
#' )
#' )
#' ),
#' server = function(input, output, session) {
#' output$distPlot <- renderPlot({
#' hist(rnorm(input$obs))
#' })
#' }
#' )
#' }
pagination <- function(..., id = NULL, selected = NULL,
align = c("center", "left", "right"),
size = c("md", "sm", "lg"),
previousBtn = "\u00ab", nextBtn = "\u00bb",
.list = NULL) {
align <- match.arg(align)
size <- match.arg(size)
# Build temporary tag structure
temp_tag <- bs4Dash::tabsetPanel(
...,
id = id,
selected = selected,
type = "tabs",
vertical = FALSE,
side = "left",
.list = .list
)
# handle style
pagination_cl <- "pagination"
if (align %in% c("center", "right")) {
if (align == "right") align <- "end"
pagination_cl <- paste(
pagination_cl,
sprintf("justify-content-%s", align)
)
}
if (size %in% c("sm", "lg")) {
pagination_cl <- paste(
pagination_cl,
sprintf("pagination-%s", size)
)
}
# Start and end navigation tags
pagination_start <- shiny::tags$li(
class = "page-item",
shiny::tags$a(
class = "page-link pagination-previous",
href = "#",
tabindex = "-1",
shiny::tags$span(`aria-hidden`="true", previousBtn),
shiny::tags$span(class = "sr-only", "Previous")
)
)
pagination_end <- shiny::tags$li(
class = "page-item",
shiny::tags$a(
class = "page-link pagination-next",
href = "#",
shiny::tags$span(`aria-hidden`="true", nextBtn),
shiny::tags$span(class = "sr-only", "Next")
)
)
# Modify tag on the fly to correspond to Bootstrap 4 pagination
temp_tag <- htmltools::tagQuery(temp_tag)$
find("ul")$ # remove old tabs class and add pagination class
addAttrs("style" = "margin-bottom: 16px")$
removeClass("nav-tabs")$ # we still need nav to behave like tabs
addClass(pagination_cl)$
resetSelected()$
find("li")$ # replace li class
removeClass("nav-item")$
addClass("page-item")$
resetSelected()$
find("a")$ # replace a class
removeClass("nav-link")$
addClass("page-link")$
resetSelected()$
find("a.active")$ # move active class to parent li
removeClass("active")$
parent()$
addClass("active")$
resetSelected()$
find("ul.pagination")$ # insert navigation
prepend(pagination_start)$
append(pagination_end)$
allTags()
# Handle disabled tags
disabled_items_idx <- numeric(0)
htmltools::tagQuery(temp_tag)$
find(".tab-pane")$
each(function(x, i) {
if (x$attribs$`data-disabled` == "true") {
disabled_items_idx <<- c(disabled_items_idx, i)
}
})
temp_tag <- htmltools::tagQuery(temp_tag)$
find("li")$
each(function(x, i) {
if (i %in% (disabled_items_idx + 1)) {
x$attribs$class <- paste(x$attribs$class, "disabled")
# recommended by Bootstrap 4 doc
x$attribs$tabindex <- "-1"
}
})$
allTags()
# Wrap ul by tags$nav
temp_tag$children[[1]] <- shiny::tags$nav(
`aria-label` = "Navigation stepper",
temp_tag$children[[1]]
)
temp_tag
}
#' Bootstrap 4 pagination item
#'
#' Insert inside \link{pagination}.
#'
#' @inheritParams shiny::tabPanel
#' @param disabled Whether to disable the item. Default to FALSE.
#'
#' @rdname pagination
#'
#' @return An HTML tag.
#' @export
paginationItem <- function (title, ..., value = title,
icon = NULL, disabled = FALSE) {
shiny::tabPanel(
title = title,
...,
value = value,
icon = icon,
`data-disabled` = tolower(disabled)
)
}
#' Update pagination widget from the server
#'
#' @inheritParams pagination
#' @param session Shiny session object.
#'
#' @rdname pagination
#'
#' @return Send a message from R to JS so as to update
#' the pagination widget on the client.
#' @export
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(bs4Dash)
#'
#' shinyApp(
#' ui = dashboardPage(
#' header = dashboardHeader(),
#' sidebar = dashboardSidebar(),
#' body = dashboardBody(
#' fluidRow(
#' actionButton("update", "Select page 4", class = "mx-2"),
#' actionButton("disable", "Disable page 1", class = "mx-2"),
#' actionButton("enable", "Enable page 1", class = "mx-2"),
#' textOutput("selected_page")
#' ),
#' br(),
#' pagination(
#' id = "mypagination",
#' paginationItem("page1", box(title = "This is a box!")),
#' paginationItem("page2", "This is page 2", disabled = TRUE),
#' paginationItem("page3", "This is page 3"),
#' paginationItem(
#' "page4",
#' sliderInput(
#' "obs",
#' "Number of observations:",
#' min = 0,
#' max = 1000,
#' value = 500
#' ),
#' plotOutput("distPlot"),
#' icon = icon("cog")
#' )
#' )
#' )
#' ),
#' server = function(input, output, session) {
#'
#' observeEvent(input$update,{
#' updatePagination("mypagination", selected = "page4")
#' })
#'
#' observeEvent(input$disable,{
#' updatePagination("mypagination", disabled = "page1")
#' })
#'
#' observeEvent(input$enable,{
#' updatePagination("mypagination", selected = "page1")
#' })
#'
#' output$selected_page <- renderText({
#' sprintf("Currently selected page: %s", input$mypagination)
#' })
#'
#' output$distPlot <- renderPlot({
#' hist(rnorm(input$obs))
#' })
#' }
#' )
#' }
updatePagination <- function(id, selected = NULL,
disabled = NULL,
session = shiny::getDefaultReactiveDomain()) {
if (length(selected) > 1) {
stop("Can't select more than one element ...")
}
# make sure we don't have selected and disabled item
# with the same value ...
common_elements <- intersect(selected, disabled)
if (length(common_elements) > 0) {
stop("A selected item cannot be disabled ...")
}
session$sendInputMessage(
id,
message = dropNulls(
list(
selected = selected,
disabled = disabled
)
)
)
}
Try the bs4Dash package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.