Can a box status value (color) be reactive and conditional in Shinydashboard?

问题

I have a Shinydashboard with reactive Dygraph boxes. I successfully setup a reactive box title to display the maximum value in the dataset and I'd like to do the same for the Status option. Here's what I've got so far:

ui <- dashboardPage(
  dashboardHeader(title = "Sites", disable = TRUE),
  dashboardSidebar(
    #collapsed = TRUE,
    disable = TRUE,
    sidebarMenu()
  ),
  dashboardBody(

    fluidRow(
      box(title = textOutput('dyermax'), background = "black", status = textOutput('dyerStat'), dygraphOutput("plot1", height = 173))
    )
  )
)

The title works as expected but the status gives an error: status can only be "primary", "success", "info", "warning", or "danger".

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

  #reactivePoll code for importing CSV data (datap)

  renderTable(datap())

  #Plot1

  output$plot1 <- renderDygraph({
    dyersburgp <- xts(x = datap()$dyersburg, order.by = datap()$date)
    dyersburgf <- xts(x = datap()$dyersburg.1, order.by = datap()$date)
    dyersburgmain <- cbind(dyersburgf, dyersburgp)
    output$dyermax <- renderPrint({
      cat("Dyersburg (max:", max(dyersburgp, na.rm = TRUE),"ug/m3)")
    })
    dyersburgMx <- max(dyersburgp, na.rm = TRUE)
    output$dyerStat <- renderPrint({
    if(dyersburgMx >60)("danger" else "info")
  })
    dygraph(dyersburgmain) 
  })


     }

shinyApp(ui, server)

I would prefer to use the Color option instead of the Status option, but adding "color = "red"" to the box doesn't change the color at all for some reason.

回答1:

Background

This is actually a really good question. To my understanding, the reason textOutput doesn't work is that, by default, text is rendered within an HTML div. So instead of just passing the raw string ('danger', 'info', etc.), it is rendered as raw HTML. For example, if we inspect the textOutput element in our browser when we run the following,

output$my_text <- renderText({
    'this is some text'
})

textOutput('my_text')

we can see it actually renders the below HTML, rather than just "this is some text".

<div id="my_text" class="shiny-text-output shiny-bound-output">this is some text</div>

Obviously this is for a very good reason, and enables us to make good-looking Shiny apps without having to worry about any HTML. But it means we have to be careful when passing outputs as arguments to UI functions.

Solution

There may be better ways to do this, but one way would be creating the HTML yourself by using renderUI/uiOutput, and using the HTML function in combination with paste0 to dynamically render out HTML string to be read directly by uiOutput (which is an alias for the more descriptive htmlOutput). This example changes the status of the box when the user changes the numericInput to above 60, and allows the user to change the title of the box as well. Extend this as required for your own project.

library(shiny)
library(shinydashboard)

body <-
    dashboardBody(
        fluidRow(
            numericInput(
                inputId = 'status_input',
                label = 'numeric input',
                value = 50),
            textInput(
                inputId = 'box_title',
                label = 'box title',
                value = ''),
            uiOutput('my_box')
        )
    )

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

    # get box status as string representing html element
    box_status <- reactive({
        if (input$status_input > 60) {
            'box-danger'
        } else {
            'box-info'
        }
    })

    # get user input for box title
    box_title <- reactive({
        input$box_title
    })

    # generate html to display reactive box
    output$my_box <- renderUI({

        status <- box_status()
        title <- box_title()

        # generate the dynamic HTML string
        HTML(paste0("
            '
            <div class=\"box box-solid ", status, "\">
            <div class=\"box-header\">
                <h3 class=\"box-title\">", title, "</h3>
            </div>
            <div class=\"box-body\">
                Box content!
            </div>
            </div>
            '"
        ))
    })
}

shinyApp(ui = dashboardPage(dashboardHeader(), dashboardSidebar(),body), server)

来源：https://stackoverflow.com/questions/59416007/can-a-box-status-value-color-be-reactive-and-conditional-in-shinydashboard