I'm looking for a way to link actionButton clicks to the legend status true/legendonly that doesn't cause a re-rendering of the plotly object but instead alters the widget. Current demo app at the bottom does achieve the link, but does so through full redrawing of the plot.
I'm aiming to link the buttons that indicate keep/drop a cluster to the visualization of the data in a plot in both direction in such a way that the plot is updated, not rendered. My current solution does cause full rendering.
The interaction is that i.e. Buttons change legend/plot & legend changes buttons.
I added some images to explain the workflows.
I have build a test version for a bigger plot in my even bigger actual app, where the user has this view:
Here the user can choose which clusters to remove for further processing by means of the in/out buttons.
Thanks to the previous question here I now have a test app where: - 1 clicking the legend changes the plot, and the button status on the left, so the user can use the plot to make the IN/OUT choices - 2 Whenever the plot re-renders, it now also reactivates the previous show/hide status of each trace.
point 1 is this work flow: 
point two is simply the plot code using this line of code before the onRender
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")
There is currently also a third interaction which causes traces to become hidden when the user clicks a button. That approach is the issue here. It currently follows the orange flow in the diagram below, but i'm hoping to change that by a javascript solution that avoids re-rendering of the plot: 
THE DEMO APP
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({
print('plotting!')
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 })
##### THIS BLOCK links buttons -> plot, but causes it to render all over again
### this interaction is what I would like to replace by javascript
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
values$legenditems <- listTraces ## this line would save the legend status even if we remove the observer for the values$dYNbs_cyl_el list
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)
UPDATED Test app, with attempt to use the answer. not working still
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);",
# " });",
# "}")
js2 <- c(
"function(el, x, inputName){",
" var id = el.getAttribute('id');",
" if(id == inputName){",
" var data = el.data;",
" $('[id^=btn]').on('click', function() {",
" var index = parseInt(this.id.split('-')[1]);",
" var trace = index -1; ",
" var v0 = data[trace].visible || true;",
" var v = v0 == true ? 'legendonly' : true;",
" Plotly.restyle(el, {visible: v}, [trace]);",
" });",
" }",
"}")
YNElement <- function(idx){sprintf("btn-%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({
print('plotting!')
values$legenditemNames <- sort(unique(mtcars$cyl))
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(js2, data = "tracesPlot1")
})
observeEvent(input$Switch, { values$colors <- !values$colors })
##### THIS BLOCK links buttons -> plot, but causes it to render all over again
# observeEvent(values$dYNbs_cyl_el, {
# legenditems <- values$dYNbs_cyl_el
# legenditems[which(legenditems == FALSE)] <- 'legendonly'
# legenditems[which(legenditems == TRUE )] <- 'TRUE'
# names(legenditems) <- values$legenditemNames
# 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
values$legenditems <- listTraces
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)
