使用 plotlyProxy 按名称删除跟踪（或在响应式上下文中访问输出模式）
Mat*_*ill 5 r shiny plotly r-plotly
我正在尝试使用该plotlyProxy()功能（此处记录）来允许闪亮应用程序的用户以最小的延迟添加和删除跟踪。
添加跟踪证明相对简单，但我很难弄清楚如何按名称删除跟踪（我只看到按跟踪编号删除的记录示例）。
有没有办法使用名称删除痕迹plotlyProxy()？
如果没有，有没有办法可以解析输出对象以推导出与给定名称相关联的跟踪编号？
我可以使用标准模式索引在交互式 R 会话中确定给定名称的关联跟踪号，但是当我尝试在闪亮的应用程序中应用相同的逻辑时，我收到一个错误：“$.shinyoutput 中的错误：从不允许闪亮的输出对象。”
下面是一个最小的例子。观察Remove按钮的观察者都没有实际工作，但他们应该对我试图实现的功能提出一个想法。
library(shiny)
library(plotly)
ui <- fluidPage(
textInput("TraceName", "Trace Name"),
actionButton("Add","Add Trace"),
actionButton("Remove","Remove Trace"),
plotlyOutput("MyPlot")
)
server <- function(input,output,session) {
## Creaing the plot
output$MyPlot <- renderPlotly({
plot_ly() %>%
layout(showlegend = TRUE)
})
## Adding traces is smooth sailing
observeEvent(input$Add,{
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
type = "scatter",mode = "markers",
name = input$TraceName))
})
## Ideal Solution (that does not work)
observeEvent(input$Remove,{
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", input$TraceName)
})
## Trying to extract tracenames throws an error:
## Warning: Error in $.shinyoutput: Reading objects from shinyoutput object not allowed.
observeEvent(input$Remove,{
TraceNames <- unlist(lapply(seq_along(names(output$MyPlot$x$attrs)),
function(x) output$MyPlot$x$attrs[[x]][["name"]]))
ThisTrace <- which(TraceNames == input$TraceName)
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", ThisTrace)
})
}
shinyApp(ui, server)
编辑使用plotlyProxy：
更新@SeGa，感谢添加对删除重复名称痕迹的支持！
最后，我找到了一个通过调整这个答案来实现预期行为的解决方案。单击删除按钮后，我通过使用onRenderfrom接收了trace.name/trace.index 映射：library(htmlwidgets)
library(shiny)
library(plotly)
library(htmlwidgets)
js <- "function(el, x, inputName){
var id = el.getAttribute('id');
var d3 = Plotly.d3;
$(document).on('shiny:inputchanged', function(event) {
if (event.name === 'Remove') {
var out = [];
d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){
var trace = d3.select(this)[0][0].__data__[0].trace;
out.push([name=trace.name, index=trace.index]);
});
Shiny.setInputValue(inputName, out);
}
});
}"
ui <- fluidPage(
textInput("TraceName", "Trace Name"),
verbatimTextOutput("PrintTraceMapping"),
actionButton("Add", "Add Trace"),
actionButton("Remove", "Remove Trace"),
plotlyOutput("MyPlot")
)
server <- function(input, output, session) {
output$MyPlot <- renderPlotly({
plot_ly(type = "scatter", mode = "markers") %>%
layout(showlegend = TRUE) %>% onRender(js, data = "TraceMapping")
})
output$PrintTraceMapping <- renderPrint({unlist(input$TraceMapping)})
observeEvent(input$Add, {
req(input$TraceName)
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
type = "scatter",mode = "markers",
name = input$TraceName))
})
observeEvent(input$Remove, {
req(input$TraceName, input$TraceMapping)
traces <- matrix(input$TraceMapping, ncol = 2, byrow = TRUE)
indices <- as.integer(traces[traces[, 1] == input$TraceName, 2])
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", indices)
})
}
shinyApp(ui, server)
结果：
在这方面有用的文章：
使用闪亮模块的解决方案plotlyProxy：
library(shiny)
library(plotly)
library(htmlwidgets)
js <- "function(el, x, data){
var id = el.getAttribute('id');
var d3 = Plotly.d3;
$(document).on('shiny:inputchanged', function(event) {
if (event.name.indexOf('Remove') > -1) {
var out = [];
d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){
var trace = d3.select(this)[0][0].__data__[0].trace;
out.push([name=trace.name, index=trace.index]);
});
Shiny.setInputValue(data.ns + data.x, out);
}
});
}"
plotly_ui_mod <- function(id) {
ns <- NS(id)
tagList(
textInput(ns("TraceName"), "Trace Name"),
verbatimTextOutput(ns("PrintTraceMapping")),
actionButton(ns("Add"), "Add Trace"),
actionButton(ns("Remove"), "Remove Trace"),
plotlyOutput(ns("MyPlot"))
)
}
plotly_server_mod <- function(input, output, session) {
sessionval <- session$ns("")
output$MyPlot <- renderPlotly({
plot_ly(type = "scatter", mode = "markers") %>%
layout(showlegend = TRUE) %>% onRender(js, data = list(x = "TraceMapping",
ns = sessionval))
})
output$PrintTraceMapping <- renderPrint({unlist(input$TraceMapping)})
observeEvent(input$Add, {
req(input$TraceName)
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
type = "scatter",mode = "markers",
name = input$TraceName))
})
observeEvent(input$Remove, {
req(input$TraceName, input$TraceMapping)
traces <- matrix(input$TraceMapping, ncol = 2, byrow = TRUE)
indices <- as.integer(traces[traces[, 1] == input$TraceName, 2])
plotlyProxy("MyPlot", session) %>%
plotlyProxyInvoke("deleteTraces", indices)
})
}
ui <- fluidPage(
plotly_ui_mod("plotly_mod")
)
server <- function(input, output, session) {
callModule(plotly_server_mod, "plotly_mod")
}
shinyApp(ui, server)
以前的解决方案避免plotlyProxy：
我是通过这个问题来到这里的。
您明确要求，plotlyProxy()所以我不确定这对您是否有帮助，但这里有一个解决方法，可以通过更新提供的数据plot_ly()而不是使用来实现预期行为plotlyProxy()：
library(shiny)
library(plotly)
ui <- fluidPage(
selectizeInput(inputId="myTraces", label="Trace names", choices = NULL, multiple = TRUE, options = list('plugins' = list('remove_button'), 'create' = TRUE, 'persist' = TRUE, placeholder = "...add or remove traces")),
plotlyOutput("MyPlot")
)
server <- function(input, output, session){
myData <- reactiveVal()
observeEvent(input$myTraces, {
tmpList <- list()
for(myTrace in input$myTraces){
tmpList[[myTrace]] <- data.frame(name = myTrace, x = rnorm(10),y = rnorm(10))
}
myData(do.call("rbind", tmpList))
return(NULL)
}, ignoreNULL = FALSE)
output$MyPlot <- renderPlotly({
if(is.null(myData())){
plot_ly(type = "scatter", mode = "markers")
} else {
plot_ly(myData(), x = ~x, y = ~y, color = ~name, type = "scatter", mode = "markers") %>%
layout(showlegend = TRUE)
}
})
}
shinyApp(ui, server)