R Shiny Dashboard valueBox：從一個數字到另一個數字的動畫

Question

我正在嘗試在 valuebox 中顯示從 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)