r - R 中 Shiny : Is it possible to output a color using renderText?

Question

我正在尝试使用 Shiny 仪表板包创建一个盒子。我无法在服务器端创建它(这是另一个问题，但在我的问题上)。但是，我想动态设置颜色，并且想知道是否可以通过使用 renderText 来实现。我现在在服务器端有一个 renderText，它输出 NULL 或颜色“栗色”。但是，这给了我以下错误:

Warning: Error in validateColor: Invalid color

您知道问题是什么或有不同的方法吗？非常感谢任何帮助!

Answer 1

简而言之，无法使用 renderText 直接更改颜色，但有很多方法可以动态更改文本颜色。

举几个方法，您可以:

使用 CSS 类并在它们之间切换:

require(shiny)
require(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "Basic dashboard"),
  dashboardSidebar(),
  dashboardBody(
    tags$head(
      tags$style(
        HTML("
              .toggle{
                color: red;
              }
             ")
        ),
      tags$script(
        HTML("
          Shiny.addCustomMessageHandler ('toggleClass',function (m) {
                  var element = $('#'+m.id); // Find element to change color of
                  element.toggleClass('toggle');
          });
             ")
      )
    ),
    fluidRow(
      box( id='test',
           title = "Box",
           status = "warning",
           solidHeader = TRUE,
           height = 400,
           textOutput('txtOut')
      )
    ),
    actionButton('btn','Generate Color')
  ) #end dashboardBody
)

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

  # Helper function, calls javascript
  toggleClass <- function(id){
    session$sendCustomMessage(type = 'toggleClass', message = list('id'=id))
  }

  output$txtOut <- renderText({ "Static text" }); # Text can be re-rendered independantly

  observeEvent(input$btn,{
    toggleClass('txtOut') # Add  / remove class
  })

}
shinyApp(ui, server)

使用 Javascript 绑定(bind)来更改元素的颜色(可能是最强大的方法):

   require(shiny)
   require(shinydashboard)

    ui <- dashboardPage(
      dashboardHeader(title = "Basic dashboard"),
      dashboardSidebar(),
      dashboardBody(
        tags$head(
          tags$script(
            HTML("
              // Change color inside of element with supplied id
              Shiny.addCustomMessageHandler ('changeTxtColor',function (m) {
                      var element = $('#'+m.id); // Find element to change color of
                      element.css({ 'color': 'rgb('+m.r+','+m.g+','+m.b+')' }); // Change color of element
              });

              // Change color of shinydashboard box
              Shiny.addCustomMessageHandler ('changeBoxColor',function (m) {
                      var parent  = $('#'+m.id).closest('.box');
                      var element = parent.children('.box-header');
                      var rgbStr  = 'rgb('+m.r+','+m.g+','+m.b+')';
                      element.css({ 'background-color':  rgbStr});
                      parent.css({ 'border-color' :  rgbStr})
              });
                ")
          )
        ),
        fluidRow(
          box( id='test',
            title = "Box",
            status = "warning",
            solidHeader = TRUE,
            height = 400,
            textOutput('txtOut'),
            div(id='target') 
            # Since you can't specify the id of shinydashboard boxes
            # we need a child with id to change the color of the box.
          )
        ),
        actionButton('btn','Generate Color')
      )
    )

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

      randomColor <- reactive({
        input$btn
        name <- sample(colors(),1)
        rgb  <- col2rgb(name)
        return( list(name=name, rgb=rgb) )
      })

      # Helper function, calls javascript
      changeTxtColor <- function(id,rgb){
        session$sendCustomMessage(type = 'changeTxtColor', message = list('id'=id,'r'=rgb[1],'g'=rgb[2],'b'=rgb[3]))
      }
      changeBoxColor <- function(id,rgb){
        session$sendCustomMessage(type = 'changeBoxColor', message = list('id'=id,'r'=rgb[1],'g'=rgb[2],'b'=rgb[3]))
      }

      output$txtOut <- renderText({
        rgb <- randomColor()$rgb
        changeTxtColor('txtOut',rgb)
        changeBoxColor('target',rgb)
        sprintf("Generated color with name %s ", randomColor()$name)
      })

    }
    shinyApp(ui, server)

简单地输出HTML而不是使用renderText，允许精确 HTML 生成的控制请参阅此 question :

require(shiny)
require(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "Basic dashboard"),
  dashboardSidebar(),
  dashboardBody(
    fluidRow(
      box( id='test',
           title = "Box",
           status = "warning",
           solidHeader = TRUE,
           height = 400,
           htmlOutput('txtOut')
      )
    ),
    actionButton('btn','Generate Color')
  ) #end dashboardBody
)

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

  # Reactive variable
  randomColor <- reactive({
    input$btn
    name <- sample(colors(),1)
    rgb  <- col2rgb(name)
    return( list(name=name, rgb=rgb) )
  })

  # Helper function, calls javascript
  toggleClass <- function(id){
    session$sendCustomMessage(type = 'toggleClass', message = list('id'=id))
  }

  output$txtOut <- renderUI({
    rgb    <- randomColor()$rgb
    rgbStr <- sprintf('rgb(%d,%d,%d)',rgb[1],rgb[2],rgb[3])
    print(rgb)
    div( HTML(sprintf("<text style='color:%s'> Generated color with name %s </text>", rgbStr, randomColor()$name) ) )
  })

}
shinyApp(ui, server)

抱歉，文本量太大。