add shiny example of dragging markers (for interactive lm)

Author: cpsievert

inst/examples/shiny/drag_markers/app.R

@@ -0,0 +1,69 @@
+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)