为什么即使数据已更改，情节也不会更新
Why won't the plot update even though the data has changed
在下面的演示应用程序中，用户可以通过单击图中的 input$Go1 或 select 区域来更改数据行的 Selected 状态。
选择图中的区域是我想要的功能。
但是，由于我无法理解的原因，按钮确实会导致重新渲染图，而 select 不会，即使这两种方法具有相同的效果，即值的变化在 data.table 的 Selected 列中 RFImp_FP1
为什么当我在剧情中 select 点时它不起作用？
ui <- fluidPage(
actionButton(inputId = 'Go', label = 'Go'),
actionButton(inputId = 'Go2', label = 'Go2'),
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues()
observeEvent(input$Go, {
values$RFImp_FP1 <- data.table(MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
values$RFImp_FP1$Selected <- 1
})
observeEvent(input$Go2,{
values$RFImp_FP1$Selected[1:4] <- 1-values$RFImp_FP1$Selected[1:4]
print(values$RFImp_FP1$Selected)
})
observe({
if(!is.null(values$RFImp_FP1)) {
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, 1-Selected, Selected)]
values$RFImp_FP1$Selected <- data_df$Selected
print(values$RFImp_FP1)
}
}
})
observeEvent(values$RFImp_FP1, {
print('seeing change')
})
output$RFAcc_FP1 <- renderPlotly({
values$RFImp_FP1
if(!is.null(values$RFImp_FP1)) {
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * input$testme
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 = c('#1b73c1', '#797979'),
symbol = factor(RFImp_score$Selected),
symbols = c('circle','x'),
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$elementId <- NULL ## to surpress warning of widgetid
p <- p %>% config(displayModeBar = F)
p
} else {
p <- plot_ly( type = 'scatter', mode = 'markers', height = '400px', width = 450) %>% layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
xaxis = list(title = 'Mean decrease accuracy index', range= c(0,1), nticks = 2, showline = TRUE),
yaxis = list(title = 'Model input variables', range = c(0,1), nticks = 2, showline = TRUE)) %>%
add_annotations(x = 0.5, y = 1.1, textangle = 0, font = list(size = 14, color = 'black'),
text = 'Contribution to accuracy',
showarrow = F, xref='paper', yref='paper')
p$elementId <- NULL
p <- p %>% config(displayModeBar = F)
p}
})
}
shinyApp(ui, server)
select 对比按钮结果：
别问我为什么，但我设法让它与 observeEvent 一起工作，并在将更改后的 data.table 重新分配给它之前将 NULL 分配给 the values$RFImp_FP1
values$RFImp_FP1 <- NULL
values$RFImp_FP1<- resDF
完整版：
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)
observeEvent(event_data("plotly_selected", source = 'RFAcc_FP1')$y, {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
resDF <- values$RFImp_FP1 %>% .[, Selected := if_else(Variables %in% parsToChange, !Selected, Selected)]
values$RFImp_FP1 <- NULL ## without this line the plot does not react
values$RFImp_FP1<- resDF ## re-assign the altered data.table to the reactiveValue
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * 80
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 = c('#F0F0F0', '#1b73c1'),
symbol = factor(RFImp_score$Selected),
symbols = c('x', 'circle'),
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)
为了避免关于未注册的警告，我们可以将观察结构更改为
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
}
})
仍然存在一个问题：连续两次进行相同的选择不会触发观察者，因为选择是相同的....
在下面的演示应用程序中，用户可以通过单击图中的 input$Go1 或 select 区域来更改数据行的 Selected 状态。
选择图中的区域是我想要的功能。
但是，由于我无法理解的原因，按钮确实会导致重新渲染图，而 select 不会，即使这两种方法具有相同的效果，即值的变化在 data.table 的 Selected 列中 RFImp_FP1
为什么当我在剧情中 select 点时它不起作用？
ui <- fluidPage(
actionButton(inputId = 'Go', label = 'Go'),
actionButton(inputId = 'Go2', label = 'Go2'),
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues()
observeEvent(input$Go, {
values$RFImp_FP1 <- data.table(MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
values$RFImp_FP1$Selected <- 1
})
observeEvent(input$Go2,{
values$RFImp_FP1$Selected[1:4] <- 1-values$RFImp_FP1$Selected[1:4]
print(values$RFImp_FP1$Selected)
})
observe({
if(!is.null(values$RFImp_FP1)) {
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, 1-Selected, Selected)]
values$RFImp_FP1$Selected <- data_df$Selected
print(values$RFImp_FP1)
}
}
})
observeEvent(values$RFImp_FP1, {
print('seeing change')
})
output$RFAcc_FP1 <- renderPlotly({
values$RFImp_FP1
if(!is.null(values$RFImp_FP1)) {
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * input$testme
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 = c('#1b73c1', '#797979'),
symbol = factor(RFImp_score$Selected),
symbols = c('circle','x'),
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$elementId <- NULL ## to surpress warning of widgetid
p <- p %>% config(displayModeBar = F)
p
} else {
p <- plot_ly( type = 'scatter', mode = 'markers', height = '400px', width = 450) %>% layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
xaxis = list(title = 'Mean decrease accuracy index', range= c(0,1), nticks = 2, showline = TRUE),
yaxis = list(title = 'Model input variables', range = c(0,1), nticks = 2, showline = TRUE)) %>%
add_annotations(x = 0.5, y = 1.1, textangle = 0, font = list(size = 14, color = 'black'),
text = 'Contribution to accuracy',
showarrow = F, xref='paper', yref='paper')
p$elementId <- NULL
p <- p %>% config(displayModeBar = F)
p}
})
}
shinyApp(ui, server)
select 对比按钮结果：
别问我为什么，但我设法让它与 observeEvent 一起工作，并在将更改后的 data.table 重新分配给它之前将 NULL 分配给 the values$RFImp_FP1
values$RFImp_FP1 <- NULL
values$RFImp_FP1<- resDF
完整版：
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)
observeEvent(event_data("plotly_selected", source = 'RFAcc_FP1')$y, {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
resDF <- values$RFImp_FP1 %>% .[, Selected := if_else(Variables %in% parsToChange, !Selected, Selected)]
values$RFImp_FP1 <- NULL ## without this line the plot does not react
values$RFImp_FP1<- resDF ## re-assign the altered data.table to the reactiveValue
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * 80
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 = c('#F0F0F0', '#1b73c1'),
symbol = factor(RFImp_score$Selected),
symbols = c('x', 'circle'),
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)
为了避免关于未注册的警告，我们可以将观察结构更改为
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
}
})
仍然存在一个问题：连续两次进行相同的选择不会触发观察者，因为选择是相同的....