R Shiny Dashboard valueBox: Animation from one number to another

user_4930357 0
Viewed 618

I am trying to show animation / transition from 0 to a number in valuebox. let's say 92.6 in valuebox. For example, if a value 90.6 needs to be shown, it will be transitioning from 0 to 90.6.

Example

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)

In javascript solution is shown here - http://jsfiddle.net/947Bf/1/ In the script below, I tried to communicate using shiny.addCustomMessageHandler but couldn't get success.

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

  });"),
shiny r jquery javascript
1 Answers

Here is an example. The parameter easing: 'easeOutCubic' causes some errors, so I removed this line.

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)

enter image description here

EDIT

Here is a way to change the icon according to value < 10 or 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)

EDIT

Here is a way to do such an animated box with an id set to the box. This allows to do multiple animated boxes with the same JS code:

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)
user_11001070
Related