单击或悬停在信息框上时，响应式更改信息框的颜色

Question

我想在shiny 和shinydashboard 中使用reactiveValue、observe、observeEvent 框架，以便能够在单击时响应地更改信息框的颜色。

我还希望它在将鼠标悬停在 infoBox 上时在弹出框中显示带有一些文本的图像。

作为可复现示例的代码基础，请参阅this

但代码如下：

 library(shinydashboard)

  ui <- dashboardPage(
    dashboardHeader(title = "Info boxes"),
    dashboardSidebar(),
    dashboardBody(
      # infoBoxes with fill=FALSE
      fluidRow(
        # A static infoBox
        infoBox("New Orders", 10 * 2, icon = icon("credit-card")),
        # Dynamic infoBoxes
        infoBoxOutput("progressBox"),
        infoBoxOutput("approvalBox")
      ),

      # infoBoxes with fill=TRUE
      fluidRow(
        infoBox("New Orders", 10 * 2, icon = icon("credit-card"), fill = TRUE),
        infoBoxOutput("progressBox2"),
        infoBoxOutput("approvalBox2")
      ),

      fluidRow(
        # Clicking this will increment the progress amount
        box(width = 4, actionButton("count", "Increment progress"))
      )
    )
  )

  server <- function(input, output) {
    output$progressBox <- renderInfoBox({
      infoBox(
        "Progress", paste0(25 + input$count, "%"), icon = icon("list"),
        color = "purple"
      )
    })
    output$approvalBox <- renderInfoBox({
      infoBox(
        "Approval", "80%", icon = icon("thumbs-up", lib = "glyphicon"),
        color = "yellow"
      )
    })

    # Same as above, but with fill=TRUE
    output$progressBox2 <- renderInfoBox({
      infoBox(
        "Progress", paste0(25 + input$count, "%"), icon = icon("list"),
        color = "purple", fill = TRUE
      )
    })
    output$approvalBox2 <- renderInfoBox({
      infoBox(
        "Approval", "80%", icon = icon("thumbs-up", lib = "glyphicon"),
        color = "yellow", fill = TRUE
      )
    })
  }

  shinyApp(ui, server)

这可能吗？

Answer 1

你想做的事完全可以用 CSS 和 JavaScript 来完成，而不是闪亮的。这是一种可能的解决方案（有很多方法可以实现您想要的）。

您将鼠标悬停在任何信息框上都会变为灰色，当您单击它时，它会变为不同的灰色。当您将鼠标悬停在第一个信息框（左上角）上时，它还会显示一个带有图像的弹出窗口。 为了解决如何在悬停/单击时更改背景颜色的问题，我只是添加了一些 CSS。为了在悬停时弹出一个显示图像的弹出窗口，我使用了 Bootstrap 的弹出窗口。很简单，希望对你有帮助

library(shinydashboard)

mycss <- "
.info-box:hover,
.info-box:hover .info-box-icon {
  background-color: #aaa !important;
}
.info-box:active,
.info-box:active .info-box-icon {
  background-color: #ccc !important;
}
"

withPopup <- function(tag) {
  content <- div("Some text and an image",
                 img(src = "http://thinkspace.com/wp-content/uploads/2013/12/member-logo-rstudio-109x70.png"))
  tagAppendAttributes(
    tag,
    `data-toggle` = "popover",
    `data-html` = "true",
    `data-trigger` = "hover",
    `data-content` = content
  )
}

ui <- dashboardPage(
  dashboardHeader(title = "Info boxes"),
  dashboardSidebar(),
  dashboardBody(
    tags$head(tags$style(HTML(mycss))),
    tags$head(tags$script("$(function() { $(\"[data-toggle='popover']\").popover(); })")),
    # infoBoxes with fill=FALSE
    fluidRow(
      # A static infoBox
      withPopup(infoBox("New Orders", 10 * 2, icon = icon("credit-card"))),
      # Dynamic infoBoxes
      infoBoxOutput("progressBox"),
      infoBoxOutput("approvalBox")
    ),

    # infoBoxes with fill=TRUE
    fluidRow(
      infoBox("New Orders", 10 * 2, icon = icon("credit-card"), fill = TRUE),
      infoBoxOutput("progressBox2"),
      infoBoxOutput("approvalBox2")
    ),

    fluidRow(
      # Clicking this will increment the progress amount
      box(width = 4, actionButton("count", "Increment progress"))
    )
  )
)

server <- function(input, output) {
  output$progressBox <- renderInfoBox({
    infoBox(
      "Progress", paste0(25 + input$count, "%"), icon = icon("list"),
      color = "purple"
    )
  })
  output$approvalBox <- renderInfoBox({
    infoBox(
      "Approval", "80%", icon = icon("thumbs-up", lib = "glyphicon"),
      color = "yellow"
    )
  })

  # Same as above, but with fill=TRUE
  output$progressBox2 <- renderInfoBox({
    infoBox(
      "Progress", paste0(25 + input$count, "%"), icon = icon("list"),
      color = "purple", fill = TRUE
    )
  })
  output$approvalBox2 <- renderInfoBox({
    infoBox(
      "Approval", "80%", icon = icon("thumbs-up", lib = "glyphicon"),
      color = "yellow", fill = TRUE
    )
  })
}

shinyApp(ui, server)