Freehand drawing ggplot. How to improve and/or format for plotly?

Question

I have a client that wants to be able to "freehand" draw on a plotly (ggplot) graph in Rshiny. I said to use the lasso select button on plotly graphs, but they were not happy that if you click somewhere else on the graph it removes the first lasso.

Using this post, I was able to workup a ggplot that I could draw on. I cannot however get it to work with plotly as I do not know the equivalent of the hover options in the ui below. I would love some input on how to do this with plotly, how to improve the code to make it faster, and/or how to not have it start at the arbitrary value of (1,1).

Understandably, this only works if the data is completely numeric. Would there be a way to do this if say the first column in data was c("a","b","c") instead of c(1,2,3) like I have below.

Note: The line starts at (1,1) for the first click because ggplot needed a value to graph, but the reactive inputs needed a graph. To get around this loop I just put the columns at c(1,vals$x)... hope that made sense.

library(shiny)
library(tidyverse)
ui <- fluidPage(
  actionButton("reset", "reset"),
  plotOutput("plot",
             hover=hoverOpts(id = "hover", delay = 300, delayType = "throttle", clip = TRUE, nullOutside = TRUE),
             click="click"))


server <- function(input, output, session) {
  vals = reactiveValues(x=NULL, y=NULL)
  draw = reactiveVal(FALSE)
  observeEvent(input$click, handlerExpr = {
    temp <- draw(); draw(!temp)
    if(!draw()) {
      vals$x <- c(vals$x, NA)
      vals$y <- c(vals$y, NA)
    }})
  observeEvent(input$reset, handlerExpr = {
    vals$x <- NULL; vals$y <- NULL
  })
  observeEvent(input$hover, {
    if (draw()) {
      vals$x <- c(vals$x, input$hover$x)
      vals$y <- c(vals$y, input$hover$y)
    }})
  output$plot= renderPlot({
    Data<-cbind(c(1,2,3),c(2,3,4))%>%as.data.frame()
    d<-cbind(c(1,vals$x),c(1,vals$y))%>%as.data.frame()
    ggplot(data=Data)+geom_point(data=Data,aes(x=V1,y=V2))+
    geom_path(data=d,aes(x=V1,y=V2))+xlim(c(0,15))+ylim(c(0,15))
  })
  }

shinyApp(ui, server)

hi, i saw your comment on my post. From a quick search of hover options with plotly, it seems that you can get only the information and trigger events when the mouse is over an existing point, not over a blank zone. But i don't say it can't be done... :-) — agenis, Oct 12 '20 at 13:06
@agenis thanks for post on the other one, it was super helpful to sending me in the right direction. I'll have to keep playing around with plotly to see if I can finagle something. Ignoring plotly, can you think of a better way to do this with ggplot in general? This works but it lacks finesse for me. — andrewjc, Oct 12 '20 at 19:37
yeah ,well, not so optimistic. GGplot is quite a heavy interface and hover requires that you upload your plot very frequently to make the drawing "smooth", which in turns creates some lag... so it's a bad compromise between lag and smoothness of the drawing.. i saw you tried to modify the `delay` parameter... ;-) Maybe try ggvis? Or go with plotly with a big bounty on your question? i've read some interesting stuff here: https://stackoverflow.com/questions/41232780/update-large-plots-in-shiny-without-re-rendering — agenis, Oct 12 '20 at 21:12
Thanks for the input! It really reassures me that I am not going crazy. I hadn't thought about ggvis so maybe that will be my next endeavor, thanks again! — andrewjc, Oct 13 '20 at 03:34

ismirsehregal · Accepted Answer · 2022-02-23T09:29:57.563

Edit: The Plotly.plot() function has been deprecated - now using Plotly.update() instead:

First of all you can have multiple lasso selections in plotly via pressing shift.

The following is a modification of my answer here - so it's plot_ly / plotlyProxy based, modifying the existing plotly object (without re-rendering) not using ggplotly. As there is some related work going on in a GitHub issue and PR the below answer might not be 100% reliable (e.g. zooming seems to mess things up - you might want to deactivate it) and may become obsolete.

Nevertheless, please check the following:

library(plotly)
library(shiny)
library(htmlwidgets)

ui <- fluidPage(
  plotlyOutput("myPlot"),
  verbatimTextOutput("click")
)

