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

Question

提前感谢您的帮助，因为这真的让我发疯。我正在尝试创建一个 plotly 散点图，我可以通过拖动它们来更改单个图的位置，从而更改回归线。重要的是，我想通过 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)

Answer 1

以下内容应该可以解决您的顾虑。

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

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

Problems with reactiveValue() in Plotly draggable graph

r

shiny

plotly

reactive