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

Question

I would like to use the reactiveValue , observe , observeEvent framework in shiny and shinydashboard to be able to reactively change the colour of an infoBox when clicked.

I would also like it to display an image with some text in a popup box when hovering over the infoBox.

As a basis of code as a reproducible example, please see this

But the code is availible below:

 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)

Is that possible?

Answer 1

What you want to do can be completely done with CSS and JavaScript, not shiny. Here is one possible solution (there are many ways to achieve what you want).

Any info box you hover over will change to gray and when you click it will change to a different gray. The first info box (top-left) will also show a popup with an image in it when you hover over it. To address the question of how to change the background colour on hover/click, I just added a bit of CSS. To have a popup on hover that shows an image, I used Bootstrap's popover. It's fairly simple, hope it helps

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)