Filter annotations with transforms on Plotly (R)

Question

I would like the filter applied to the data thanks to transforms and updatemenus to also apply to the annotations (arrows).

Alternatively, my problem would be solved if we could use arrows as markers, but I couldn't figure out how.

Minimum reproducible example:

library(plotly)
library(tidyverse) 

df <- data.frame(x = rnorm(5),
                 y = rnorm(5),
                 x_end = rnorm(5),
                 y_end = rnorm(5),
                 o = c(rep(0, 4), 1))

p <- plot_ly(df,
             type = 'scatter',
             mode = 'markers',
             x = ~x,
             y = ~y,
             transforms = list(list(type = 'filter', target = ~o, operation = '=', value = df$o))) %>%
  layout(updatemenus = list(list(buttons = list(list(args = list("transforms[0].value", 0),
                                                     label = '0'),
                                                list(args = list("transforms[0].value", 1),
                                                     label = '1'))))) %>% 
  add_annotations(x = ~x,
                  y = ~y,
                  axref = "x", ayref = "y",
                  text = "",
                  ax = ~x_end,
                  ay = ~y_end)

p

EDIT:

I can now filter arrows on a plot, but I can't combine it with subplot. The first plot is updating well, but not the following ones:

library(plotly)
library(tidyverse) 


create_plot <- function(df, i){
  
  df_to_annotations <- function(df){
    nb <- nrow(df)
    return(list(x = df$x_end,
                y = df$y_end,
                xref = rep('x', nb),
                yref = rep(paste0('y', i), nb),
                axref = rep('x', nb),
                ayref = rep(paste0('y', i), nb),
                ax = df$x,
                ay = df$y,
                text = rep('', nb)) %>%
             transpose())
  }
  
  all_arrows <- df_to_annotations(df)
  arrows_0 <- df_to_annotations(df %>% filter(o > 0))
  
  return(plot_ly(df,
                 type = 'scatter',
                 mode = 'markers',
                 x = ~x_end,
                 y = ~y_end,
                 text = ~o
                 #transforms = list(list(type = 'filter', target = ~o, operation = '>', value = 0))
  )  %>% 
    layout(annotations = all_arrows,
           updatemenus = list(list(type = 'buttons',
                                   buttons = list(list(method = 'update',
                                                       args = list(list(),
                                                                   list(annotations = all_arrows)),
                                                       label = 'Tous'),
                                                  list(method = 'update',
                                                       args = list(list(),
                                                                   list(annotations = arrows_0)),
                                                       label = '> 0')))))
  )
  }


random_df <- function(){
  return(data.frame(x = 0,
                 y = c(rep(0, 3), rep(1, 3)),
                 x_end = c(rep(5, 3), rep(10, 3)),
                 y_end = runif(6, -5, 5),
                 o = c(0, 0, 1:4)))
}

df1 <- random_df()
df2 <- random_df()
df3 <- random_df()

subplot(create_plot(df1, ''),
        create_plot(df2, 2),
        create_plot(df3, 3),
        nrows = 3,
        shareX = TRUE)

EDIT 2:

Following Kat's comment, here are some clarifications on the desired result: I would like a single filter for all the subplots, that the plots have markers + arrows and that the filter acts on both the markers and the arrows.

Thanks a lot for your help!

Answer 1

Okay, so some things that may help to know upfront. The subplot function only allows one layout that all plots have to share. For the most part, you won't see the impact of this shared layout when you plot, because it assigns things like alternate axes (y, y2, y3). I'm fairly sure you're knowledgeable on this since you had the foresight to add these indicators in your annotations.

Alright, so what happened to the buttons? The function took the first assigned updatemenus and purged the rest.

I'm going to start with the fastest solution. Then I'll describe how I determined what happened so that you may be able to figure the Plotly-ism out next time you run into Plotly-problems. Last, I'll show you a way to make your function do this, so you don't need to add extra steps after calling subplot.

---

Fastest fix

There are a few actions we'll take:

• Add two empty list objects before calling create_plot
• Add these two objects into create_plot, to collect the annotations cumulatively
• split the plots using the same criteria used for the buttons (df$o > 0)
  • I also added color = I("black") and showlegend = F
  • Neither of these (color/showlegend) are needed. I added them because adding split tells Plotly 'color me by my split!' It was quite ugly! So, I made the points the same color as the arrows and got rid of the legend.
