处理后从 plotly select 中清除 event_data
Clear event_data from plotly select after processing it
在下面的虚拟应用程序中，用户可以通过拖动 1 个或多个点周围的区域来 select / deselect 个点。
这导致这些点的状态从 data.table 中的 T <-> F 翻转。
我现在想解决的是event_data处理后如何清空，
或者至少确保用户可以 select 同一组点连续两次。
即：现在，select将底部的三个点变成十字，
select使用相同的三个点并打算将它们转回圆圈目前不起作用，因为 event_data 与之前的 selection 相同。
我以为我成功了，但事实证明我没有。
Plotly 允许通过双击清除事件数据，但我想通过代码中的自动功能实现同样的效果，以便在事件数据出现时立即清除处理。
我也尝试过使用此解决方案来处理点击事件，但我无法将其用于我的 select 事件
useShinyjs(),
extendShinyjs(text = "shinyjs.resetSelect = function() { Shiny.onInputChange('.clientValue-plotly_click-A', 'null'); }"),
在 UI 和 js$resetSelect() 在服务器块中
GIF 显示了在拖动 select 操作之间双击和不双击行为之间的差异。
library(shiny)
library(plotly)
library(dplyr)
library(data.table)
testDF <- data.table( MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
testDF$Selected <- T
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues(RFImp_FP1 = testDF)
observe({
if(!is.null( values$RFImp_FP1)) {
values$Selected <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
}
})
observeEvent(values$Selected, {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
if(!is.null(event_data("plotly_selected", source = 'RFAcc_FP1'))){
data_df <- values$RFImp_FP1
data_df <- data_df %>% .[, Selected := if_else(Variables %in% parsToChange, !Selected, Selected)]
values$RFImp_FP1 <- NULL
values$RFImp_FP1 <- data_df
}
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * 80
colors <- if(length(unique(RFImp_score$Selected)) > 1) { c('#F0F0F0', '#1b73c1') } else { '#1b73c1' }
symbols <- if(length(unique(RFImp_score$Selected)) > 1) { c('x', 'circle') } else { 'circle' }
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = factor(RFImp_score$Selected),
colors = colors,
symbol = factor(RFImp_score$Selected),
symbols = symbols,
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)
请检查以下内容：
library(shiny)
library(plotly)
library(data.table)
testDF <- data.table(MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10], Selected = TRUE)
setorder(testDF, MeanDecreaseAccuracy)
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
RFImp_score <- reactive({
eventData <- event_data("plotly_selected", source = 'RFAcc_FP1_source', session)
parsToChange <- eventData$y
testDF[Variables %in% parsToChange, Selected := !Selected]
testDF
})
output$RFAcc_FP1 <- renderPlotly({
req(RFImp_score())
plotheight <- length(RFImp_score()$Variables) * 80
colors <- if (length(unique(RFImp_score()$Selected)) > 1) {
c('#F0F0F0', '#1b73c1')
} else {
if (unique(RFImp_score()$Selected)) {
'#1b73c1'
} else {
'#F0F0F0'
}
}
symbols <-
if (length(unique(RFImp_score()$Selected)) > 1) {
c('x', 'circle')
} else {
if (unique(RFImp_score()$Selected)) {
'circle'
} else {
'x'
}
}
p <- plot_ly(data = RFImp_score(),
source = 'RFAcc_FP1_source',
height = plotheight,
width = 450) %>%
add_trace(x = ~MeanDecreaseAccuracy,
y = ~Variables,
type = 'scatter',
mode = 'markers',
color = ~factor(Selected),
colors = colors,
symbol = ~factor(Selected),
symbols = symbols,
marker = list(size = 6),
hoverinfo = "text",
text = ~paste('<br>', 'Parameter: ', ~Variables,
'<br>', 'Mean decrease accuracy: ', format(round(MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = ~Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)
结果：
通常反应式方法可能更好，但由于我的
我选择坚持观察
lapply(plotlist, function(THEPLOT) {
values[[paste('RFImp', THEPLOT, sep = '')]] #..... etc
#......
})
最后我设法通过反转跟踪顺序解决了问题以实现所需的行为。
通过使 selected == T curveNumber 0 和 selected == F curveNumber 1，每次进行相同的选择并反转时，event_data 在
之间切换
curveNumber pointNumber x y
1 0 0 0.3389429 g
2 0 1 0.3872325 j
和
curveNumber pointNumber x y
1 1 0 0.3389429 g
2 1 1 0.3872325 j
这是通过颜色和符号语句前面的!来实现的：
mode = 'markers',
color = ~factor(!Selected),
colors = colors,
symbol = ~factor(!Selected),
if(!is.null( values$RFImp_FP1)) { ...} 语句导致 observe({...}) 触发两次，但这没有进一步的影响，因为 values$Selected 仅在第一次发生变化。如果没有此声明，如果绘图不在您打开的第一页上（即在另一个选项卡或下拉按钮上），新的 Plotly 版本会导致应用程序抛出以下错误
Warning: The 'plotly_selected' event tied a source ID of 'RFAcc_FP1'
is not registered. In order to obtain this event data, please add
event_register(p, 'plotly_selected') to the plot (p) that you wish
to obtain event data from.
正在运行的应用程序：
library(shiny)
library(plotly)
library(dplyr)
library(data.table)
testDF <- data.table( MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
testDF$Selected <- T
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues(RFImp_FP1 = testDF)
observe({
values$Selected <- event_data("plotly_selected", source = 'RFAcc_FP1')
})
observeEvent(values$Selected, {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
if(!is.null(event_data("plotly_selected", source = 'RFAcc_FP1'))){
data_df <- values$RFImp_FP1
data_df[Variables %in% parsToChange, Selected := !Selected]
values$RFImp_FP1 <- NULL
values$RFImp_FP1 <- data_df
}
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * 80
colors <- if(length(unique(RFImp_score$Selected)) > 1) { c( '#1b73c1', '#F0F0F0') } else { '#1b73c1' }
symbols <- if(length(unique(RFImp_score$Selected)) > 1) { c( 'circle', 'x') } else { 'circle' }
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = ~factor(!Selected),
colors = colors,
symbol = ~factor(!Selected),
symbols = symbols,
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)
在下面的虚拟应用程序中，用户可以通过拖动 1 个或多个点周围的区域来 select / deselect 个点。 这导致这些点的状态从 data.table 中的 T <-> F 翻转。
我现在想解决的是event_data处理后如何清空，
或者至少确保用户可以 select 同一组点连续两次。
即：现在，select将底部的三个点变成十字， select使用相同的三个点并打算将它们转回圆圈目前不起作用，因为 event_data 与之前的 selection 相同。
我以为我成功了，但事实证明我没有。
Plotly 允许通过双击清除事件数据，但我想通过代码中的自动功能实现同样的效果，以便在事件数据出现时立即清除处理。
我也尝试过使用此解决方案来处理点击事件，但我无法将其用于我的 select 事件
useShinyjs(),
extendShinyjs(text = "shinyjs.resetSelect = function() { Shiny.onInputChange('.clientValue-plotly_click-A', 'null'); }"),
在 UI 和 js$resetSelect() 在服务器块中
library(shiny)
library(plotly)
library(dplyr)
library(data.table)
testDF <- data.table( MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
testDF$Selected <- T
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues(RFImp_FP1 = testDF)
observe({
if(!is.null( values$RFImp_FP1)) {
values$Selected <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
}
})
observeEvent(values$Selected, {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
if(!is.null(event_data("plotly_selected", source = 'RFAcc_FP1'))){
data_df <- values$RFImp_FP1
data_df <- data_df %>% .[, Selected := if_else(Variables %in% parsToChange, !Selected, Selected)]
values$RFImp_FP1 <- NULL
values$RFImp_FP1 <- data_df
}
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * 80
colors <- if(length(unique(RFImp_score$Selected)) > 1) { c('#F0F0F0', '#1b73c1') } else { '#1b73c1' }
symbols <- if(length(unique(RFImp_score$Selected)) > 1) { c('x', 'circle') } else { 'circle' }
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = factor(RFImp_score$Selected),
colors = colors,
symbol = factor(RFImp_score$Selected),
symbols = symbols,
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)
请检查以下内容：
library(shiny)
library(plotly)
library(data.table)
testDF <- data.table(MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10], Selected = TRUE)
setorder(testDF, MeanDecreaseAccuracy)
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
RFImp_score <- reactive({
eventData <- event_data("plotly_selected", source = 'RFAcc_FP1_source', session)
parsToChange <- eventData$y
testDF[Variables %in% parsToChange, Selected := !Selected]
testDF
})
output$RFAcc_FP1 <- renderPlotly({
req(RFImp_score())
plotheight <- length(RFImp_score()$Variables) * 80
colors <- if (length(unique(RFImp_score()$Selected)) > 1) {
c('#F0F0F0', '#1b73c1')
} else {
if (unique(RFImp_score()$Selected)) {
'#1b73c1'
} else {
'#F0F0F0'
}
}
symbols <-
if (length(unique(RFImp_score()$Selected)) > 1) {
c('x', 'circle')
} else {
if (unique(RFImp_score()$Selected)) {
'circle'
} else {
'x'
}
}
p <- plot_ly(data = RFImp_score(),
source = 'RFAcc_FP1_source',
height = plotheight,
width = 450) %>%
add_trace(x = ~MeanDecreaseAccuracy,
y = ~Variables,
type = 'scatter',
mode = 'markers',
color = ~factor(Selected),
colors = colors,
symbol = ~factor(Selected),
symbols = symbols,
marker = list(size = 6),
hoverinfo = "text",
text = ~paste('<br>', 'Parameter: ', ~Variables,
'<br>', 'Mean decrease accuracy: ', format(round(MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = ~Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)
结果：
通常反应式方法可能更好，但由于我的
我选择坚持观察 lapply(plotlist, function(THEPLOT) {
values[[paste('RFImp', THEPLOT, sep = '')]] #..... etc
#......
})
最后我设法通过反转跟踪顺序解决了问题以实现所需的行为。
通过使 selected == T curveNumber 0 和 selected == F curveNumber 1，每次进行相同的选择并反转时，event_data 在
curveNumber pointNumber x y
1 0 0 0.3389429 g
2 0 1 0.3872325 j
和
curveNumber pointNumber x y
1 1 0 0.3389429 g
2 1 1 0.3872325 j
这是通过颜色和符号语句前面的!来实现的：
mode = 'markers',
color = ~factor(!Selected),
colors = colors,
symbol = ~factor(!Selected),
if(!is.null( values$RFImp_FP1)) { ...} 语句导致 observe({...}) 触发两次，但这没有进一步的影响，因为 values$Selected 仅在第一次发生变化。如果没有此声明，如果绘图不在您打开的第一页上（即在另一个选项卡或下拉按钮上），新的 Plotly 版本会导致应用程序抛出以下错误
Warning: The 'plotly_selected' event tied a source ID of 'RFAcc_FP1' is not registered. In order to obtain this event data, please add
event_register(p, 'plotly_selected')to the plot (p) that you wish to obtain event data from.
正在运行的应用程序：
library(shiny)
library(plotly)
library(dplyr)
library(data.table)
testDF <- data.table( MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
testDF$Selected <- T
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues(RFImp_FP1 = testDF)
observe({
values$Selected <- event_data("plotly_selected", source = 'RFAcc_FP1')
})
observeEvent(values$Selected, {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
if(!is.null(event_data("plotly_selected", source = 'RFAcc_FP1'))){
data_df <- values$RFImp_FP1
data_df[Variables %in% parsToChange, Selected := !Selected]
values$RFImp_FP1 <- NULL
values$RFImp_FP1 <- data_df
}
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * 80
colors <- if(length(unique(RFImp_score$Selected)) > 1) { c( '#1b73c1', '#F0F0F0') } else { '#1b73c1' }
symbols <- if(length(unique(RFImp_score$Selected)) > 1) { c( 'circle', 'x') } else { 'circle' }
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = ~factor(!Selected),
colors = colors,
symbol = ~factor(!Selected),
symbols = symbols,
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)