server <- function(input, output, session) {

  js <- "
    function(el, x){
      var id = el.getAttribute('id');
      var gd = document.getElementById(id);
      var d3 = Plotly.d3;
      Plotly.update(id).then(attach);
        function attach() {
          gd.addEventListener('click', function(evt) {
            var xaxis = gd._fullLayout.xaxis;
            var yaxis = gd._fullLayout.yaxis;
            var bb = evt.target.getBoundingClientRect();
            var x = xaxis.p2d(evt.clientX - bb.left);
            var y = yaxis.p2d(evt.clientY - bb.top);
            var coordinates = [x, y];
            Shiny.setInputValue('clickposition', coordinates);
          });
          gd.addEventListener('mousemove', function(evt) {
            var xaxis = gd._fullLayout.xaxis;
            var yaxis = gd._fullLayout.yaxis;
            var bb = evt.target.getBoundingClientRect();
            var x = xaxis.p2d(evt.clientX - bb.left);
            var y = yaxis.p2d(evt.clientY - bb.top);
            var coordinates = [x, y];
            Shiny.setInputValue('mouseposition', coordinates);
          });
        };
  }
  "

  output$myPlot <- renderPlotly({
    plot_ly(type = "scatter", mode = "markers") %>% layout(
      xaxis = list(range = c(0, 100)),
      yaxis = list(range = c(0, 100))) %>%
      onRender(js, data = "clickposition")
  })

  myPlotProxy <- plotlyProxy("myPlot", session)

  followMouse <- reactiveVal(FALSE)
  traceCount <- reactiveVal(0L)

  observeEvent(input$clickposition, {
    followMouse(!followMouse())

    if(followMouse()){
      plotlyProxyInvoke(myPlotProxy, "addTraces", list(x = list(input$clickposition[1]), y = list(input$clickposition[2])))
      traceCount(traceCount()+1)
    }
  })

  observe({
    if(followMouse()){
      plotlyProxyInvoke(myPlotProxy, "extendTraces", list(x = list(list(input$mouseposition[1])), y = list(list(input$mouseposition[2]))), list(traceCount()))
    }
  })

}

shinyApp(ui, server)

If you rather want to work with a single trace:

library(plotly)
library(shiny)
library(htmlwidgets)

ui <- fluidPage(
  plotlyOutput("myPlot"),
  verbatimTextOutput("click")
)

server <- function(input, output, session) {
  
  js <- "
    function(el, x){
      var id = el.getAttribute('id');
      var gd = document.getElementById(id);
      Plotly.update(id).then(attach);
        function attach() {
          gd.addEventListener('click', function(evt) {
            var xaxis = gd._fullLayout.xaxis;
            var yaxis = gd._fullLayout.yaxis;
            var bb = evt.target.getBoundingClientRect();
            var x = xaxis.p2d(evt.clientX - bb.left);
            var y = yaxis.p2d(evt.clientY - bb.top);
            var coordinates = [x, y];
            Shiny.setInputValue('clickposition', coordinates);
          });
          gd.addEventListener('mousemove', function(evt) {
            var xaxis = gd._fullLayout.xaxis;
            var yaxis = gd._fullLayout.yaxis;
            var bb = evt.target.getBoundingClientRect();
            var x = xaxis.p2d(evt.clientX - bb.left);
            var y = yaxis.p2d(evt.clientY - bb.top);
            var coordinates = [x, y];
            Shiny.setInputValue('mouseposition', coordinates);
          });
        };
  }
  "
  
  output$myPlot <- renderPlotly({
    plot_ly(type = "scatter", mode = "markers") %>% layout(
      xaxis = list(range = c(0, 100)),
      yaxis = list(range = c(0, 100))) %>%
      onRender(js, data = "clickposition")
  })
  
  myPlotProxy <- plotlyProxy("myPlot", session)

  followMouse <- reactiveVal(FALSE)
  clickCount <- reactiveVal(0L)
  
  observeEvent(input$clickposition, {
    followMouse(!followMouse())
    clickCount(clickCount()+1)
    
    if(clickCount() == 1){
      plotlyProxyInvoke(myPlotProxy, "addTraces", list(x = list(input$clickposition[1]), y = list(input$clickposition[2])))
    }
    
  })
  
  observe({
    if(followMouse()){
      plotlyProxyInvoke(myPlotProxy, "extendTraces", list(x = list(list(input$mouseposition[1])), y = list(list(input$mouseposition[2]))), list(1)) 
    } else {
      plotlyProxyInvoke(myPlotProxy, "extendTraces", list(x = list(list(NA)), y = list(list(NA))), list(1))
    }
  })

}

shinyApp(ui, server)

Wow this is some pretty cool stuff you have here! I will give it a try in the next day or two when I get a chance and accept your answer after I can test it out myself! Also thank you for pointing out the multiple lasso's with plotly, feel like I should have known that having working with plotly for a few months now..... — andrewjc, Oct 13 '20 at 19:24
what a fun set of code you posted. Thanks for sharing as I have been having a lot of fun playing around with it and modifying it for various iterations. Perhaps this is a good indication I should starting learning more JS, so thanks for the answer!! — andrewjc, Oct 14 '20 at 02:52
Is it possible to get back the coordinates of the free-hand drawings? — Hirak Sarkar, Jul 28 '21 at 16:14
They are accessible via `input$mouseposition`. You could save chunks of the data into a `reactiveVal` containing a list and split it by `input$clickposition` (just as I did to separate the traces). — ismirsehregal, Jul 28 '21 at 18:20

Freehand drawing ggplot. How to improve and/or format for plotly?

1 Answers1

Linked