如何渲染隐藏预设轨迹的绘图，即基于列表的 'legendonly'
How to render a plotly plot with preset traces hidden i.e. 'legendonly' based on list
感谢对上一个问题的帮助 我现在可以通过读出图例列表在 list 中记录哪些 traces 隐藏在 plotly 图中TRUE/legendonly 和一块 javascript，我用它来更改列表条目和相关按钮的颜色。
我现在也想做的是在重新渲染情节时保持 TRUE/legendonly 状态。在下面的虚拟应用程序中，可以使用开关 actionbutton 重新呈现 plot，这会由于颜色的变化而导致重新 render。
换句话说：如何根据 values$tracesPlot1 用户最后一次查看此特定内容时 altered/recorded 来渲染具有“传奇状态”的某些痕迹剧情.
我怀疑这会涉及一些document.getElementById("")方法来获取值$tracesPlot1，然后执行与已经存在的脚本相反的操作，从该图中获取图例状态，并将其发送到情节，使用相同的onRender(js, data = "tracesPlot1")
HERE: 你可以看到当用户回到第一个配色方案时，一些按钮仍然是关闭的，但是 plot of当然所有痕迹再次可见，而不是反映按钮状态。
p.s.:my app 用户可以在按 3 列中的 1 列分组之间切换绘图，导致重新渲染，我想用相同的图例加载它呈现时取消选择元素
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")
)
server <- function(input, output, session) {
values <- reactiveValues(colors = T, NrOfTraces = length(unique(mtcars$cyl)))
output$plot1 <- renderPlotly({
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 %>% onRender(js, data = "tracesPlot1")
})
observeEvent(input$Switch, { values$colors <- !values$colors })
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"))
}
})
})
observeEvent(input$tracesPlot1, {
listTraces <- input$tracesPlot1
#values$tracesPlot1 <- input$tracesPlot1
listTracesTF <- gsub('legendonly', FALSE, listTraces)
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) })
}
shinyApp(ui, server)
你可以这样设置轨迹的visible 属性:
library(plotly)
legendItems <- list("4" = TRUE, "6" = "legendonly", "8" = TRUE)
p <- plot_ly() %>%
add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl))
p <- plotly_build(p)
for(i in seq_along(p$x$data)){
p$x$data[[i]]$visible <- legendItems[[p$x$data[[i]]$name]]
}
p
@Stephane，
我想出了如何让它工作。
重要的是，您的答案中的代码放在 p1 %>% onRender(js, data = "tracesPlot1") 上方，否则我们会松开 javascript。
在下面的示例中，我添加了一些内容，现在单击三个按钮也可以激活隐藏...遗憾的是，这确实意味着绘图将必须完全重新渲染，这在我的 3D 散点图中具有 5000 个数据点和 1 -50 条轨迹需要几秒钟。
避免这种情况的唯一方法是，如果我们可以通过 javascript 对 p1$x$data[[i]]$visible 进行操作，这会改变小部件，并且不会触发闪亮的服务器触发......有什么想法吗？我可能会为此从当前解决方案到更快的 javascript 方法
的转换打开一个新项目
在下面的应用程序中：
单击图例会更改 input$tracePlot1，我将其操作为 T/F 列表而不是 "TRUE"/"legendonly"，并在需要时用它更新 values$dYNbs_cyl_el
单击按钮本身也会更改 values$dYNbs_cyl_el 项
an observeEvent 查看 values$dYNbs_cyl_el 克隆此列表，再次将 T/F 更改为 "TRUE"/"legenonly" 以便它与图例状态输入相匹配，并用 sort(unique(mtcars$cyl)) 命名列表，然后将此对象转换为 values$legenditems
如果该图显示 'color version 1'，即我的应用程序的替代项，我在其中更改了我将数据分组到跟踪中的列，那么该图使用 values$legenditems 来更改的状态传奇物品。
这以两种方式提供了一个很好的 3 元素链接交互。
图例改变情节和按钮
按钮改变情节和图例
以及情节“记得”谁出现了，谁没有出现。
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({
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 })
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
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)
感谢对上一个问题的帮助 list 中记录哪些 traces 隐藏在 plotly 图中TRUE/legendonly 和一块 javascript，我用它来更改列表条目和相关按钮的颜色。
我现在也想做的是在重新渲染情节时保持 TRUE/legendonly 状态。在下面的虚拟应用程序中，可以使用开关 actionbutton 重新呈现 plot，这会由于颜色的变化而导致重新 render。
换句话说：如何根据 values$tracesPlot1 用户最后一次查看此特定内容时 altered/recorded 来渲染具有“传奇状态”的某些痕迹剧情.
我怀疑这会涉及一些document.getElementById("")方法来获取值$tracesPlot1，然后执行与已经存在的脚本相反的操作，从该图中获取图例状态，并将其发送到情节，使用相同的onRender(js, data = "tracesPlot1")
HERE:
p.s.:my app 用户可以在按 3 列中的 1 列分组之间切换绘图，导致重新渲染，我想用相同的图例加载它呈现时取消选择元素
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")
)
server <- function(input, output, session) {
values <- reactiveValues(colors = T, NrOfTraces = length(unique(mtcars$cyl)))
output$plot1 <- renderPlotly({
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 %>% onRender(js, data = "tracesPlot1")
})
observeEvent(input$Switch, { values$colors <- !values$colors })
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"))
}
})
})
observeEvent(input$tracesPlot1, {
listTraces <- input$tracesPlot1
#values$tracesPlot1 <- input$tracesPlot1
listTracesTF <- gsub('legendonly', FALSE, listTraces)
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) })
}
shinyApp(ui, server)
你可以这样设置轨迹的visible 属性:
library(plotly)
legendItems <- list("4" = TRUE, "6" = "legendonly", "8" = TRUE)
p <- plot_ly() %>%
add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl))
p <- plotly_build(p)
for(i in seq_along(p$x$data)){
p$x$data[[i]]$visible <- legendItems[[p$x$data[[i]]$name]]
}
p
@Stephane，
我想出了如何让它工作。
重要的是，您的答案中的代码放在 p1 %>% onRender(js, data = "tracesPlot1") 上方，否则我们会松开 javascript。
在下面的示例中，我添加了一些内容，现在单击三个按钮也可以激活隐藏...遗憾的是，这确实意味着绘图将必须完全重新渲染，这在我的 3D 散点图中具有 5000 个数据点和 1 -50 条轨迹需要几秒钟。
避免这种情况的唯一方法是，如果我们可以通过 javascript 对 p1$x$data[[i]]$visible 进行操作，这会改变小部件，并且不会触发闪亮的服务器触发......有什么想法吗？我可能会为此从当前解决方案到更快的 javascript 方法
在下面的应用程序中：
单击图例会更改 input$tracePlot1，我将其操作为 T/F 列表而不是 "TRUE"/"legendonly"，并在需要时用它更新 values$dYNbs_cyl_el
单击按钮本身也会更改 values$dYNbs_cyl_el 项
an observeEvent 查看 values$dYNbs_cyl_el 克隆此列表，再次将 T/F 更改为 "TRUE"/"legenonly" 以便它与图例状态输入相匹配，并用 sort(unique(mtcars$cyl)) 命名列表，然后将此对象转换为 values$legenditems
如果该图显示 'color version 1'，即我的应用程序的替代项，我在其中更改了我将数据分组到跟踪中的列，那么该图使用 values$legenditems 来更改的状态传奇物品。
这以两种方式提供了一个很好的 3 元素链接交互。 图例改变情节和按钮 按钮改变情节和图例 以及情节“记得”谁出现了，谁没有出现。
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({
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 })
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
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)