• Add visibility to the arguments for the buttons to control the presence of the markers.
• Remove the nested list from each button's second argument for the annotations
  • when you added annotations = all_arrows for the annotations, that was your indicator that list(all_arrows) was one too many nests in buttons (It's easy to miss this sort of thing...I do it all the time!)
  • I changed the calls to arr1 and arr2 in the buttons, which at this point makes no difference. This change has to do with the optional function for fixing the plot (instead of updating the subplot after it's created) that I discuss at the end of this answer.

The updated create_plot() and two empty lists:

arr1 = list()            # <--- I'm new; cumulator for all_arrows
arr2 = list()            # <--- I'm new; cumulator for arrows_0

create_plot <- function(df, i){
  df_to_annotations <- function(df){
    nb <- nrow(df)
    return(list(x = df$x_end, y = df$y_end,
                xref = rep('x', nb),
                yref = rep(paste0('y', i), nb),
                axref = rep('x', nb),
                ayref = rep(paste0('y', i), nb),
                ax = df$x, ay = df$y,
                text = rep('', nb)) %>% transpose())
  }
  all_arrows <- df_to_annotations(df) 
  arr1 <<- append(arr1, all_arrows)            # <--- I'm new; cumulator for all_arrows
  arrows_0 <- df_to_annotations(df %>% filter(o > 0))
  arr2 <<- append(arr2, arrows_0)              # <--- I'm new; cumulator for arrows_0
  return(plot_ly(df,
                 type = 'scatter',
                 mode = 'markers',
                 x = ~x_end, y = ~y_end,
                 color = I("black"),                # prevent split from setting color
                 showlegend = F,                    # turn off legend
                 split = ~ifelse(o <= 0, "0", "1"), # add split; traces set for button
                 text = ~o)  %>% 
           layout(annotations = all_arrows,
                  updatemenus = list(list(
                    type = 'buttons',
                    buttons = list(list(method = 'update',
                                        args = list(list(visible = c(T, T, T, T, T, T)),
                                                    list(annotations = arr1)),
                                        label = 'Tous'),
                                   list(method = 'update',
                                        args = list(list(visible = c(F, T, F, T, F, T)),
                                                    list(annotations = arr2)),
                                        label = '> 0')))))
  )
}

No changes to random_df or the creation of df1, df2, and df3.

The next change is to subplot. The only change is that it will be assigned to an object.

sb <- subplot(create_plot(df1, ''),
              create_plot(df2, 2),
              create_plot(df3, 3),
              nrows = 3,
              shareX = TRUE) 

Looks the same as before if you plot it (except the marker colors match the arrow colors).

Now the final steps so that your buttons work.

Take those cumulative lists and replace the arguments for the annotations in the buttons.

sb$x$layout$updatemenus[[1]]$buttons[[1]]$args[[2]]$annotations <- arr1
sb$x$layout$updatemenus[[1]]$buttons[[2]]$args[[2]]$annotations <- arr2
sb

In this image, your button is working as you requested.

---

Why did that work?

If you wanted to investigate what landed in subplot before running those last two lines of code, you could use the following:

# what annotations are currently assigned to the buttons?
invisible(lapply(1:length(sb$x$layout$updatemenus[[1]]$buttons),
                 function(i) {
                   shorty <- sb$x$layout$updatemenus[[1]]$buttons
                   invisible(lapply(1:length(shorty[[i]]$args[[2]]$annotations),
                                    function(j) {
                                      message("Button ", i, " annotation ", j,
                                              " yref = ", 
                                              shorty[[i]]$args[[2]]$annotations[[j]]$yref)
                                    }))
                 }))
# Button 1 annotation 1 yref = y
# Button 1 annotation 2 yref = y
# Button 1 annotation 3 yref = y
# Button 1 annotation 4 yref = y
# Button 1 annotation 5 yref = y
# Button 1 annotation 6 yref = y
# Button 2 annotation 1 yref = y
# Button 2 annotation 2 yref = y
# Button 2 annotation 3 yref = y
# Button 2 annotation 4 yref = y
# As you can see all of the annotations for plots 2 and 3 were dropped from updatemenus

You could use this same chunk of code again after that change. You would find that there are 18 annotations assigned to button 1 and 12 assigned to button 2.

By the way, if you wondering why the markers worked but the annotations didn't without the change, that's because there are only two traces for each plot. If you didn't add the other plots, four of the six TRUE and FALSE for visible would have been ignored.

---

Making a function do the work

So you could modify your create_plot function, but I chose to create another function. Your inputs are the data frames that you want to plot. The output is the subplot with working buttons.

subplotter <- function(...) {
  dots <- list(...) 
  if(length(dots) == 0) return(NULL)
  lapply(1:length(dots),
         function(k) {
           if(k < 2) {
             d <- create_plot(dots[[k]], '') # create the plots
           } else {
             d <- create_plot(dots[[k]], k)  # create the plots
           }
           d2 <- plotly_build(d)             # ensure that layout is built
           if(isTRUE(k != length(dots))) {   # if not last plot, remove buttons
             remr <- which(names(d2$x$layout) == "updatemenus", arr.ind = T)
             d2$x$layout <- d2$x$layout[-remr] # remove updatemenus*
           }
           dots[[k]] <<- d2                 # replace the contents with the plot
         })
  return(subplot(dots, nrows = length(dots), shareX = T)) # plot it!
}

subplotter(df1, df2, df3)

All the code together

This combines all the code necessary to generate the plot from start to finish, using your functions and the function I created. (This is just to simplify everything I put in this answer.)

library(plotly)
library(tidyverse)

arr1 = list()            # <--- I'm new; cumulator for all_arrows
arr2 = list()            # <--- I'm new; cumulator for arrows_0

create_plot <- function(df, i){
  df_to_annotations <- function(df){
    nb <- nrow(df)
    return(list(x = df$x_end, y = df$y_end,
                xref = rep('x', nb),
                yref = rep(paste0('y', i), nb),
                axref = rep('x', nb),
                ayref = rep(paste0('y', i), nb),
                ax = df$x, ay = df$y,
                text = rep('', nb)) %>% transpose())
  }
  all_arrows <- df_to_annotations(df) 
  arr1 <<- append(arr1, all_arrows)            # <--- I'm new; cumulator for all_arrows
  arrows_0 <- df_to_annotations(df %>% filter(o > 0))
  arr2 <<- append(arr2, arrows_0)              # <--- I'm new; cumulator for arrows_0
  return(plot_ly(df,
                 type = 'scatter',
                 mode = 'markers',
                 x = ~x_end, y = ~y_end,
                 color = I("black"),                # prevent split from setting color
                 showlegend = F,                    # turn off legend
                 split = ~ifelse(o <= 0, "0", "1"), # add split for button
                 text = ~o)  %>% 
           layout(annotations = all_arrows,
                  updatemenus = list(list(
                    type = 'buttons',
                    buttons = list(list(method = 'update',
                                        args = list(list(visible = c(T, T, T, T, T, T)),
                                                    list(annotations = arr1)),
                                        label = 'Tous'),
                                   list(method = 'update',
                                        args = list(list(visible = c(F, T, F, T, F, T)),
                                                    list(annotations = arr2)),
                                        label = '> 0')))))
  )
}

random_df <- function(){
  return(data.frame(x = 0,
                    y = c(rep(0, 3), rep(1, 3)),
                    x_end = c(rep(5, 3), rep(10, 3)),
                    y_end = runif(6, -5, 5),
                    o = c(0, 0, 1:4)))
}

df1 <- random_df()
df2 <- random_df()
df3 <- random_df()

subplotter <- function(...) {
  dots <- list(...) 
  if(length(dots) == 0) return(NULL)
  lapply(1:length(dots),
         function(k) {
           if(k < 2) {
             d <- create_plot(dots[[k]], '') # create the plots
           } else {
             d <- create_plot(dots[[k]], k)  # create the plots
           }
           d2 <- plotly_build(d)             # ensure that layout is built
           if(isTRUE(k != length(dots))) {   # if not last plot, remove buttons
             remr <- which(names(d2$x$layout) == "updatemenus", arr.ind = T)
             d2$x$layout <- d2$x$layout[-remr] # remove updatemenus*
           }
           dots[[k]] <<- d2                 # replace the contents with the plot
         })
  return(subplot(dots, nrows = length(dots), shareX = T)) # plot it!
}

subplotter(df1, df2, df3)