Plotly 可拖动图中的 reactiveValue() 问题

Posted 2023-02-18

【中文标题】Plotly 可拖动图中的 reactiveValue() 问题

【英文标题】：Problems with reactiveValue() in Plotly draggable graph

【发布时间】：2021-12-26 15:04:54

【问题描述】：

提前感谢您的帮助，因为这真的让我发疯。我正在尝试创建一个情节散点图，我可以通过拖动它们来更改单个图的位置，从而更改回归线。重要的是，我想通过 pickerInput 过滤数据，只对数据的子集运行分析。

大多数事情都在工作，但是我对使用 reactiveValues() 感到困惑。更具体地说，我相信 reactiveValues() 不能采用反应性数据帧……在这种情况下，是 mtcars 的过滤版本。我已经尝试了各种各样的事情，现在变得有点绝望。下面是代码。我还附上了代码的简化版本的代码，它工作得很好，但没有所有重要的过滤功能。

请帮忙！

library(plotly)
library(purrr)
library(shiny)

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 = unique(mtcars$cyl))),
                         
                         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 <- reactiveValues(
    data = data()
    x = data$mpg,
    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(a
    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)

只是雪上加霜，这个版本的代码没有过滤就可以了。

library(plotly)
library(purrr)
library(shiny)

ui = navbarPage(windowTitle="Draggable Plot",
                tabPanel(title = "Draggable Plot",
                        
                         mainPanel(
                           plotlyOutput("p", height = "500px", width = "1000px"))))



server <- function(input, output, session) 
  
  rv <- reactiveValues(
    x = mtcars$mpg,
    y = mtcars$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(a
    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)

【参考方案1】：

以下内容应能解决您的疑虑。

  rv <- reactiveValues()
  
  observe(
    rv$data = data()
    rv$x = data()$mpg
    rv$y = data()$wt
  )

【讨论】：

非常感谢 YBS！...该解决方案很有效。