Thanks for your help in advance as this one is really driving me mad. I am trying to create a plotly scatterplot where I can change the location of single plots by dragging them, thus changing the regression line. Importantly, I would like to filter the data through a pickerInput, to only run the analysis for a subset of the data.

Most things are working, however I am coming unstuck with my use of reactiveValues(). More, specifically, I believe reactiveValues() can't take a reactive dataframe...in this case a filtered version of mtcars. I have tried all sorts of things and am now getting a little desperate. Below is the code. I have also attached code of a simplified version of the code, which works just fine however doesn't have the all important filtering capability.

Please help!

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)

Just to add insult to injury, this version of the code without filtering works just fine.

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)

CodePudding user response：

The following should address your concerns.

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