Is it possible in R to hide plotly subplots using a dropdown

Question

I am trying generating series of small plotly plots based on a group in a data.frame and then using plotly::subplot() to bind them together. I would like to then use a dropdown filter to only display some of the subplots.

So far (using the plotly docs https://plotly.com/r/map-subplots-and-small-multiples/ and this answer https://stackoverflow.com/a/66205810/1498485) I can create the plots and the buttons and show and hide the contents of the subplots.

But I cannot figure out how to hide/reset the axis so only the selected subplot is displayed. Below is a minimised example of what I am doing.

# create data 
df <- expand.grid(group = LETTERS[1:4],
                  type = factor(c('high','med','low'), levels = c('high','med','low')),
                  date = seq(as.Date('2020-01-01'), Sys.Date(), 'month')) %>%
  mutate(value = abs(rnorm(nrow(.)))) %>%
  group_by(group)

# define plot function
create_plots <- function(dat){
  legend <- unique(dat$group) == 'A'
  plot_ly(dat, x = ~date) |> 
  add_lines(y = ~value, color = ~type, legendgroup = ~type, showlegend = legend) %>%
  add_annotations(
    text = ~unique(group),
    x = 0.1,
    y = 0.9,
    yref = "paper",
    xref = "paper",
    xanchor = "middle",
    yanchor = "top",
    showarrow = FALSE,
    font = list(size = 15)
  )
}

# create buttons to filter by group (based on https://stackoverflow.com/a/66205810/1498485)
buttons <- LETTERS[1:4] |> 
  lapply(function(x){
    list(label = x,
         method = 'update',
         args = list(list(
           name = c('high', 'med', 'low'), 
           visible = unlist(Map(rep, x == LETTERS[1:4], each = 3))
             )))
  })

# generate subplots
df %>%
  do(mafig = create_plots(.)) %>%
  subplot(nrows = 2) %>%
  layout(
    updatemenus = list(
      list(y = 0.8,
           buttons = buttons))
    )

Answer 1

Yes, but as far as I know, you'll have to go beyond the Plotly package. This solution uses the libraries htmltools and shinyRPG. (It is not a Shiny app!)

I don't think that shinyRPG is a cran package. (It wasn't when I obtained it.) To download this package use this.

devtools::install_github("RinteRface/shinyRPG")

I'm using this library to make the selection box. Instead of a dropdown, I used a multiple selection box (you can select one to many plots at the same time).

The first thing I did was comment out the layout options for the plots and assign them to an object.

# generate subplots
so <- df %>%
  do(mafig = create_plots(.)) %>%
  subplot(nrows = 2) #%>%
  # layout(
  #   updatemenus = list(
  #     list(y = 0.8,
  #          buttons = buttons))
  # )

The only other change I made to the original subplot object was to change the default height. I used this percentage because the selection box is given 15% of the space (width-wise).

so[["sizingPolicy"]][["defaultHeight"]] <- "80%"

Next is the selection box.

When it comes to the options, I have c(setNames(1:4, LETTERS[1:4])) This reflects as A, B, C, and D in the selection options, because you have that labeled on the graphs. You can change this to anything. The matching names have no bearing on connecting the selection to the plot. However, the values 1:4 do. If you change this, it will impact the selection success.

tagSel <- rpgSelect(
  "selectBox",
  "Selections:",
  c(setNames(1:4, LETTERS[1:4])), # left is values, right is labels
  multiple = T)
tagSel$attribs$class <- 'select'
tagSel$children[[2]]$attribs$class <- "mutli-select"
tagSel$children[[2]]$attribs$onchange <- "getOps(this)"

With browsable, I combined the selection box, the Javascript, and the JQuery that connects the selection with the plots visibility, some styling options, and the subplots.

If it seems like a lot, the vast majority is actually for beautification. (That's almost everything in the style tags.)

I added a lot of comments in the JS, but if something's unclear, let me know.

browsable(tagList(list(
  tags$head(
    tags$script(HTML("function getOps(sel) { /* activate select */
            $plts = $('svg g.cartesianlayer').find('g.subplot'); /* find plots */
            $labs = $('svg g.infolayer').find('g.annotation');   /* find plot labels */
            $plts.addClass('plotter');               /* add opacity to plots */
            $labs.addClass('plotter');               /* add opacity to subplot labels */
            for(i = 0; i < sel.length; i++) { /* look through options */
              opt = sel.options[i];
              j = opt.value;
              if ( opt.selected ) {
                $plts.filter(':nth-child(' + j + ')').removeClass('plotter-inact');
                $labs[i].firstChild.classList.remove('plotter-inact');
              } else {
                $plts.filter(':nth-child(' + j + ')').addClass('plotter-inact');
                $labs[i].firstChild.classList.add('plotter-inact');
              }
            }
          }")),
    tags$style(".plotter {opacity: 1;}
               .plotter-inact {opacity: 0;}
               .select { 
                 position: relative; width: 13ch;
                 border: 2px solid #003b70;
                 margin: 0 2px; cursor: pointer;
                 border-radius: 5px; font-size: 1.1em;
                 text-align: center; line-height: 1.25em;
               }
               #selectBox {
                 background-color: #003b70;
                 width: 10ch; text-align: center;
                 color: white; font-weight: bold;
                 line-height: 1.25em;
               }
               .yaLeft {
                position: relative;
                float: left; width: 85%;
                height: 100vh;
               }
               .yaRight {
                 float: right; width: 15%;
               }")),
  div(div(class = "yaLeft", so), 
      div(class = "yaRight", tagSel)))))