如何在不重新渲染的情况下更新 show/hide R shiny 中 plotly widget 的痕迹以响应 actionbuttons
How to update show/hide traces of a plotly widget in R shiny in response to actionbuttons without re-rendering
我正在寻找一种方法 link actionButton 单击 legend 状态 true/legendonly 不会引起重新plotly 对象的 -rendering 而是更改 widget。底部的当前演示应用程序确实实现了 link，但通过完全重绘情节来实现。
我的目标是 link 指示 keep/drop 集群的按钮在两个方向 中以这样的方式可视化图中的数据 已更新，未呈现。我当前的解决方案确实会导致完全渲染。
交互是按钮改变 legend/plot & 图例改变按钮。
我添加了一些图片来解释工作流程。
我已经在我更大的实际应用程序中为更大的情节构建了一个测试版本，用户有这个视图：
在这里，用户可以通过 in/out 按钮选择要删除哪些集群以进行进一步处理。
感谢上一个问题 我现在有一个测试应用程序，其中：
- 1 单击图例更改图，左侧的按钮状态，因此用户可以使用图进行 IN/OUT 选择
- 2 每当绘图重新呈现时，它现在也会重新激活每个跟踪的先前 show/hide 状态。
第 1 点是这个工作流程：
第二点只是在 onRender
之前使用这行代码的情节代码
if(values$colors) { for(i in seq_along(p1$x$data)){
p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}
}
p1 %>% onRender(js, data = "tracesPlot1")
目前还有第三种交互，当用户单击按钮时，它会导致痕迹隐藏。这种方法就是这里的问题。它目前遵循下图中的橙色流程，但我希望通过避免重新渲染绘图的 javascript 解决方案来改变它：
演示应用程序
library(plotly)
library(shiny)
library(htmlwidgets)
js <- c(
"function(el, x, inputName){",
" var id = el.getAttribute('id');",
" var d3 = Plotly.d3;",
" el.on('plotly_restyle', function(evtData) {",
" var out = {};",
" d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
" var trace = d3.select(this)[0][0].__data__[0].trace;",
" out[trace.name] = trace.visible;",
" });",
" Shiny.setInputValue(inputName, out);",
" });",
"}")
YNElement <- function(idx){sprintf("YesNo_button-%d", idx)}
ui <- fluidPage(
fluidRow(
column(2,
h5("Keep/Drop choices linked to colorscheme 1"),
uiOutput('YNbuttons')
),
column(8,
plotlyOutput("plot1")
),
column(2,
h5('Switch grouping'),
actionButton(inputId = 'Switch', label = icon('refresh'), style = "color: #f7ad6e; background-color: white; border-color: #f7ad6e;
height: 40px; width: 40px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px")
), style = "margin-top:150px"
),
verbatimTextOutput("tracesPlot1"),
verbatimTextOutput("tracesPlot2")
)
server <- function(input, output, session) {
values <- reactiveValues(colors = T, NrOfTraces = length(unique(mtcars$cyl)))
output$plot1 <- renderPlotly({
print('plotting!')
if(values$colors) { colors <- c('red', 'blue', 'green') } else {colors <- c('black', 'orange', 'gray')}
p1 <- plot_ly()
p1 <- add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
p1 <- layout(p1, title = 'mtcars group by cyl with switching colors')
p1 <- plotly_build(p1)
if(values$colors) { for(i in seq_along(p1$x$data)){
p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}
}
p1 %>% onRender(js, data = "tracesPlot1")
})
observeEvent(input$Switch, { values$colors <- !values$colors })
##### THIS BLOCK links buttons -> plot, but causes it to render all over again
### this interaction is what I would like to replace by javascript
observeEvent(values$dYNbs_cyl_el, {
legenditems <- values$dYNbs_cyl_el
legenditems[which(legenditems == FALSE)] <- 'legendonly'
legenditems[which(legenditems == TRUE )] <- 'TRUE'
names(legenditems) <- sort(unique(mtcars$cyl))
values$legenditems <- as.list(legenditems)
})
observeEvent(values$NrOfTraces, {
values$dYNbs_cyl_el <- rep(T,values$NrOfTraces)
names(values$dYNbs_cyl_el) <- sapply(1:values$NrOfTraces, function(x) {YNElement(x)})
})
output$YNbuttons <- renderUI({
req(values$NrOfTraces)
lapply(1:values$NrOfTraces, function(el) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] == T ) {
div(actionButton(inputId = YNb, label = icon("check"), style = "color: #339FFF; background-color: white; border-color: #339FFF;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px"))
} else {
div(actionButton(inputId = YNb, label = icon("times"), style = "color: #ff4d4d; background-color: white; border-color: #ff4d4d;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px"))
}
})
})
flipYNb_FP1 <- function(idx){
YNb <- YNElement(idx)
values$dYNbs_cyl_el[[YNb]] <- !values$dYNbs_cyl_el[[YNb]]
}
observe({
lapply(1:values$NrOfTraces, function(ob) {
YNElement <- YNElement(ob)
observeEvent(input[[YNElement]], {
flipYNb_FP1(ob)
}, ignoreInit = T)
})
})
observeEvent(input$tracesPlot1, {
listTraces <- input$tracesPlot1
values$legenditems <- listTraces ## this line would save the legend status even if we remove the observer for the values$dYNbs_cyl_el list
listTracesTF <- gsub('legendonly', FALSE, listTraces)
listTracesTF <- as.logical(listTracesTF)
lapply(1:values$NrOfTraces, function(el) {
if(el <= length(listTracesTF)) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] != listTracesTF[el]) {
values$dYNbs_cyl_el[[YNb]] <- listTracesTF[el]
}
}
})
})
output$tracesPlot1 <- renderPrint({ unlist(input$tracesPlot1) })
output$tracesPlot2 <- renderPrint({ unlist(values$legenditems) })
}
shinyApp(ui, server)
已更新测试应用程序，尝试使用答案。仍然无法工作
library(plotly)
library(shiny)
library(htmlwidgets)
# js <- c(
# "function(el, x, inputName){",
# " var id = el.getAttribute('id');",
# " var d3 = Plotly.d3;",
# " el.on('plotly_restyle', function(evtData) {",
# " var out = {};",
# " d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
# " var trace = d3.select(this)[0][0].__data__[0].trace;",
# " out[trace.name] = trace.visible;",
# " });",
# " Shiny.setInputValue(inputName, out);",
# " });",
# "}")
js2 <- c(
"function(el, x, inputName){",
" var id = el.getAttribute('id');",
" if(id == inputName){",
" var data = el.data;",
" $('[id^=btn]').on('click', function() {",
" var index = parseInt(this.id.split('-')[1]);",
" var trace = index -1; ",
" var v0 = data[trace].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [trace]);",
" });",
" }",
"}")
YNElement <- function(idx){sprintf("btn-%d", idx)}
ui <- fluidPage(
fluidRow(
column(2,
h5("Keep/Drop choices linked to colorscheme 1"),
uiOutput('YNbuttons')
),
column(8,
plotlyOutput("plot1")
),
column(2,
h5('Switch grouping'),
actionButton(inputId = 'Switch', label = icon('refresh'), style = "color: #f7ad6e; background-color: white; border-color: #f7ad6e;
height: 40px; width: 40px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px")
), style = "margin-top:150px"
),
verbatimTextOutput("tracesPlot1"),
verbatimTextOutput("tracesPlot2")
)
server <- function(input, output, session) {
values <- reactiveValues(colors = T, NrOfTraces = length(unique(mtcars$cyl)))
output$plot1 <- renderPlotly({
print('plotting!')
values$legenditemNames <- sort(unique(mtcars$cyl))
if(values$colors) { colors <- c('red', 'blue', 'green') } else {colors <- c('black', 'orange', 'gray')}
p1 <- plot_ly()
p1 <- add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
p1 <- layout(p1, title = 'mtcars group by cyl with switching colors')
p1 <- plotly_build(p1)
if(values$colors) { for(i in seq_along(p1$x$data)){
p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}
}
p1 %>% onRender(js2, data = "tracesPlot1")
})
observeEvent(input$Switch, { values$colors <- !values$colors })
##### THIS BLOCK links buttons -> plot, but causes it to render all over again
# observeEvent(values$dYNbs_cyl_el, {
# legenditems <- values$dYNbs_cyl_el
# legenditems[which(legenditems == FALSE)] <- 'legendonly'
# legenditems[which(legenditems == TRUE )] <- 'TRUE'
# names(legenditems) <- values$legenditemNames
# values$legenditems <- as.list(legenditems)
# })
observeEvent(values$NrOfTraces, {
values$dYNbs_cyl_el <- rep(T,values$NrOfTraces)
names(values$dYNbs_cyl_el) <- sapply(1:values$NrOfTraces, function(x) {YNElement(x)})
})
output$YNbuttons <- renderUI({
req(values$NrOfTraces)
lapply(1:values$NrOfTraces, function(el) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] == T ) {
div(actionButton(inputId = YNb, label = icon("check"), style = "color: #339FFF; background-color: white; border-color: #339FFF;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px"))
} else {
div(actionButton(inputId = YNb, label = icon("times"), style = "color: #ff4d4d; background-color: white; border-color: #ff4d4d;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px"))
}
})
})
flipYNb_FP1 <- function(idx){
YNb <- YNElement(idx)
values$dYNbs_cyl_el[[YNb]] <- !values$dYNbs_cyl_el[[YNb]]
}
observe({
lapply(1:values$NrOfTraces, function(ob) {
YNElement <- YNElement(ob)
observeEvent(input[[YNElement]], {
flipYNb_FP1(ob)
}, ignoreInit = T)
})
})
observeEvent(input$tracesPlot1, {
listTraces <- input$tracesPlot1
values$legenditems <- listTraces
listTracesTF <- gsub('legendonly', FALSE, listTraces)
listTracesTF <- as.logical(listTracesTF)
lapply(1:values$NrOfTraces, function(el) {
if(el <= length(listTracesTF)) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] != listTracesTF[el]) {
values$dYNbs_cyl_el[[YNb]] <- listTracesTF[el]
}
}
})
})
output$tracesPlot1 <- renderPrint({ unlist(input$tracesPlot1) })
output$tracesPlot2 <- renderPrint({ unlist(values$legenditems) })
}
shinyApp(ui, server)
你能试试这个吗:
library(plotly)
library(shiny)
library(htmlwidgets)
js <- c(
"function(el, x){",
" var data = el.data;",
" $('#btn').on('click', function() {",
" var traceName = $('#selector').val();",
" $.each(data, function(index,value){",
" if(value.name == traceName){",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [index]);",
" }",
" });",
" });",
"}")
ui <- fluidPage(
plotlyOutput("plot"),
selectInput("selector", "", choices = c("drat", "wt", "qsec")),
actionButton("btn", "Show/hide")
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p %>% onRender(js)
})
}
shinyApp(ui, server)
如果你有多个地块：
js <- c(
"function(el, x, plotid){",
" var id = el.getAttribute('id');",
" if(id == plotid){",
" var data = el.data;",
" $('#btn').on('click', function() {",
" var traceName = $('#selector').val();",
" $.each(data, function(index,value){",
" if(value.name == traceName){",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [index]);",
" }",
" });",
" });",
" }",
"}")
然后
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p %>% onRender(js, data = "plot")
})
如果您有多个按钮，每条轨迹一个：
js <- c(
"function(el, x, plotid){",
" var id = el.getAttribute('id');",
" if(id == plotid){",
" var data = el.data;",
" $('[id^=btn]').on('click', function() {",
" var index = parseInt(this.id.split('-')[1]);",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [index]);",
" });",
" }",
"}")
ui <- fluidPage(
plotlyOutput("plot"),
actionButton("btn-0", "drat"),
actionButton("btn-1", "wt")
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p %>% onRender(js, data = "plot")
})
}
shinyApp(ui, server)
这不适用于您的示例。那是因为按钮是通过 renderUI 创建的，并且在第一次渲染图时它们还不存在。
我能找到的唯一解决方案是以下一个。我没有将 onclick 事件监听器附加到 plotly 的回调中，而是将它们附加到按钮的 onclick 属性中：
js <- c(
"function toggleLegend(id){",
" var plot = document.getElementById('plot1');",
" var data = plot.data;",
" var index = parseInt(id.split('-')[1]) - 1;",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(plot, {visible: v}, [index]);",
"}")
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
fluidRow(
......
output$YNbuttons <- renderUI({
req(values$NrOfTraces)
lapply(1:values$NrOfTraces, function(el) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] == TRUE) {
div(actionButton(inputId = YNb, label = icon("check"),
style = "color: #339FFF; background-color: white; border-color: #339FFF;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px",
onclick = "toggleLegend(this.id);"))
} else {
div(actionButton(inputId = YNb, label = icon("times"),
style = "color: #ff4d4d; background-color: white; border-color: #ff4d4d;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px",
onclick = "toggleLegend(this.id);"))
}
})
})
并且没有使用 onRender。
但这只适用于一个地块。如果你想 link 按钮到多个图，假设按钮 id 的形式是 btn-plot2-5，那么做：
js <- c(
"function toggleLegend(id){",
" var ids = id.split('-');",
" var plotid = ids[1];",
" var index = parseInt(ids[2])-1;",
" var plot = document.getElementById(plotid);",
" var data = plot.data;",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(plot, {visible: v}, [index]);",
"}")
我正在寻找一种方法 link actionButton 单击 legend 状态 true/legendonly 不会引起重新plotly 对象的 -rendering 而是更改 widget。底部的当前演示应用程序确实实现了 link，但通过完全重绘情节来实现。
我的目标是 link 指示 keep/drop 集群的按钮在两个方向 中以这样的方式可视化图中的数据 已更新，未呈现。我当前的解决方案确实会导致完全渲染。
交互是按钮改变 legend/plot & 图例改变按钮。
我添加了一些图片来解释工作流程。
我已经在我更大的实际应用程序中为更大的情节构建了一个测试版本，用户有这个视图：
在这里，用户可以通过 in/out 按钮选择要删除哪些集群以进行进一步处理。
感谢上一个问题
第 1 点是这个工作流程：onRender
if(values$colors) { for(i in seq_along(p1$x$data)){
p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}
}
p1 %>% onRender(js, data = "tracesPlot1")
目前还有第三种交互，当用户单击按钮时，它会导致痕迹隐藏。这种方法就是这里的问题。它目前遵循下图中的橙色流程，但我希望通过避免重新渲染绘图的 javascript 解决方案来改变它：
演示应用程序
library(plotly)
library(shiny)
library(htmlwidgets)
js <- c(
"function(el, x, inputName){",
" var id = el.getAttribute('id');",
" var d3 = Plotly.d3;",
" el.on('plotly_restyle', function(evtData) {",
" var out = {};",
" d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
" var trace = d3.select(this)[0][0].__data__[0].trace;",
" out[trace.name] = trace.visible;",
" });",
" Shiny.setInputValue(inputName, out);",
" });",
"}")
YNElement <- function(idx){sprintf("YesNo_button-%d", idx)}
ui <- fluidPage(
fluidRow(
column(2,
h5("Keep/Drop choices linked to colorscheme 1"),
uiOutput('YNbuttons')
),
column(8,
plotlyOutput("plot1")
),
column(2,
h5('Switch grouping'),
actionButton(inputId = 'Switch', label = icon('refresh'), style = "color: #f7ad6e; background-color: white; border-color: #f7ad6e;
height: 40px; width: 40px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px")
), style = "margin-top:150px"
),
verbatimTextOutput("tracesPlot1"),
verbatimTextOutput("tracesPlot2")
)
server <- function(input, output, session) {
values <- reactiveValues(colors = T, NrOfTraces = length(unique(mtcars$cyl)))
output$plot1 <- renderPlotly({
print('plotting!')
if(values$colors) { colors <- c('red', 'blue', 'green') } else {colors <- c('black', 'orange', 'gray')}
p1 <- plot_ly()
p1 <- add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
p1 <- layout(p1, title = 'mtcars group by cyl with switching colors')
p1 <- plotly_build(p1)
if(values$colors) { for(i in seq_along(p1$x$data)){
p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}
}
p1 %>% onRender(js, data = "tracesPlot1")
})
observeEvent(input$Switch, { values$colors <- !values$colors })
##### THIS BLOCK links buttons -> plot, but causes it to render all over again
### this interaction is what I would like to replace by javascript
observeEvent(values$dYNbs_cyl_el, {
legenditems <- values$dYNbs_cyl_el
legenditems[which(legenditems == FALSE)] <- 'legendonly'
legenditems[which(legenditems == TRUE )] <- 'TRUE'
names(legenditems) <- sort(unique(mtcars$cyl))
values$legenditems <- as.list(legenditems)
})
observeEvent(values$NrOfTraces, {
values$dYNbs_cyl_el <- rep(T,values$NrOfTraces)
names(values$dYNbs_cyl_el) <- sapply(1:values$NrOfTraces, function(x) {YNElement(x)})
})
output$YNbuttons <- renderUI({
req(values$NrOfTraces)
lapply(1:values$NrOfTraces, function(el) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] == T ) {
div(actionButton(inputId = YNb, label = icon("check"), style = "color: #339FFF; background-color: white; border-color: #339FFF;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px"))
} else {
div(actionButton(inputId = YNb, label = icon("times"), style = "color: #ff4d4d; background-color: white; border-color: #ff4d4d;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px"))
}
})
})
flipYNb_FP1 <- function(idx){
YNb <- YNElement(idx)
values$dYNbs_cyl_el[[YNb]] <- !values$dYNbs_cyl_el[[YNb]]
}
observe({
lapply(1:values$NrOfTraces, function(ob) {
YNElement <- YNElement(ob)
observeEvent(input[[YNElement]], {
flipYNb_FP1(ob)
}, ignoreInit = T)
})
})
observeEvent(input$tracesPlot1, {
listTraces <- input$tracesPlot1
values$legenditems <- listTraces ## this line would save the legend status even if we remove the observer for the values$dYNbs_cyl_el list
listTracesTF <- gsub('legendonly', FALSE, listTraces)
listTracesTF <- as.logical(listTracesTF)
lapply(1:values$NrOfTraces, function(el) {
if(el <= length(listTracesTF)) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] != listTracesTF[el]) {
values$dYNbs_cyl_el[[YNb]] <- listTracesTF[el]
}
}
})
})
output$tracesPlot1 <- renderPrint({ unlist(input$tracesPlot1) })
output$tracesPlot2 <- renderPrint({ unlist(values$legenditems) })
}
shinyApp(ui, server)
已更新测试应用程序，尝试使用答案。仍然无法工作
library(plotly)
library(shiny)
library(htmlwidgets)
# js <- c(
# "function(el, x, inputName){",
# " var id = el.getAttribute('id');",
# " var d3 = Plotly.d3;",
# " el.on('plotly_restyle', function(evtData) {",
# " var out = {};",
# " d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
# " var trace = d3.select(this)[0][0].__data__[0].trace;",
# " out[trace.name] = trace.visible;",
# " });",
# " Shiny.setInputValue(inputName, out);",
# " });",
# "}")
js2 <- c(
"function(el, x, inputName){",
" var id = el.getAttribute('id');",
" if(id == inputName){",
" var data = el.data;",
" $('[id^=btn]').on('click', function() {",
" var index = parseInt(this.id.split('-')[1]);",
" var trace = index -1; ",
" var v0 = data[trace].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [trace]);",
" });",
" }",
"}")
YNElement <- function(idx){sprintf("btn-%d", idx)}
ui <- fluidPage(
fluidRow(
column(2,
h5("Keep/Drop choices linked to colorscheme 1"),
uiOutput('YNbuttons')
),
column(8,
plotlyOutput("plot1")
),
column(2,
h5('Switch grouping'),
actionButton(inputId = 'Switch', label = icon('refresh'), style = "color: #f7ad6e; background-color: white; border-color: #f7ad6e;
height: 40px; width: 40px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px")
), style = "margin-top:150px"
),
verbatimTextOutput("tracesPlot1"),
verbatimTextOutput("tracesPlot2")
)
server <- function(input, output, session) {
values <- reactiveValues(colors = T, NrOfTraces = length(unique(mtcars$cyl)))
output$plot1 <- renderPlotly({
print('plotting!')
values$legenditemNames <- sort(unique(mtcars$cyl))
if(values$colors) { colors <- c('red', 'blue', 'green') } else {colors <- c('black', 'orange', 'gray')}
p1 <- plot_ly()
p1 <- add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
p1 <- layout(p1, title = 'mtcars group by cyl with switching colors')
p1 <- plotly_build(p1)
if(values$colors) { for(i in seq_along(p1$x$data)){
p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}
}
p1 %>% onRender(js2, data = "tracesPlot1")
})
observeEvent(input$Switch, { values$colors <- !values$colors })
##### THIS BLOCK links buttons -> plot, but causes it to render all over again
# observeEvent(values$dYNbs_cyl_el, {
# legenditems <- values$dYNbs_cyl_el
# legenditems[which(legenditems == FALSE)] <- 'legendonly'
# legenditems[which(legenditems == TRUE )] <- 'TRUE'
# names(legenditems) <- values$legenditemNames
# values$legenditems <- as.list(legenditems)
# })
observeEvent(values$NrOfTraces, {
values$dYNbs_cyl_el <- rep(T,values$NrOfTraces)
names(values$dYNbs_cyl_el) <- sapply(1:values$NrOfTraces, function(x) {YNElement(x)})
})
output$YNbuttons <- renderUI({
req(values$NrOfTraces)
lapply(1:values$NrOfTraces, function(el) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] == T ) {
div(actionButton(inputId = YNb, label = icon("check"), style = "color: #339FFF; background-color: white; border-color: #339FFF;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px"))
} else {
div(actionButton(inputId = YNb, label = icon("times"), style = "color: #ff4d4d; background-color: white; border-color: #ff4d4d;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px"))
}
})
})
flipYNb_FP1 <- function(idx){
YNb <- YNElement(idx)
values$dYNbs_cyl_el[[YNb]] <- !values$dYNbs_cyl_el[[YNb]]
}
observe({
lapply(1:values$NrOfTraces, function(ob) {
YNElement <- YNElement(ob)
observeEvent(input[[YNElement]], {
flipYNb_FP1(ob)
}, ignoreInit = T)
})
})
observeEvent(input$tracesPlot1, {
listTraces <- input$tracesPlot1
values$legenditems <- listTraces
listTracesTF <- gsub('legendonly', FALSE, listTraces)
listTracesTF <- as.logical(listTracesTF)
lapply(1:values$NrOfTraces, function(el) {
if(el <= length(listTracesTF)) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] != listTracesTF[el]) {
values$dYNbs_cyl_el[[YNb]] <- listTracesTF[el]
}
}
})
})
output$tracesPlot1 <- renderPrint({ unlist(input$tracesPlot1) })
output$tracesPlot2 <- renderPrint({ unlist(values$legenditems) })
}
shinyApp(ui, server)
你能试试这个吗:
library(plotly)
library(shiny)
library(htmlwidgets)
js <- c(
"function(el, x){",
" var data = el.data;",
" $('#btn').on('click', function() {",
" var traceName = $('#selector').val();",
" $.each(data, function(index,value){",
" if(value.name == traceName){",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [index]);",
" }",
" });",
" });",
"}")
ui <- fluidPage(
plotlyOutput("plot"),
selectInput("selector", "", choices = c("drat", "wt", "qsec")),
actionButton("btn", "Show/hide")
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p %>% onRender(js)
})
}
shinyApp(ui, server)
如果你有多个地块：
js <- c(
"function(el, x, plotid){",
" var id = el.getAttribute('id');",
" if(id == plotid){",
" var data = el.data;",
" $('#btn').on('click', function() {",
" var traceName = $('#selector').val();",
" $.each(data, function(index,value){",
" if(value.name == traceName){",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [index]);",
" }",
" });",
" });",
" }",
"}")
然后
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p %>% onRender(js, data = "plot")
})
如果您有多个按钮，每条轨迹一个：
js <- c(
"function(el, x, plotid){",
" var id = el.getAttribute('id');",
" if(id == plotid){",
" var data = el.data;",
" $('[id^=btn]').on('click', function() {",
" var index = parseInt(this.id.split('-')[1]);",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [index]);",
" });",
" }",
"}")
ui <- fluidPage(
plotlyOutput("plot"),
actionButton("btn-0", "drat"),
actionButton("btn-1", "wt")
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p %>% onRender(js, data = "plot")
})
}
shinyApp(ui, server)
这不适用于您的示例。那是因为按钮是通过 renderUI 创建的，并且在第一次渲染图时它们还不存在。
我能找到的唯一解决方案是以下一个。我没有将 onclick 事件监听器附加到 plotly 的回调中，而是将它们附加到按钮的 onclick 属性中：
js <- c(
"function toggleLegend(id){",
" var plot = document.getElementById('plot1');",
" var data = plot.data;",
" var index = parseInt(id.split('-')[1]) - 1;",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(plot, {visible: v}, [index]);",
"}")
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
fluidRow(
......
output$YNbuttons <- renderUI({
req(values$NrOfTraces)
lapply(1:values$NrOfTraces, function(el) {
YNb <- YNElement(el)
if(values$dYNbs_cyl_el[[YNb]] == TRUE) {
div(actionButton(inputId = YNb, label = icon("check"),
style = "color: #339FFF; background-color: white; border-color: #339FFF;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px",
onclick = "toggleLegend(this.id);"))
} else {
div(actionButton(inputId = YNb, label = icon("times"),
style = "color: #ff4d4d; background-color: white; border-color: #ff4d4d;height: 34px; width: 34px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px",
onclick = "toggleLegend(this.id);"))
}
})
})
并且没有使用 onRender。
但这只适用于一个地块。如果你想 link 按钮到多个图，假设按钮 id 的形式是 btn-plot2-5，那么做：
js <- c(
"function toggleLegend(id){",
" var ids = id.split('-');",
" var plotid = ids[1];",
" var index = parseInt(ids[2])-1;",
" var plot = document.getElementById(plotid);",
" var data = plot.data;",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(plot, {visible: v}, [index]);",
"}")