问题
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)
回答1:
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);
Plotly.plot(id).then(attach);
function attach() {
var xaxis = gd._fullLayout.xaxis;
var yaxis = gd._fullLayout.yaxis;
var coordinates = [null, null]
gd.addEventListener('click', function(evt) {
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 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)
})
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.plot(id).then(attach);
function attach() {
var xaxis = gd._fullLayout.xaxis;
var yaxis = gd._fullLayout.yaxis;
var coordinates = [null, null]
gd.addEventListener('click', function(evt) {
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 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)
})
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)
来源：https://stackoverflow.com/questions/64309573/r-shiny-freehand-drawing-ggplot-how-to-improve-and-or-format-for-plotly