Обновление контрольной панели Shiny-R

Question

Я использую, чтобы добавить некоторый прогресс в свои блестящие приложения, используя пакет shinyBS. Но новая версия, работающая с bootstrap 3, не имеет возможности. Как блестящий включенный индикатор прогресса не настраивается по мере необходимости, я попытался переделать BS, совместимый с загрузочным модулем 3. Он работает хорошо, но мне не удается его обновить.

Заранее благодарим за помощь!

Вот пример, NB: ярлык и размер еще не включены в js.

Сервер: (от 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)) 
) 

И я добавить следующий JS код WWW (как 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); 
}; 
    } 
); 

редактировать:

Я могу добавить некоторые уточнения, когда JS код выполняется, ария-valuenow и ширина хорошо обновляется, но в основном DIV поэтому изменение не учитывается:

<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> 

Answer 1

Так что решение было вполне легко, просто изменить уровень ИО в функции:

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) 
) 
) 
} 

Я надеюсь, что это будет полезно для любого блестящего developper добавить пользовательский ProgressBar.