Problems with reactiveValue() in Plotly draggable graph - r

Question

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)

Answer 1

The following should address your concerns.
rv <- reactiveValues()
observe({
rv$data = data()
rv$x = data()$mpg
rv$y = data()$wt
})