javascript - R Shiny 仪表板 valueBox : Animation from one number to another

Question

我正在尝试在值框中显示从 0 到数字的动画/过渡。假设 valuebox 中的值是 92.6。例如，如果需要显示值 90.6，它将从 0 转换到 90.6。

示例

library(shinydashboard)
library(dplyr)
# UI
ui <- dashboardPage(skin = "black",
                    dashboardHeader(title = "Test"),
                    dashboardSidebar(disable = TRUE),
                    dashboardBody(
                        fluidRow(
                            valueBoxOutput("test_box")
                        )
                    )
)

# Server response
server <- function(input, output, session) {
    output$test_box <- renderValueBox({
        iris %>% 
            summarise(Petal.Length = mean(Petal.Length)) %>% 
            .$Petal.Length %>% 
            scales::dollar() %>% 
            valueBox(subtitle = "Unit Sales",
                     icon = icon("server"),
                     color = "purple"
        )
    })
}

shinyApp(ui, server)

这里显示了 JavaScript 解决方案 - http://jsfiddle.net/947Bf/1/在下面的脚本中，我尝试使用shiny.addCustomMessageHandler进行通信，但未能成功。

tags$script("
 Shiny.addCustomMessageHandler('testmessage',
 function(){
    var o = {value : 0};
    $.Animation( o, {
        value: $('#IRR .inner h3').val()
      }, { 
        duration: 1500,
        easing : 'easeOutCubic'
      }).progress(function(e) {
          $('#IRR .inner h3').text((e.tweens[0].now).toFixed(1));
    });

  });"),

Answer 1

这是一个例子。参数easing: 'easeOutCubic'导致一些错误，所以我删除了这一行。

library(shiny)
library(shinydashboard)

js <- "
Shiny.addCustomMessageHandler('anim',
 function(x){
    
    var $s = $('div.small-box div.inner h3'); 
    var o = {value: 0};
    $.Animation( o, {
        value: x
      }, { 
        duration: 1500
        //easing: 'easeOutCubic'
      }).progress(function(e) {
          $s.text('$' + (e.tweens[0].now).toFixed(1));
    });

  }
);"

# UI
ui <- dashboardPage(skin = "black",
                    dashboardHeader(title = "Test"),
                    dashboardSidebar(disable = TRUE),
                    dashboardBody(
                      tags$head(tags$script(js)),
                      fluidRow(
                        valueBox("", subtitle = "Unit Sales",
                                 icon = icon("server"),
                                 color = "purple"
                        )
                      ),
                      br(),
                      actionButton("btn", "Change value")
                    )
)

# Server response
server <- function(input, output, session) {
  
  rv <- reactiveVal(10)
  
  observeEvent(input[["btn"]], {
    rv(rpois(1,20))
  })
  
  observeEvent(rv(), {
    session$sendCustomMessage("anim", rv())
  })
  
}

shinyApp(ui, server)

<小时/>

编辑

这里有一个根据value < 10改变图标的​​方法或value > 10 .

library(shiny)
library(shinydashboard)

js <- "
Shiny.addCustomMessageHandler('anim',
 function(x){
    
    var $icon = $('div.small-box i.fa');
    if(x <= 10 && $icon.hasClass('fa-arrow-up')){
      $icon.removeClass('fa-arrow-up').addClass('fa-arrow-down');
    }
    if(x > 10 && $icon.hasClass('fa-arrow-down')){
      $icon.removeClass('fa-arrow-down').addClass('fa-arrow-up');
    }
    
    var $s = $('div.small-box div.inner h3'); 
    var o = {value: 0};
    $.Animation( o, {
        value: x
      }, { 
        duration: 1500
        //easing: 'easeOutCubic'
      }).progress(function(e) {
          $s.text('$' + (e.tweens[0].now).toFixed(1));
    });

  }
);"

# UI
ui <- dashboardPage(skin = "black",
                    dashboardHeader(title = "Test"),
                    dashboardSidebar(disable = TRUE),
                    dashboardBody(
                      tags$head(tags$script(HTML(js))),
                      fluidRow(
                        valueBox("", subtitle = "Unit Sales",
                                 icon = icon("arrow-up"),
                                 color = "purple"
                        )
                      ),
                      br(),
                      actionButton("btn", "Change value")
                    )
)

# Server response
server <- function(input, output, session) {
  
  rv <- reactiveVal(10)
  
  observeEvent(input[["btn"]], {
    rv(rpois(1,10))
  })
  
  observeEvent(rv(), {
    session$sendCustomMessage("anim", rv())
  })
  
}

shinyApp(ui, server)

编辑

这里有一种方法来制作这样一个动画框，并将 id 设置为该框。这允许使用相同的 JS 代码执行多个动画框:

library(shiny)
library(shinydashboard)

js <- "
Shiny.addCustomMessageHandler('anim',
 function(x){

    var $box = $('#' + x.id + ' div.small-box');
    var value = x.value;

    var $icon = $box.find('i.fa');
    if(value <= 10 && $icon.hasClass('fa-arrow-up')){
      $icon.removeClass('fa-arrow-up').addClass('fa-arrow-down');
    }
    if(value > 10 && $icon.hasClass('fa-arrow-down')){
      $icon.removeClass('fa-arrow-down').addClass('fa-arrow-up');
    }

    var $s = $box.find('div.inner h3');
    var o = {value: 0};
    $.Animation( o, {
        value: value
      }, {
        duration: 1500
      }).progress(function(e) {
          $s.text('$' + (e.tweens[0].now).toFixed(1));
    });

  }
);"

# UI
ui <- dashboardPage(
  skin = "black",
  dashboardHeader(title = "Test"),
  dashboardSidebar(disable = TRUE),
  dashboardBody(
    tags$head(tags$script(HTML(js))),
    fluidRow(
      tagAppendAttributes(
        valueBox("", subtitle = "Unit Sales",
                 icon = icon("server"),
                 color = "purple"
        ),
        id = "mybox"
      )
    ),
    br(),
    actionButton("btn", "Change value")
  )
)

# Server response
server <- function(input, output, session) {

  rv <- reactiveVal(10)

  observeEvent(input[["btn"]], {
    rv(rpois(1,20))
  })

  observeEvent(rv(), {
    session$sendCustomMessage("anim", list(id = "mybox", value = rv()))
  })

}

shinyApp(ui, server)