在过滤后的闪亮散点图中保留现有选择

Posted 2023-02-18

【中文标题】在过滤后的闪亮散点图中保留现有选择

【英文标题】：Retaining existing selection in filtered shiny plotly scatter plot

【发布时间】：2021-09-19 01:46:41

【问题描述】：

我试图制作闪亮的过滤散点图，几乎准备将其集成到我的主要项目中，但是，只要选择将滤波器相关的选择重置为其默认设置就会重置。强>

对于上下文，我的示例使用 Iris 数据集，将每个花瓣宽度显示为可选择的绘图，并允许您独立查看与这些宽度相关的花瓣长度。问题是每当我更改选择的踏板宽度时，花瓣长度都会重置为默认值。

我认为这可能会导致错误，因为我正在寻找一个对我的示例数据来说不是有效选项的长度，但是对于我的项目用例来说，这将非常有帮助。

附件是我当前状态的代码。

library(shinydashboard)
library(shinyWidgets)
library(plotly)
library(shiny)

#______________________________________________________________________________#
server <- function(input, output, session)  
    df <- reactive(
        subset(iris, Petal.Width %in% input$Petalw)
    )
    
    # Extract list of Petal Lengths from selected data - to be used as a filter
    p.lengths <- reactive(
        unique(df()$Petal.Length)
    )
    
    # Filter based on Petal Length
    output$PetalL <- renderUI(
        pickerInput("PetalLengthSelector", "PetalLength", as.list(p.lengths()), as.list(p.lengths()), options = list(`actions-box` = TRUE),multiple = T)
        
    )
    
    # Subset this data based on the values selected by user
    df_1 <- reactive(
        foo <- subset(df(), Petal.Length %in% input$PetalLengthSelector)
        return(foo)
    )
    
    #output table
    output$table <- DT::renderDataTable(
        DT::datatable(df_1(), options = list(searching = FALSE,pageLength = 25))
    )
    #output scatter plot
    
    output$correlation_plot <- renderPlotly(
        fig <- plot_ly(
            data = df_1(),
            x = ~Sepal.Length, 
            y = ~Sepal.Width, 
            type = 'scatter', 
            mode = 'markers',
            #mode ="lines+markers",
            color =~Petal.Length,
            text = ~paste("Sepal.Length:",Sepal.Length,"<br>",
                          "Sepal.Width:",Sepal.Width,"<br>",
                          "Petal.Length:",Petal.Length,"<br>",
                          "Petal.Width:",Petal.Width,"<br>",
                          "Species:",Species),
            hoverinfo = 'text'
        ) 
        
    )
    


#______________________________________________________________________________#
ui <- navbarPage(
    title = 'Select values in two columns based on two inputs respectively',
    
    fluidRow(
        column(width = 12,
               plotlyOutput('correlation_plot')
        )
    ),
    
    
    fluidRow(
        column(width = 6,
               pickerInput("Petalw","PetalWidth", choices = unique(iris$Petal.Width),selected = unique(iris$Petal.Width), options = list(`actions-box` = TRUE),multiple = T)
        ),
        column(width = 6,
               uiOutput("PetalL")
        )
    ),
    
    fluidRow(
        column(12,
               tabPanel('Table', DT::dataTableOutput('table'))
        )
    )
)
shinyApp(ui, server)

【参考方案1】：

我会将df 数据框定义为带有新actionButton 的eventReactive 对象。这样它只会在您单击actionButton 时更新。然后您可以避免更新第二个pickerInput，同时仍然选择第一个pickerInput 中的项目。试试这个

library(shinydashboard)
library(shinyWidgets)
library(tidyverse)
library(plotly)
library(shiny)
library(DT)

#______________________________________________________________________________#
server <- function(input, output, session) 
  df <- eventReactive(input$update, 
    req(input$Petalw)
    subset(iris, Petal.Width %in% input$Petalw)
  )
  
  # Extract list of Petal Lengths from selected data - to be used as a filter
  p.lengths <- reactive(
    req(df())
    unique(df()$Petal.Length)
  )
  
  # Filter based on Petal Length
  output$PetalL <- renderUI(
    req(p.lengths())
    pickerInput("PetalLengthSelector", "PetalLength", 
                choices = as.list(p.lengths()), 
                selected = as.list(p.lengths()),
                options = list(`actions-box` = TRUE),multiple = T)
    
  )
  
  # Subset this data based on the values selected by user
  df_1 <- reactive(
    req(df(),input$PetalLengthSelector)
    foo <- subset(df(), Petal.Length %in% input$PetalLengthSelector)
    return(foo)
  )
  
  output$table <- DT::renderDataTable(
    DT::datatable(df_1(), options = list(searching = FALSE,pageLength = 25))
  )
  
  ### this works
  
  # output$correlation_plot <- renderPlotly(
  #   req(df_1())
  #   text = paste("Sepal.Length:",df_1()$Sepal.Length,"<br>",
  #                "Sepal.Width:", df_1()$Sepal.Width,"<br>",
  #                "Petal.Length:",df_1()$Petal.Length,"<br>",
  #                "Petal.Width:", df_1()$Petal.Width,"<br>",
  #                "Species:",df_1()$Species)
  #   plot1 <- plot_ly(data=df_1(),
  #                    x = ~Petal.Length,
  #                    y = ~Petal.Width,
  #                    type = 'scatter',
  #                    mode = "markers",
  #                    color =~Petal.Length,
  #                    text = text,
  #                    hoverinfo = 'text'
  #                    
  #   )
  # )
  
  output$correlation_plot <- renderPlotly(
    fig <- plot_ly(
      data = df_1(),
      x = ~Sepal.Length, 
      y = ~Sepal.Width, 
      type = 'scatter', 
      mode = 'markers',
      color =~Petal.Length,
      text = ~paste("Sepal.Length:",Sepal.Length,"<br>",
                    "Sepal.Width:",Sepal.Width,"<br>",
                    "Petal.Length:",Petal.Length,"<br>",
                    "Petal.Width:",Petal.Width,"<br>",
                    "Species:",Species),
      hoverinfo = 'text'
    ) 
    
  )
  



#______________________________________________________________________________#
ui <- navbarPage(
  title = 'Select values in two columns based on two inputs respectively',
  
  fluidRow(
    column(width = 12,
           plotlyOutput('correlation_plot')
    )
  ),
  
  
  fluidRow(
    column(width = 3,
           pickerInput("Petalw","PetalWidth", choices = unique(iris$Petal.Width),selected = c("PetalWidth"), options = list(`actions-box` = TRUE),multiple = T)
    ),
    column(2, actionBttn("update","Update")), column(2,""),
    column(width = 5,
           uiOutput("PetalL")
    )
  ),
  tags$style(type='text/css', "#update  width:100%; margin-top: 25px;"),   ### aligning action button with pickerInput
  fluidRow(
    column(12,
           tabPanel('Table', DT::dataTableOutput('table'))
    )
  )
)
shinyApp(ui, server)

【讨论】：

我很欣赏这次尝试，但我的特别目标是让第二个 pickerInput 在提供新信息后保留其选择，而不是延迟更新。