Search code examples
rshinyplotlypurrrshiny-reactivity

How to create a draggable plot in R Shiny using a reactive dataframe?

In Code1 below I am trying to create a draggable plot using the plotly package. The user should be able to drag the points of the plot and capture the new points in the data frame rendered to the left called "Data1". When running the code I get the error "Warning: Error in <-: invalid (NULL) left side of assignment". What am I doing wrong?

As an FYI, Code2 below does just this but using a different data set, though both are structured the same. In running Code2, I compare the data frame that works in Code2 (called "Data") with the data frame that does not work in Code1 ("Data1") to show how similarly the two data frames are in structure. Drag the plotted data points in Code2 and see how nicely the "Data" table to the left updates. This is what I'm trying to get at in Code1, but instead by using Data1 data.

Solution spoiler: see ismirsehregal answer below. The difference between Code1 and Code2, where Code1 fails and Code2 doesn't, is due to the inappropriate use of reactive() in defining the data1() dataframe in Code1. Since data1() is modified from different places (sliderInput(), the drag feauture in plotly), reactiveVal() or reactiveValues() must be used and not reactive() in defining the dataframe. Also note the use of reactiveValuesToList() in rendering the modified dataframe after dragging a plot point.

Code1:

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

ui <- fluidPage(
  fluidRow(column(5,sliderInput('periods','Nbr of periods:',min=0,max=24,value=12))),
  fluidRow(column(2,h5("Data1:"),tableOutput('data1')),
           column(6, plotlyOutput("p")))
)

server <- function(input, output, session) {
  data1 <- reactive({
    data.frame(
      x = c(1:input$periods),
      y = c((0.15-0.70)*(exp(-50/100*(1:input$periods))-exp(-50/100*input$periods)*
            (1:input$periods)/input$periods)) + 0.70
    )
  })

  output$p <- renderPlotly({
    circles <- map2(data1()$x, data1()$y, 
                    ~list(type = "circle",
                          xanchor = .x,
                          yanchor = .y,
                          x0 = -4, x1 = 4,
                          y0 = -4, y1 = 4,
                          xsizemode = "pixel", 
                          ysizemode = "pixel",
                          fillcolor = "blue",
                          line = list(color = "transparent"))
                    )
    plot_ly() %>%
      add_lines(x = data1()$x, y = data1()$y, color = I("red")) %>%
      layout(shapes = circles) %>%
      config(edits = list(shapePosition = TRUE))
  })
 
  output$data1 <- renderTable(data1())
  
  # 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)
    data1()$x[row_index] <- pts[1]
    data1()$y[row_index] <- pts[2]
  })
  
}

shinyApp(ui, server)

Code2:

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

ui <- fluidPage(
  fluidRow(column(5,sliderInput('periods','Nbr of periods:',min=0,max=24,value=12))),
  fluidRow(
    column(2,h5(strong(("Data:"))),tableOutput('data')),
    column(2,h5(strong(("Data1:"))),tableOutput('data1')),
    column(6,h5(strong(("Move the points and see how `Data` table to left updates:"))), plotlyOutput("p")),
  ),
  fluidRow(h5(strong(("Data1 above shown for comparison purposes, would like to substitute Data with Data1 in the plot"))))
)

server <- function(input, output, session) {
  rv <- reactiveValues( x = mtcars$mpg,y = mtcars$wt)
  
  data <- reactive(data.frame(x=(rv$x_sub),y=(rv$y_sub)))
  
  data1 <- reactive({
    data.frame(
      x = c(1:input$periods),
      y = c((0.15-0.70) * (exp(-50/100*(1:input$periods))-
          exp(-50/100*input$periods)*(1:input$periods)/input$periods)) + 0.70
    )
  })
  
  observe({
    rv$x_sub <- rv$x[1:input$periods]
    rv$y_sub <- rv$y[1:input$periods]
  })
 
  output$p <- renderPlotly({
    circles <- map2(rv$x_sub, rv$y_sub, 
                    ~list(
                      type = "circle",
                      xanchor = .x,
                      yanchor = .y,
                      x0 = -4, x1 = 4,
                      y0 = -4, y1 = 4,
                      xsizemode = "pixel", 
                      ysizemode = "pixel",
                      fillcolor = "blue",
                      line = list(color = "transparent")
                    )
    )
    plot_ly() %>%
      add_lines(x = rv$x_sub, y = rv$y_sub, color = I("red")) %>%
      layout(shapes = circles) %>%
      config(edits = list(shapePosition = TRUE))
  })
 
  output$data <- renderTable(data())
  output$data1 <- renderTable(data1())
  
  # 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)
Solution

  • Unfortunately you can't modify a reactive in multiple places. For this use case reactiveVal or reactiveValues are intended.

    Please check the following:

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

ui <- fluidPage(
  fluidRow(column(5,sliderInput('periods','Nbr of periods:',min=0,max=24,value=12))),
  fluidRow(column(2,h5("Data1:"),tableOutput('data1table')),
           column(6, plotlyOutput("p")))
)

server <- function(input, output, session) {
  data1 <- reactiveValues(x = NULL, y = NULL)
  
  observe({
    data1$x <- c(1:input$periods)
    data1$y <- c((0.15-0.70)*(exp(-50/100*(1:input$periods))-exp(-50/100*input$periods)*
                           (1:input$periods)/input$periods)) + 0.70
  })
  
  output$p <- renderPlotly({
    circles <- map2(data1$x, data1$y, 
                    ~list(type = "circle",
                          xanchor = .x,
                          yanchor = .y,
                          x0 = -4, x1 = 4,
                          y0 = -4, y1 = 4,
                          xsizemode = "pixel", 
                          ysizemode = "pixel",
                          fillcolor = "blue",
                          line = list(color = "transparent"))
    )
    plot_ly() %>%
      add_lines(x = data1$x, y = data1$y, color = I("red")) %>%
      layout(shapes = circles) %>%
      config(edits = list(shapePosition = TRUE))
  })
  
  output$data1table <- renderTable({
    as.data.frame(reactiveValuesToList(data1))
  })
  
  # 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)
    data1$x[row_index] <- pts[1]
    data1$y[row_index] <- pts[2]
  })
  
}

shinyApp(ui, server)

    result