Plotly可拖拽散点图使用reactiveValue加载过滤数据报错求解

问题修复说明 #

你的代码存在4处可直接修复的问题：

• 语法错误：reactiveValues定义中data = data()后缺少逗号，直接导致代码无法解析
• 依赖缺失：pickerInput是shinyWidgets包的功能，未加载该包会报函数不存在的错误
• 响应式逻辑错误：不能在reactiveValues初始化时直接调用reactive对象data()，reactive对象仅能在响应式上下文中使用，且初始化阶段输入控件的值还未完成加载
• 参数不匹配：你设置了multiple = FALSE（单选模式），但selected参数传入了所有气缸数的取值，单选模式下默认选中值仅能为单个选项

修复的核心逻辑是新增observeEvent监听过滤后数据集的变化，每次用户修改气缸筛选条件时，自动更新reactiveValues中存储的坐标值，同时保留原有的拖拽修改坐标的逻辑。

修正后完整可运行代码 #

library(plotly)
library(purrr)
library(shiny)
library(shinyWidgets) # 新增pickerInput依赖包

ui = navbarPage(windowTitle="Draggable Plot",
                tabPanel(title = "Draggable Plot",
                         sidebarPanel(width = 2,
                                      pickerInput("Cylinders","Select Cylinders", 
                                                  choices = unique(mtcars$cyl), 
                                                  options = list(`actions-box` = TRUE),
                                                  multiple = FALSE, 
                                                  selected = 4)), # 单选模式下默认选中4缸
                         
                         mainPanel(
                           plotlyOutput("p", height = "500px", width = "1000px"),
                           verbatimTextOutput("summary"))))


server <- function(input, output, session) {
  
  data = reactive({
    data = mtcars
    data <- data[data$cyl %in% input$Cylinders,]
    return(data)
  })
  
  # 初始化rv，默认先存储全量数据坐标
  rv <- reactiveValues(
    x = mtcars$mpg,
    y = mtcars$wt
  )
  
  # 新增监听：过滤条件变化时更新rv的坐标值
  observeEvent(data(), {
    rv$x = data()$mpg
    rv$y = data()$wt
  })
  
  grid <- reactive({
    data.frame(x = seq(min(rv$x), max(rv$x), length = 10))
  })
  model <- reactive({
    d <- data.frame(x = rv$x, y = rv$y)
    lm(y ~ x, d)
  })
  
  output$p <- renderPlotly({
    # creates a list of circle shapes from x/y data
    circles <- map2(rv$x, rv$y, 
                    ~list(
                      type = "circle",
                      # anchor circles at (mpg, wt)
                      xanchor = .x,
                      yanchor = .y,
                      # give each circle a 2 pixel diameter
                      x0 = -4, x1 = 4,
                      y0 = -4, y1 = 4,
                      xsizemode = "pixel", 
                      ysizemode = "pixel",
                      # other visual properties
                      fillcolor = "blue",
                      line = list(color = "transparent")
                    )
    )
    
    # plot the shapes and fitted line
    plot_ly() %>%
      add_lines(x = grid()$x, y = predict(model(), grid()), color = I("red")) %>%
      layout(shapes = circles) %>%
      config(edits = list(shapePosition = TRUE))
  })
  
  output$summary <- renderPrint({
    summary(model())
  })
  
  # update x/y reactive values in response to changes in shape anchors
  observe({
    ed <- event_data("plotly_relayout")
    shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
    if (length(shape_anchors) != 2) return()
    row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
    pts <- as.numeric(shape_anchors)
    rv$x[row_index] <- pts[1]
    rv$y[row_index] <- pts[2]
  })
  
}

shinyApp(ui, server)

内容的提问来源于stack exchange，提问作者Dorian von Freyhold