How to render a plotly plot with preset traces hidden i.e. 'legendonly' based on list

Question

Thanks to help on a previous question here I can now record in a list which traces are hidden in a plotly plot by reading out the legend list of TRUE/legendonly with a piece of javascript , which I use to change the list entries, and the color of associated buttons.

What I'm now also looking to do, is to maintain that TRUE/legendonly status when the plot is re-rendered. In the dummy app below, the plot can be re-rendered with the switch actionbutton , which causes a re- render due to a change of colors.

In other words: how to render the plot with certain traces already having 'legendonly status based on values$tracesPlot1 that was altered/recorded the last time the user looked at this particular plot.

I suspect this would involve some document.getElementById("") approach to get values$tracesPlot1, and then do the opposite of the script that is already in place to get the legend status out of this plot, and send it into the plot, with the use of the same onRender(js, data = "tracesPlot1")

HERE: you can see that when the user goes back to the first color scheme, some of the buttons are still switched off, but the plot of course has all traces visible again, instead of reflecting the button status.

ps:my app the user can switch the plot between grouped by 1 of 3 columns, causing re-rendering, and I would like to load it back with the same legend elements deselected when it renders

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")
)

server <- function(input, output, session) {
  values <- reactiveValues(colors = T, NrOfTraces = length(unique(mtcars$cyl)))


  output$plot1 <- renderPlotly({
    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 %>% onRender(js, data = "tracesPlot1")   

  })


  observeEvent(input$Switch, { values$colors <- !values$colors    })


  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"))
      }
     })
    })  

  observeEvent(input$tracesPlot1, {
    listTraces <- input$tracesPlot1
    #values$tracesPlot1 <- input$tracesPlot1
    listTracesTF <- gsub('legendonly', FALSE, listTraces)
    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)  })
}
shinyApp(ui, server)

Answer 1

You can set the visible property of the traces like this:

library(plotly)

legendItems <- list("4" = TRUE, "6" = "legendonly", "8" = TRUE)

p <- plot_ly() %>%
  add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl))
p <- plotly_build(p)

for(i in seq_along(p$x$data)){
  p$x$data[[i]]$visible <- legendItems[[p$x$data[[i]]$name]]
}

p

Answer 2

@Stephane,

I figured out how to get it working. Important that the code from your answer is put above the p1 %>% onRender(js, data = "tracesPlot1") otherwise we loose the javascript.

In the example below I made some additions so that also clicking the three buttons now activates hiding... Sadly this does mean the plot will have to re-render completely which in my 3D scatter plots with 5000 datapoints and 1-50 traces will take a few seconds. The only way to circumvent that is if we can do the manipulation of p1$x$data[[i]]$visible through javascript which alters the widget, and doesn't trigger shiny server to fire....... Any thoughts? I might open a new item for this conversion from current solution to a faster javascript approach

In the app below: clicking the legend alters input$tracePlot1 , which I manipulate into a T/F list instead of "TRUE"/"legendonly" and update values$dYNbs_cyl_el with it where needed

clicking the buttons themselves also changes values$dYNbs_cyl_el items

an observeEvent looking at values$dYNbs_cyl_el clones this list, changed T/F into "TRUE"/"legenonly" again so that it matches the legend status input, and names the list with sort(unique(mtcars$cyl)) and then converts this object into values$legenditems

if the plot is showing 'color version 1', ie a surrogate for my app, where I alter which column I group the data into traces with, then the plot uses values$legenditems to alter the status of the legenditems.

This gives a nice 3 element linked interaction in two ways. Legend alters plot and buttons buttons alter plot and legend and the plot " remembers " who was shown and who wasn't.

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({
    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    })

    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
    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)