动态图像轮播 R 闪亮

Question

我想根据过滤列表在闪亮的仪表板中动态添加图像轮播。我已经尝试过 shinydashboardPlus 包和 slickR 包，但似乎无法让它们中的任何一个工作。

尽我所能使用 shinydashboardPlus 重现一个简短的示例。不反对使用其他包。

library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(shinyWidgets)

df <- data.frame(
  name = c("rose", "carnation", "hydrangea"),
  color = c("red", "pink", "blue"),
  Picture = c("rose.jpg", "carnation.jpg", "hydrangea.jpg")
)

ui <- dashboardPage(
  dashboardHeader(title = "Dynamic Carousel", 
                  titleWidth =300
                  
  ),
  
  dashboardSidebar(width = 300,
                   
                   pickerInput(inputId = "color", 
                               label = "Options",
                               pickerOptions(width = "fit"),
                               choices = df$color, 
                               selected = df$color,
                               multiple = TRUE,
                               options = pickerOptions(actionsBox = TRUE, dropupAuto = FALSE))
                   
                   ),
  dashboardBody(
    fluidRow(width = 6,
             
             uiOutput("carousel")
             
             ),
    
    fluidRow(width = 12,
             dataTableOutput("table")
             )
  )
)

server <- function(input, output) {
  
  filtered <- reactive({
    df %>%
      filter(color %in% input$color)
  })
  
  images <- reactive({
    
    images <- lapply(filtered()$Picture,function(x){
      htmltools::tags$img(src = x)
    })
    
    return(images)
    
  })
  
  output$carousel <- renderUI({
    
    items = Map(function(i) {carouselItem(
      tags$img(src = images()[[i]])
    )})
    
    carousel(indicators = TRUE,
             id = "carousel",
             .list = items
    )
    
  })
  
  output$table <- renderDT(filtered())
  
}

shinyApp(ui = ui, server = server)

您可以使用这些图像进行测试。

Answer 1

似乎问题在于您如何构建items 的列表。您的 images() 反应变量已经具有图像标签。因此，您在构建列表时无需再次使用tags$img。您还使用了 Map() 函数，但您似乎实际上并没有映射任何值。试试

    items <- Map(function(img) {carouselItem(img)}, images())

这会将您的所有图像标签包装在正确的carouselItem() 包装器中。

此外，您不能为您的 carousel() 提供与您的 uiOutput() 相同的 ID。确保它们具有不同的 ID，否则 javascript 会混淆。

Answer 2

一个简短的可重现的 slickR 示例，对细节进行了一些更改。

library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(shinyWidgets)

df <- data.frame(
  name = c("rose", "carnation", "hydrangea"),
  color = c("red", "pink", "blue"),
  Picture = c("rose.jpg", "carnation.jpg", "hydrangea.jpg")
)

ui <- dashboardPage(
  dashboardHeader(title = "Dynamic Carousel", 
                  titleWidth =300
                  
  ),
  
  dashboardSidebar(width = 300,
                   
                   pickerInput(inputId = "color", 
                               label = "Options",
                               pickerOptions(width = "fit"),
                               choices = df$color, 
                               selected = df$color,
                               multiple = TRUE,
                               options = pickerOptions(actionsBox = TRUE, dropupAuto = FALSE))
                   
                   ),
  dashboardBody(
    fluidRow(
             
             box(width = 12,
               slickROutput("slick_output", width = "70%", height = "250px")
             )
             
             
             
             ),
    
    fluidRow(
             box(width = 12,
               dataTableOutput("table")
             )
             )
  )
)

server <- function(input, output) {
  
  filtered <- reactive({
    df %>%
      filter(color %in% input$color)
  })
  
  images <- reactive({
    
    images <- lapply(filtered()$Picture,function(x){
      htmltools::tags$img(src = x, width = "400px", height = "225px", style="margin-left: auto;  margin-right: auto;")
    })
    
    return(images)
    
  })
  
  output$slick_output <- renderSlickR({
    
    slickR(images(),
           slideId = 'myslick') + 
      settings(dots = TRUE,
               slidesToShow = 2,
               slidesToScroll = 2,
               autoplay = TRUE)
    
  })
  
  output$table <- renderDT(filtered())
  
}

shinyApp(ui = ui, server = server)