In the dummy app below, the user can select / deselect points by dragging a region around 1 or more points. This results in changing the state of these points to flip from T <-> F in the data.table.
What I'm trying to solve at the moment, is how to empty the event_data after processing it,
or at least making sure it is possible for the user to select the same set of points twice in a row.
i.e.: Now, selecting the bottom three points will turn them into crosses, selecting the same three points with the intend to turn them back to circles currently does not work as the event_data is identical to the previous selection.
I thought I had it working, but it turns out I did not.
Plotly allows the event data to be cleared with double click but I want to achieve the same effect to do this with automatic functionality in the code to clear it as soon as it's processed. I also tried to play around with this solution for click events, but I can't get it to work for my select events HERE
useShinyjs(),
extendShinyjs(text = "shinyjs.resetSelect = function() { Shiny.onInputChange('.clientValue-plotly_click-A', 'null'); }"),
in the UI and js$resetSelect()in the server block
GIF shows the difference between the behavior with and without double clicking between drag select actions.
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)
