CODEWITHSUNDEEP
rprogress-barshiny
Ben
Ben

Reputation: 320

Update Shiny-R custom progressbar

I use to put some progressbar in my shiny apps using shinyBS package. But the new version working with bootstrap 3 does not have the option. As shiny included progressbar is not customizable as wanted, I tried to remake the BS one compatible with bootstrap 3. It works well but I do not manage to update it.

Thanks in advance for any help about this!

Here is an exemple, NB : label and size are not included in the js yet.

Server : (from https://gist.github.com/artemklevtsov/d280c4343b052c2aaaef )

server <- function(input, output,session) {

tags$script(src="ShinyProgress.js"),
  progressBar <- function(inputId,value = 0, label = FALSE, color = "info", size = NULL,
                      striped = FALSE, active = FALSE, vertical = 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")
htmltools::tags$div(
  class = "progress",
  id=inputId,
  class = if (!is.null(size)) paste0("progress-", size),
  class = if (vertical) "vertical",
  class = if (active) "active",
  htmltools::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,
    htmltools::tags$span(class = if (!label) "sr-only", text_value)
  )
)
}

     updatePB=function(session,inputId,value=NULL,label=NULL,color=NULL,size=NULL,striped=NULL,active=NULL,vertical=NULL) {
data <- dropNulls(list(id=inputId,value=value,label=label,color=color,size=size,striped=striped,active=active,vertical=vertical))
session$sendCustomMessage("updateprogress", data)
  }

dropNulls=function(x) {
  x[!vapply(x,is.null,FUN.VALUE=logical(1))]
}

  observe({input$n1 ; updatePB(session,inputId="pb1",value=input$n1)})

    }

UI :

ui <- fluidPage(
  numericInput(inputId="n1", label="numeric input", value=10, min = 0, max = 100, step = 1),
mainPanel(progressBar(inputId="pb1",value=10))
)

And I add the following js code to www (as ShinyProgress.js) :

Shiny.addCustomMessageHandler("updateprogress",
  function(data) {
$el = $("#"+data.id);
if(data.hasOwnProperty('value')) {
  $el.css('width', data.value+'%').attr('aria-valuenow', data.value);
};
if(data.hasOwnProperty('color')) {
  $el.removeClass("progress-bar-standard progress-bar-info progress-bar-success progress-bar-danger progress-bar-warning");
  $el.addClass("progress-bar-"+data.color);
};
if(data.hasOwnProperty('striped')) {
  $el.toggleClass('progress-bar-striped', data.striped);
};
if(data.hasOwnProperty('active')) {
  $el.toggleClass('active', data.active);
};
if(data.hasOwnProperty('vertical')) {
  $el.toggleClass('vertical', data.vertical);
};
  }
);

edit :

I am able to add some clarification, when js code is executed, aria-valuenow and width are well updated but in the main div so the modification is not taken into account :

<div aria-valuenow="100" style="width: 100%;" id="pb1">
          <div aria-valuemax="100" aria-valuemin="0" aria-valuenow="0" class="progress-bar progress-bar-info" role="progressbar" style="width:0%;min-width:2em;">
            <span class="sr-only">0%</span>
          </div>
</div>

Upvotes: 0

Views: 932

Answers (1)

Ben
Ben

Reputation: 320

So the solution was quite easy, just change the level of the id in the function :

progressBar <- function(inputId, value=0, label=F, color="info", size=NULL, striped=F, active=F, vertical=F) {
 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")
htmltools::tags$div(
class = "progress",
# id=inputId,
class = if (!is.null(size)) paste0("progress-", size),
class = if (vertical) "vertical",
class = if (active) "active",
htmltools::tags$div(
  id=inputId,
  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,
  htmltools::tags$span(class = if (!label) "sr-only", text_value)
)
)
}

I hope that it will be helpfull for any shiny developper to add custom progressbar.

Upvotes: 2

Related Questions