Question

在下面的虚拟应用程序中，用户可以通过拖动1个或更多点周围的区域来选择/取消选择点。这导致更改这些点的状态以从data.table中的T <-> F翻转。

目前我要解决的是如何在处理后清空event_data

或至少确保用户可以连续两次选择同一组点。

即：现在，选择底部的三个点将它们变成十字形，选择相同的三个点并打算将它们转回圆圈目前不起作用，因为event_data与先前的选择相同。

我以为我可以用，但事实证明我没有用。

可以通过双击来清除事件数据，但我想达到同样的效果，可以通过代码中的自动功能在处理完事件后立即将其清除。我还尝试使用此解决方案来处理点击事件，但无法使其适用于我选择的事件HERE

  useShinyjs(),

    extendShinyjs(text = "shinyjs.resetSelect = function() { Shiny.onInputChange('.clientValue-plotly_click-A', 'null'); }"),

在用户界面中，js$resetSelect()在服务器块中

GIF显示在拖动选择动作之间进行双击与不进行双击之间的行为差异。

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)

Answer 1

请检查以下内容：

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)

结果：

Answer 2

通常，反应性方法可能更好，但是由于我的原因，我选择坚持观察

 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({...})触发两次，但这没有进一步的含义，因为value $ Selected仅在第一次更改。如果没有此声明，则新的Plotly版本会导致应用程序在以下情况下引发以下错误：如果该图不在您打开的第一页上（即在另一个选项卡或下拉按钮上）

警告：“ plotly_selected”事件将源ID绑定为“ RFAcc_FP1” 没有注册。为了获得此事件数据，请添加 event_register(p, 'plotly_selected')至您想要的地块（p）从中获取事件数据。

可运行的应用程序：

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)

处理后从plotly select中清除event_data

2 个答案: