Question

我想使用reactiveValue和observe中的observeEvent，shiny，shinydashboard框架，以便能够反应性地更改infoBox的颜色点击时。

当我将鼠标悬停在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)

点击或悬停在上，可以反应性地改变信息框的颜色

1 个答案: