shinydashboard
shinydashboard copied to clipboard
Published
20 hours ago •
rstudio
rstudio
Progress-bar function
According this: https://almsaeedstudio.com/themes/AdminLTE/pages/UI/general.html
prgoressBar <- function(value = 0, label = FALSE, color = "aqua", size = NULL,
striped = FALSE, active = FALSE, vertical = FALSE) {
stopifnot(is.numeric(value))
if (value < 0 || value > 100)
stop("'value' should be in the range from 0 to 100.", call. = FALSE)
if (!(color %in% shinydashboard:::validColors || color %in% shinydashboard:::validStatuses))
stop("'color' should be a valid status or color.", call. = FALSE)
if (!is.null(size))
size <- match.arg(size, c("sm", "xs", "xxs"))
text_value <- paste0(value, "%")
if (vertical)
style <- htmltools::css(height = text_value, `min-height` = "2em")
else
style <- htmltools::css(width = text_value, `min-width` = "2em")
tags$div(
class = "progress",
class = if (!is.null(size)) paste0("progress-", size),
class = if (vertical) "vertical",
class = if (active) "active",
tags$div(
class = "progress-bar",
class = paste0("progress-bar-", color),
class = if (striped) "progress-bar-striped",
style = style,
role = "progressbar",
`aria-valuenow` = value,
`aria-valuemin` = 0,
`aria-valuemax` = 100,
tags$span(class = if (!label) "sr-only", text_value)
)
)
}
progressGroup <- function(text, value, min = 0, max = value, color = "aqua") {
stopifnot(is.character(text))
stopifnot(is.numeric(value))
if (value < min || value > max)
stop(sprintf("'value' should be in the range from %d to %d.", min, max), call. = FALSE)
tags$div(
class = "progress-group",
tags$span(class = "progress-text", text),
tags$span(class = "progress-number", sprintf("%d / %d", value, max)),
prgoressBar(round(value / max * 100), color = color, size = "sm")
)
}
Output with default params:
prgoressBar(10)
#> <div class="progress">
#> <div aria-valuemax="100" aria-valuemin="0" aria-valuenow="10" class="progress-bar progress-bar-aqua" role="progressbar" style="width:10%;min-width:2em;">
#> <span class="sr-only">10%</span>
#> </div>
#> </div>
progressGroup("Text", 150, 0, 300)
#> <div class="progress-group">
#> <span class="progress-text">Text</span>
#> <span class="progress-number">150 / 300</span>
#> <div class="progress progress-sm">
#> <div aria-valuemax="100" aria-valuemin="0" aria-valuenow="50" class="progress-bar progress-bar-aqua" role="progressbar" style="width:50%;min-width:2em;">
#> <span class="sr-only">50%</span>
#> </div>
#> </div>
#> </div>
To reproduce examples from the AdminLTE docs:
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(disable = TRUE),
dashboardBody(
h2("Progress Bars"),
fluidRow(
box(title = "Progress Bars Different Sizes",
p("Normal"),
prgoressBar(40, color = "primary", striped = TRUE),
p("Small"),
prgoressBar(20, color = "green", striped = TRUE, active = TRUE, size = "sm"),
p("Extra small"),
prgoressBar(60, color = "yellow", striped = TRUE, size = "xs"),
p("Extra extra small"),
prgoressBar(60, color = "red", striped = TRUE, size = "xxs")
),
box(title = "Progress bars",
prgoressBar(40, color = "green"),
prgoressBar(20, color = "aqua"),
prgoressBar(60, color = "yellow"),
prgoressBar(80, color = "red")
)
),
fluidRow(
box(title = "Progress Bars Different Sizes",
class = "text-center",
prgoressBar(40, color = "primary", striped = TRUE, active = TRUE, vertical = TRUE),
prgoressBar(100, color = "green", vertical = TRUE, size = "sm"),
prgoressBar(50, color = "yellow", striped = TRUE, vertical = TRUE, size = "xs"),
prgoressBar(50, color = "aqua", vertical = TRUE, size = "xxs")
),
box(title = "Vertical Progress bars",
class = "text-center",
prgoressBar(40, color = "green", vertical = TRUE),
prgoressBar(20, color = "aqua", vertical = TRUE),
prgoressBar(60, color = "yellow", vertical = TRUE),
prgoressBar(80, color = "red", vertical = TRUE)
)
),
fluidRow(
box(title = "Progress Groups",
p(strong("Goal Completion"), class = "text-center"),
progressGroup("Add Products to Cart", 160, 0, 200),
progressGroup("Complete Purchase", 310, 0, 400, color = "red"),
progressGroup("Visit Premium Page", 480, 0, 800, color = "green"),
progressGroup("Send Inquiries", 250, 0, 500, color = "yellow")
)
)
)
)
server <- function(input, output) { }
shinyApp(ui, server)
Also may be helpful to add an appropriate render and output functions.
~~ wbr.
Has anyone put together a render function or something that can be used to increment these progress bars? Thanks in advance.
Hi @artemklevtsov, Would you be willing to create a pull request for it. Maybe it would help me to accomplish this https://github.com/rstudio/shinydashboard/pull/135. Thanks.
Thanks @artemklevtsov
I've got the progress bars to render with renderUI, but I'm having a hard time getting them to update (quickly). What I've set up inside the renderUI call is a dependancy on a reactiveValue. I then update these reactive Values in an observeEvent brace, once I had hit an actionButton. If the button simply increments the reactive value by say one, then everything works, but if I include a loop that increases the value from 1 to 100, when this is run the progress bar gets "grayed out" , almost as if the renderUI function can't keep up with the for loop. Once the loop hits 100, then the progress bar updates to its final value, is there a way around this?
A reproducible example is below:
my server.R:
library(shiny)
library(shinydashboard)
prgoressBar <- function(value = 0, label = FALSE, color = "aqua", size = NULL,
striped = FALSE, active = FALSE, vertical = FALSE) {
stopifnot(is.numeric(value))
if (value < 0 || value > 100)
stop("'value' should be in the range from 0 to 100.", call. = FALSE)
if (!(color %in% shinydashboard:::validColors || color %in% shinydashboard:::validStatuses))
stop("'color' should be a valid status or color.", call. = FALSE)
if (!is.null(size))
size <- match.arg(size, c("sm", "xs", "xxs"))
text_value <- paste0(value, "%")
if (vertical)
style <- htmltools::css(height = text_value, `min-height` = "2em")
else
style <- htmltools::css(width = text_value, `min-width` = "2em")
tags$div(
class = "progress",
class = if (!is.null(size)) paste0("progress-", size),
class = if (vertical) "vertical",
class = if (active) "active",
tags$div(
class = "progress-bar",
class = paste0("progress-bar-", color),
class = if (striped) "progress-bar-striped",
style = style,
role = "progressbar",
`aria-valuenow` = value,
`aria-valuemin` = 0,
`aria-valuemax` = 100,
tags$span(class = if (!label) "sr-only", text_value)
)
)
}
progressGroup <- function(text, value, min = 0, max = value, color = "aqua") {
stopifnot(is.character(text))
stopifnot(is.numeric(value))
if (value < min || value > max)
stop(sprintf("'value' should be in the range from %d to %d.", min, max), call. = FALSE)
tags$div(
class = "progress-group",
tags$span(class = "progress-text", text),
tags$span(class = "progress-number", sprintf("%d / %d", value, max)),
prgoressBar(round(value / max * 100), color = color, size = "sm")
)
}
shinyServer(function(input,output){
# Create some REACTIVE VALUES
progressValue <- reactiveValues()
progressValue$one <- 0
progressValue$two <- 0
progressValue$three <- 0
progressValue$four <- 0
# Render UI output
output$progressOne <- renderUI({
progressGroup(text = "Sample Parameter Space", value = progressValue$one, min = 0, max = 100, color = "aqua")
})
output$progressTwo <- renderUI({
progressGroup(text = "Evaluate Simulation Error", value = progressValue$two, min = 0, max = 100, color = "red")
})
output$progressThree <- renderUI({
progressGroup(text = "Resample top 10%", value = progressValue$three, min = 0, max = 100, color = "green")
})
output$progressFour <- renderUI({
progressGroup(text = "Compile Output", value = progressValue$four, min = 0, max = 100, color = "yellow")
})
# Then on action button, allow bar to move up.
observeEvent(input$goButton, {
for(i in 1:100) {
progressValue$one <- i
progressValue$two <- i
progressValue$three <- i
progressValue$four <- i
Sys.sleep(0.1)
}
})
})
And my ui.R:
library(shiny)
library(shinydashboard)
shinyUI(
dashboardPage(
dashboardHeader(title = "Playground App"),
dashboardSidebar(
sidebarMenu(
id = "sideBar",
menuItem("Progress Bar", tabName = "progress", icon = icon("home", class = "fa-lg fa-fw", lib = "font-awesome"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "progress",
column(width = 8,
box(width = NULL,
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
collapsed = FALSE,
title = "Calibration",
helpText("Progress Bar Demo."),
p(strong("Goal Completion"), class = "text-center"),
uiOutput(outputId = "progressOne"),
uiOutput(outputId = "progressTwo"),
uiOutput(outputId = "progressThree"),
uiOutput(outputId = "progressFour")
)
),
column(width = 4,
box(width = NULL,
status = "warning",
solidHeader = TRUE,
title = "Button",
actionButton("goButton", "HIT ME")
)
)
)
)
)
)
)
Thanks a lot in advance!
Hi @dmpe, are you able to provide any insight into what I am doing wrong here with regards to animating progress bars? I know Winston is particularly busy right now, and that you are doing a look of good dev work on this package (thanks for that). I'm just super keen to incorporate all the great stuff from the latest builds of AdminLTE into my dashboards.
Thanks!
Just a quick update on this. I switched to editing the shiny withProgress() bars and after digging through the CSS files found the relevant elements. Have put together a short post on the topic http://jackolney.github.io/2016/shiny/ but will also get round to writing some customisation functions that I might submit as a PR. Thanks.
The color/vertical/etc. setting is not working as expected in navbarPage:
prgoressBar <- function(value = 0, label = FALSE, color = "aqua", size = NULL,
striped = FALSE, active = FALSE, vertical = FALSE) {
stopifnot(is.numeric(value))
if (value < 0 || value > 100)
stop("'value' should be in the range from 0 to 100.", call. = FALSE)
if (!(color %in% shinydashboard:::validColors || color %in% shinydashboard:::validStatuses))
stop("'color' should be a valid status or color.", call. = FALSE)
if (!is.null(size))
size <- match.arg(size, c("sm", "xs", "xxs"))
text_value <- paste0(value, "%")
if (vertical)
style <- htmltools::css(height = text_value, `min-height` = "2em")
else
style <- htmltools::css(width = text_value, `min-width` = "2em")
tags$div(
class = "progress",
class = if (!is.null(size)) paste0("progress-", size),
class = if (vertical) "vertical",
class = if (active) "active",
tags$div(
class = "progress-bar",
class = paste0("progress-bar-", color),
class = if (striped) "progress-bar-striped",
style = style,
role = "progressbar",
`aria-valuenow` = value,
`aria-valuemin` = 0,
`aria-valuemax` = 100,
tags$span(class = if (!label) "sr-only", text_value)
)
)
}
progressGroup <- function(text, value, min = 0, max = value, color = "aqua") {
stopifnot(is.character(text))
stopifnot(is.numeric(value))
if (value < min || value > max)
stop(sprintf("'value' should be in the range from %d to %d.", min, max), call. = FALSE)
tags$div(
class = "progress-group",
tags$span(class = "progress-text", text),
tags$span(class = "progress-number", sprintf("%d / %d", value, max)),
prgoressBar(round(value / max * 100), color = color, size = "sm")
)
}
ui <- navbarPage("ProgressBar Test",
tabPanel("Example",
fluidRow(
box(title = "Progress Bars Different Sizes",
p("Normal"),
prgoressBar(40, color = "primary", striped = TRUE),
p("Small"),
prgoressBar(20, color = "green", striped = TRUE, active = TRUE, size = "sm"),
p("Extra small"),
prgoressBar(60, color = "yellow", striped = TRUE, size = "xs"),
p("Extra extra small"),
prgoressBar(60, color = "red", striped = TRUE, size = "xxs")
),
box(title = "Progress bars",
prgoressBar(40, color = "green"),
prgoressBar(20, color = "aqua"),
prgoressBar(60, color = "yellow"),
prgoressBar(80, color = "red")
)
),
fluidRow(
box(title = "Progress Bars Different Sizes",
class = "text-center",
prgoressBar(40, color = "primary", striped = TRUE, active = TRUE, vertical = TRUE),
prgoressBar(100, color = "green", vertical = TRUE, size = "sm"),
prgoressBar(50, color = "yellow", striped = TRUE, vertical = TRUE, size = "xs"),
prgoressBar(50, color = "aqua", vertical = TRUE, size = "xxs")
),
box(title = "Vertical Progress bars",
class = "text-center",
prgoressBar(40, color = "green", vertical = TRUE),
prgoressBar(20, color = "aqua", vertical = TRUE),
prgoressBar(60, color = "yellow", vertical = TRUE),
prgoressBar(80, color = "red", vertical = TRUE)
)
),
fluidRow(
box(title = "Progress Groups",
p(strong("Goal Completion"), class = "text-center"),
progressGroup("Add Products to Cart", 160, 0, 200),
progressGroup("Complete Purchase", 310, 0, 400, color = "red"),
progressGroup("Visit Premium Page", 480, 0, 800, color = "green"),
progressGroup("Send Inquiries", 250, 0, 500, color = "yellow")
)
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)
See the following screenshot:
If the navpage stuff is replaced by shinydashboardboday, it works perfectly. Does anyone know what's wrong?
Hi, I am adding a solution to the problem. tags$style(paste0(".progress-bar-", color," {background-color: ",color,";}"))
prgoressBar <- function(value = 0, label = FALSE, color = "red", size = NULL,
striped = FALSE, active = FALSE, vertical = FALSE) {
stopifnot(is.numeric(value))
if (value < 0 || value > 100)
stop("'value' should be in the range from 0 to 100.", call. = FALSE)
if (!(color %in% shinydashboard:::validColors || color %in% shinydashboard:::validStatuses))
stop("'color' should be a valid status or color.", call. = FALSE)
if (!is.null(size))
size <- match.arg(size, c("sm", "xs", "xxs"))
text_value <- paste0(value, "%")
if (vertical)
style <- htmltools::css(height = text_value, `min-height` = "2em")
else
style <- htmltools::css(width = text_value, `min-width` = "2em")
tags$div(
class = "progress",
class = if (!is.null(size)) paste0("progress-", size),
class = if (vertical) "vertical",
class = if (active) "active",
tags$div(
class = "progress-bar",
class = paste0("progress-bar-", color),
class = if (striped) "progress-bar-striped",
style = style,
role = "progressbar",
`aria-valuenow` = value,
`aria-valuemin` = 0,
`aria-valuemax` = 100,
tags$span(class = if (!label) "sr-only", text_value),
tags$style(paste0(".progress-bar-", color," {background-color: ",color,";}"))
)
)
}
