inst/examples/shiny/drag_markers/app.R

In plotly: Create Interactive Web Graphics via 'plotly.js'

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

ui <- fluidPage(
  fluidRow(
    column(5, verbatimTextOutput("summary")),
    column(7, plotlyOutput("p"))
  )
)

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)