问题描述
由于对此问题的答案,我已经开发了plotly
plot
,其中buttons
链接到其legend
,在其中单击legend
会更改每个包含T/F
状态的reactive variable
的状态,从而重新呈现链接到每个actionbuttons
的actionbuttons
trace
(数据组).另一个javascript
在相反的方向上执行相同的操作,单击button
隐藏/显示plot
中的trace
+ legend
项.
Thanks to answers on this previous question, I have developed a plotly
plot
with buttons
linked to its legend
, where clicking the legend
changes the state of a reactive variable
containing T/F
state for each of them, and thus re-renders the actionbuttons
linked to each trace
(data group). The other javascript
does the same in opposite direction, clicking a button
hides/shows that trace
+ legend
item in the plot
.
现在我希望通过一个新按钮+ selectinput添加另一个交互
简短的问题:
如何使单击一般按钮(#0),
在TRUE/'legendonly'
之间更改图例状态开关对于情节j(#1)的迹线n,
其中n = input$SelectTrace
(#2)
通过在该actionButton
The question in short:
How to make clicking a GENERIC button (#0),
change the legend status switch between TRUE/'legendonly'
for trace n of plotly plot j (#1),
where n = input$SelectTrace
(#2)
by using javascript
+ onclick
argument on that actionButton
0 actionButton
在这里称为'SwitchExt'
1因为我有多个
,所以它需要定位到特定的plotly plot
2 a selectInput
将走线作为选择
0 actionButton
called 'SwitchExt' here
1 It needs to target a specific plotly plot
since I have multiple
2 a selectInput
with the traces as choices
详细说明:
现在我有以下小问题:在我的应用程序的另一个条件面板中,向用户显示了一组具有相同数据的不同图块: -用户可以选择要突出显示的迹线,其旁边的按钮将根据T/F状态列表显示第一个绘图中的该迹线是否打开/关闭,然后该按钮将显示蓝色/红色,并且链接到选定的跟踪.
Now I have the following little problem: In my app, in another conditional panel, the user is shown a different set of plots with the same data: - the user can choose which trace to highlight, a button next to it will show whether this trace in the first plot is on/off based on the list of T/F statusses, and then this button will show blue/red, and is linked to the trace selected.
场景:用户选择了第n组,点击新的actionButton 'SwitchExt'
这会触发flipYNb_FP1(n)
,actionButton YNbuttons... YNb <- YNElement(n) ....
Scenario: The user selected group n, clicks the new actionButton 'SwitchExt'
this triggers flipYNb_FP1(n)
, actionButton YNbuttons... YNb <- YNElement(n) ....
if(values$dYNbs_cyl_el[[YNb]] == TRUE) {
将导致按钮n更改状态.
will cause button n to change state.
我可以使它也更改values$legenditems[n]
,但是在我的绘图代码中,values$legenditems
包裹在isolate({ })
中,以防止链接到legend
的javascript
更改绘图时重新渲染.
I can make it also change values$legenditems[n]
, but in my plot code, values$legenditems
is wrapped in isolate({ })
to stop the plot from re-rendering whenever the javascript
linked to the legend
changes it.
解决方案的概念:基本上,我认为我需要的不是直接更改values$legenditems
列表,而是要有另一个javascript
,它通过'onclick'
链接到actionButton
'switchExt'
,并以input$SelectTrace
作为输入,并且然后将legendstatus
更改为类似于javascript js1
的方式,但是随后使用document.getElementById
获取input$SelectTrace
的值,将其转换为numeric
,并更新legendstatus
.
Concept of the solution: Basically what I think I need, is rather than changing the values$legenditems
list directly, is to have another piece of javascript
that is linked to actionButton
'switchExt'
by 'onclick'
and takes input$SelectTrace
as input, and then changes the legendstatus
similar to how javascript js1
does it, but then using document.getElementById
to grab the value of input$SelectTrace
, turn it into numeric
, and update the legendstatus
.
应用程序:
library(plotly)
library(shiny)
library(htmlwidgets)
## js to link buttons to legend
js1 <- c(
"function toggleLegend(id){",
" var ids = id.split('-');",
" var plotid = ids[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]);",
"}")
## js code to link legend to buttons
js2 <- 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-plot1-%d", idx)}
ui <- fluidPage(
tags$head(
tags$script(HTML(js1))
),
fluidRow(
column(2,
h5("Keep/Drop choices linked to colorscheme 1"),
uiOutput('YNbuttons')
),
column(8,
plotlyOutput("plot1")
),
column(2,
h5('Switch plot ID and shows the plot remembers the show/hide'),
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"),
br(),
h5('New Button that does not work on legend.', style = 'font-weight:bold'),
uiOutput('newswitch'),
br(),
selectInput(inputId = 'SelectTrace', label = 'Select Trace', choices = 1:3, selected = 1)
), style = "margin-top:150px"
)
)
server <- function(input, output, session) {
values <- reactiveValues(Linked_FP1 = T, NrOfTraces = length(unique(mtcars$cyl)))
observeEvent(input$SwitchExt, {
## trying to make the user be able to switch the buttons linked to the legend on/off through another button that is in another page.
flipYNb_FP1(as.numeric(input$SelectTrace))
req(values$legenditems) ## don't run if legend items does not exist yet.
if(values$dYNbs_cyl_el[as.numeric(input$SelectTrace)]) { values$legenditems[[as.numeric(input$SelectTrace)]] <- T } else { values$legenditems[[as.numeric(input$SelectTrace)]] <- 'legendonly' } ## problem line is here...... since I need to isolate values$legenditems in the plot code
## this does not actually cause the legend to change. If I don't isolate, the plot would re-render due to the change in values$legenditems, which is not what we want
})
output$plot1 <- renderPlotly({
if(values$Linked_FP1) {colors <- c('red', 'blue', 'black') } 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)
isolate({ if(values$Linked_FP1) { for(i in seq_along(p1$x$data)){ ## causes the plot to render with previous hide/show selection
p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}
} }) ##This block is isolated because otherwise the plot will re-render when the user clicks 1 of the three buttons
p1 %>% onRender(js2, data = "tracesPlot1") ## add the javacode to extract the legend status
})
observeEvent(input$Switch, { values$Linked_FP1 <- !values$Linked_FP1 }) ## disable the link in my real app, in this dummy app it switches to plot with different id and colors that is not interactive
observeEvent(values$NrOfTraces, {
values$dYNbs_cyl_el <- rep(T,values$NrOfTraces) ## the list of Yes/No status of groups, from which the 3 buttons on the left are build blue or red
names(values$dYNbs_cyl_el) <- sapply(1:values$NrOfTraces, function(x) {YNElement(x)}) ## add names to that list
values$legenditems <- rep(T, values$NrOfTraces) ## make the legenditem list so that the app doesn't crash when user clicks switchExt without first clicking on legend items
names(values$legenditems) <- sort(unique(mtcars$cyl)) ## add names to that list
})
output$newswitch <- renderUI({
req(input$SelectTrace)
print(input$SelectTrace)
if(values$dYNbs_cyl_el[as.numeric(input$SelectTrace)]) {
actionButton(inputId = 'SwitchExt', label = icon('refresh'), style = "color: #339fff; background-color: white; border-color: #339fff;
height: 40px; width: 40px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px",
onclick = "toggleLegend(this.id);"
)}
else { actionButton(inputId = 'SwitchExt', 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",
onclick = "toggleLegend(this.id);"
)}
})
observeEvent(input$tracesPlot1, {
if(values$Linked_FP1) {
listTraces <- input$tracesPlot1
values$legenditems <- listTraces ## store the list of show/hide for when the plot re-renders here
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$YNbuttons <- renderUI({
req(values$NrOfTraces)
lapply(1:values$NrOfTraces, function(el) {
YNb <- YNElement(el)
if(values$Linked_FP1) {
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);"))
}
}
})
})
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]], {
if(!values$Linked_FP1) { flipYNb_FP1(ob) }
}, ignoreInit = T)
})
})
}
shinyApp(ui, server)
解决方案:经过一些意想不到的行为的挣扎之后,我发现我需要删除switchExt-plot1的观察者,以防止按钮两次翻转.
solution:After some struggle with some unintended behavior I figured out that I needed to remove the observer for switchExt-plot1 to stop buttons from flipping twice.
observeEvent(input[['SwitchExt-plot1']], {
flipYNb_FP1(as.numeric(input$SelectTrace))
})
可运行的应用程序是这样的:
library(plotly)
library(shiny)
library(htmlwidgets)
## js to link buttons to legend
js1 <- c(
"function toggleLegend(id){",
" var ids = id.split('-');",
" var plotid = ids[1];",
" var index = parseInt(ids[2])-1;", ## correct as the YN buttons are named YesNo-plot1-%d
" 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]);",
"}",
"function toggleLegend2(id){",
" var index = parseInt($('#SelectTrace').val())-1;",
" var ids = id.split('-');",
" var plotid = ids[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]);",
"}")
## js code to link legend to buttons
js2 <- 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-plot1-%d", idx)}
ui <- fluidPage(
tags$head(
tags$script(HTML(js1))
),
fluidRow(
column(2,
h5("Keep/Drop choices linked to colorscheme 1"),
uiOutput('YNbuttons')
),
column(8,
plotlyOutput("plot1")
),
column(2,
h5('New Button that does not work on legend.', style = 'font-weight:bold'),
uiOutput('newswitch'),
br(),
selectInput(inputId = 'SelectTrace', label = 'Select Trace', choices = 1:3, selected = 1)
), style = "margin-top:150px"
)
)
server <- function(input, output, session) {
values <- reactiveValues(Linked_FP1 = T, NrOfTraces = length(unique(mtcars$cyl)))
output$plot1 <- renderPlotly({
if(values$Linked_FP1) {colors <- c('red', 'blue', 'black') } 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)
isolate({ if(values$Linked_FP1) { for(i in seq_along(p1$x$data)){ ## causes the plot to render with previous hide/show selection
p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}
} }) ##This block is isolated because otherwise the plot will re-render when the user clicks 1 of the three buttons
p1 %>% onRender(js2, data = "tracesPlot1") ## add the javacode to extract the legend status
})
observeEvent(values$NrOfTraces, {
values$dYNbs_cyl_el <- rep(T,values$NrOfTraces) ## the list of Yes/No status of groups, from which the 3 buttons on the left are build blue or red
names(values$dYNbs_cyl_el) <- sapply(1:values$NrOfTraces, function(x) {YNElement(x)}) ## add names to that list
values$legenditems <- rep(T, values$NrOfTraces) ## make the legenditem list so that the app doesn't crash when user clicks switchExt without first clicking on legend items
names(values$legenditems) <- sort(unique(mtcars$cyl)) ## add names to that list
})
output$newswitch <- renderUI({
req(input$SelectTrace)
if(values$dYNbs_cyl_el[as.numeric(input$SelectTrace)]) {
actionButton(inputId = 'SwitchExt-plot1', label = icon('refresh'), style = "color: #339fff; background-color: white; border-color: #339fff;
height: 40px; width: 40px; border-radius: 6px; border-width: 2px; text-align: center; line-height: 50%; padding: 0px; display:block; margin: 2px",
onclick = "toggleLegend2(this.id)")
}
else { actionButton(inputId = 'SwitchExt-plot1', 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",
onclick = "toggleLegend2(this.id)")}
})
observeEvent(input$tracesPlot1, {
if(values$Linked_FP1) {
listTraces <- input$tracesPlot1
values$legenditems <- listTraces ## store the list of show/hide for when the plot re-renders here
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$YNbuttons <- renderUI({
req(values$NrOfTraces)
lapply(1:values$NrOfTraces, function(el) {
YNb <- YNElement(el)
if(values$Linked_FP1) {
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);"))
}
}
})
})
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]], {
if(!values$Linked_FP1) { flipYNb_FP1(ob) }
}, ignoreInit = T)
})
})
}
shinyApp(ui, server)
图片以支持评论:
推荐答案
我不确定我是否理解,但让我们从一些内容入手.
I'm not sure I understand, but let's start with something.
js1 <- 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]);",
"}",
"function toggleLegend2(){",
" var index = parseInt($('#SelectTrace').val())-1;",
" var plot = document.getElementById('plot1');",
" var data = plot.data;",
" var v0 = data[index].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(plot, {visible: v}, [index]);",
"}")
actionButton(inputId = 'SwitchExt', ......, onclick = "toggleLegend2()")
是您想要的吗?
这篇关于如何通过R Shiny中的JavaScript通过通用按钮+ selectInput更改轨迹n的图例状态的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!