CODEWITHSUNDEEP
rshiny
Kush Patel
Kush Patel

Reputation: 3865

How to use function with passing function has reactive as input in shiny

I have little problem. I have build package called d3K that can be used across different dashboard. One of function is as follows:

conditionalRenderValueBox <- function(value, title, red_limit, yellow_limit){
      renderValueBox(    valueBox(value, title,
      color = if(class(value)=="character" | is.na(value)){
        "blue"
      }else if(value>red_limit ){
        "red"
      }else if(value>yellow_limit){
        "yellow"
      }else{
        "green"
      }
    ))
}

Now I am trying to pass value parameter in function, where parameter is reactive value.

server.R

library(lubridate)
# library(googleVis)
# library(readr)
library(shinyjs)
library(ggplot2)
library(plotly)
library(d3K)
library(dplyr)
server <- function(input, output, session) {

   v1 = reactive({
      input$v1
   })

   f <-  reactive({
      if(is.na(v1())){
          "WAI"
       }else{
           runif(1, 1, 10)
       }
       })
output$t <- conditionalRenderValueBox(f(), "Possible Value", 15, 10) 
}

ui.R

library(shinydashboard)
library(shiny)
library(shinyjs)
library(plotly)

ui <- dashboardPage(

  dashboardHeader(title = "DashBoard")
  ,skin = 'yellow'
    ,dashboardSidebar(
      tags$head(
      tags$style(HTML("
                      .sidebar { height: 90vh; overflow-y: auto; }
                      " )
      )
    ),

      sidebarMenu(

          menuItem("R", tabName = "R", icon = icon("cog"))
          , selectInput("v1", label = h3("Select box"), 
choices = list( 1,  11, 15), 
selected = 1),


      )

    )


   ,dashboardBody(
       tabItems(
          tabItem(
             tabName = "R"
             , br()
             , fluidRow(
                  valueBoxOutput("t")
                )

  )
)
)
)

I am not able to see value box in shiny dashboard.

However, if use following code in plase of output$t in server , it works 

output$t <- renderValueBox(    valueBox(f(), "title",
          color = if(class(f())=="character" | is.na(f())){
            "blue"
          }else if(f()>red_limit ){
            "red"
          }else if(f()>yellow_limit){
            "yellow"
          }else{
            "green"
          }
        ))

Then I am able to see result as expected

Upvotes: 1

Views: 1515

Answers (1)

Carl
Carl

Reputation: 5779

I find that it runs if you define conditionalRenderValueBox in the script like so:

library(lubridate)
# library(googleVis)
# library(readr)
library(shinyjs)
library(ggplot2)
library(plotly)
# library(d3K) I don't have access to this package obviously
library(dplyr)
library(shinydashboard)
library(shiny)
library(shinyjs)
library(plotly)

conditionalRenderValueBox <- function(value, title, red_limit, yellow_limit){
  renderValueBox(    valueBox(value, title,
                              color = if(class(value)=="character" | is.na(value)){
                                "blue"
                              }else if(value>red_limit ){
                                "red"
                              }else if(value>yellow_limit){
                                "yellow"
                              }else{
                                "green"
                              }
}

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

  v1 = reactive({
    input$v1
  })
  f <-  reactive({
    if(is.na(v1())){
      "WAI"
    }else{
      runif(1, 1, 10)
    }
  })
  output$t <- conditionalRenderValueBox(f(), "Possible Value", 15, 10) 

  ))
}

ui <- dashboardPage(
  dashboardHeader(title = "DashBoard")
  ,skin = 'yellow'
  ,dashboardSidebar(
    tags$head(
      tags$style(HTML("
                      .sidebar { height: 90vh; overflow-y: auto; }
                      " )
      )
    ),
    sidebarMenu(
      menuItem("R", tabName = "R", icon = icon("cog"))
      , selectInput("v1", label = h3("Select box"), 
                    choices = list( 1,  11, 15), 
                    selected = 1)      
    )    
  )
  ,dashboardBody(
    tabItems(
      tabItem(
        tabName = "R"
        , br()
        , fluidRow(
          valueBoxOutput("t")
        )

      )
    )
  )
)

runApp(shinyApp(server=server,ui=ui))

I am guessing the problem is with how your package exports the function, but it's hard for me to know without seeing the code.

Hope this helps.

edit: Hey I don't know exactly what your d3K package does and if you've gotten it to work, but as far as I can tell you don't want write functions that wrap the render* shiny functions. This app below won't work:

myFunc <- function(x) {
  renderTable({
    head(x)
  })
}

shinyApp(
  ui=fluidPage(
    selectInput("select","Choose dataset",c("mtcars","iris")),
    tableOutput("table")
    ),
  server=function(input,output) {

    dataset <- reactive({
      get(input$select)
    })

    output$table <- myFunc(dataset())

  })

The function runs once on start-up and renders the initial table, but it never changes after that because myFunc doesn't understand reactivity like the render* functions do.

I think your function should wrap the valueBox element and then you feed your function to renderValueBox like so:

library(lubridate)
# library(googleVis)
# library(readr)
library(shinyjs)
library(ggplot2)
library(plotly)
# library(d3K) I don't have access to this package obviously
library(dplyr)
library(shinydashboard)
library(shiny)
library(shinyjs)
library(plotly)

conditionalRenderValueBox <- function(value, title, red_limit, yellow_limit){

  #renderValueBox( 
    valueBox(value, title,
                          color = if(class(value)=="character" | is.na(value)){
                                "blue"
                              }else if(value>red_limit ){
                                "red"
                              }else if(value>yellow_limit){
                                "yellow"
                              }else{
                                "green"
                              }
  )
  #)
}

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

  v1 = reactive({
    input$v1
  })
  f <-  reactive({
    v1 <- v1()
    print("Hey")
    if(is.na(v1)){
      "WAI"
    }else{
      runif(1, 1, 10)
    }
  })
  observe({
  output$t <- renderValueBox(conditionalRenderValueBox(f(), "Possible Value", 15, 10))
  })

}

ui <- dashboardPage(
  dashboardHeader(title = "DashBoard")
  ,skin = 'yellow'
  ,dashboardSidebar(
    tags$head(
      tags$style(HTML("
                      .sidebar { height: 90vh; overflow-y: auto; }
                      " )
      )
      ),
    sidebarMenu(
      menuItem("R", tabName = "R", icon = icon("cog"))
      , selectInput("v1", label = h3("Select box"), 
                    choices = list( 1,  11, 15), 
                    selected = 1)      
    )    
      )
  ,dashboardBody(
    tabItems(
      tabItem(
        tabName = "R"
        , br()
        , fluidRow(
          valueBoxOutput("t")
        )

      )
    )
  )
)

runApp(shinyApp(server=server,ui=ui))

Upvotes: 1

Related Questions