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

Question

I'm attempting to make a filtered scatter plot in shiny and am nearly ready to integrate it into my main project, however, whenever the selection changes the filter-dependent selections reset to their default settings.

对于上下文，我的示例使用 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)

Answer 1

我会将数据框定义df为一个eventReactive带有新的对象actionButton。这样，它仅在您单击 时才会更新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)