реактивно изменяя цвет в Infobox, на клик или парить над

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. Чтобы иметь всплывающее окно, отображающее изображение, я использовал popup для 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)