如何將函數與傳遞函數一起使用有反應作為閃亮的輸入

Question

我沒什么問題 我有一個名為d3K的構建包，可以在不同的儀表板上使用。 功能之一如下：

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

現在，我嘗試在函數中傳遞value參數，其中parameter是無功值。

服務器

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

用戶界面

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

  )
)
)
)

我無法在閃亮的儀表板上看到值框。

但是，如果在server的output $ t中使用以下代碼，則可以使用

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

然后我可以看到預期的結果

Answer 1

我發現如果您在腳本中定義conditionalRenderValueBox ，它將運行：

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

我猜測問題出在您的程序包如何導出函數，但是如果不查看代碼，我很難知道。

希望這可以幫助。

編輯：嘿，我不知道您的d3K軟件包到底是做什么的，以及您是否已經使它工作了，但是據我所知，您不希望編寫包裝render *閃亮函數的函數。 以下這個應用程式無法運作：

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

  })

該函數在啟動時運行一次並呈現初始表，但是此后它永遠不會改變，因為myFunc不像render *函數那樣理解反應性。

我認為您的函數應該包裝valueBox元素，然后將函數饋入renderValueBox如下所示：

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