R flexdashboard animation with 2 traces has issue with animation slider

This question is an extension to the question asked and answered here, where an animation with a factor level on the x-axis and the same factor level as the frame in the animation have the order of the factor messed up on the slider. The question was answered for plotly in general. However, in the flexdashboard, I'm using shared data, and the answer provided in the original question doesn't cover that scenario (because it wasn't mentioned in the original question). Any help would be appreciated!

Toy example (Rmd code):

---
title: "Dashboard"
output: 
  flexdashboard::flex_dashboard:
    orientation: columns
 ---

```{r setup, include=FALSE}
library(crosstalk)     
library(flexdashboard) 
library(dplyr)         
library(plotly)    

# Make up data
data <- expand.grid(Date = seq(as.Date("2000-01-01"), as.Date("2000-04-01"), by = "1 day"),
                    Group = c("A", "B")) %>%  
            mutate(N = rnorm(n(), 0, 1),
                fr = format(Date, "%d-%b"),
                fr = factor(fr, levels = unique(fr)))

# Shared data
S_data <- SharedData$new(data, ~Group, group = "Group")
```

Date animation
===================================== 
 Column 1 {data-width=80}
-----------------------------------------------------------------------

### Data selection
```{r}
  filter_select(id = "group", label = "group",
    sharedData = S_data, group = ~Group, multiple = FALSE)
```

Column 2 {data-width=300}
-----------------------------------------------------------------------

```{r, warning = FALSE, echo = FALSE, message = FALSE}
## function provided in the answer linked to the original question
fixer <- function(plt) {
  plt <- plotly_build(plt)                   # build to get data
                                             # capture current animation order in plot
  curOrd <- invisible(lapply(1:length(plt$x$frames), function(j) {
    plt$x$frames[[j]]$name
  })) %>% unlist()
  
  fixOrd <- match(levels(data$fr), curOrd)    # compare current order; get index to fix
  plt$x$frames <- plt$x$frames[fixOrd]       # rearrange frames & slider (steps)
  plt$x$layout$sliders[[1]]$steps <- plt$x$layout$sliders[[1]]$steps[fixOrd]

                                       # change the base anim frame (when not animating)
  plt$x$data[[2]] <- plt$x$frames[[1]]$data[[1]]
  plt # return plot
}

fig <- plot_ly(S_data) %>%
    add_trace(x = ~fr,
            y = ~N, color = ~Group, 
            type = "scatter",
            mode = "markers") %>%
   add_trace(x = ~fr,
            y = ~N,
            frame = ~fr, 
            type = "scatter",
            mode = "markers",
            marker = list(color = "fuchsia")) %>%
  animation_slider() %>% fixer()  
fig
```

EDIT

Took me a minute to figure out how to upload videos, but here's 2 recordings. I commented out the fixer portion, so that there's less to troubleshoot.

Video 1 - the plot is colour-coded. The selection works correctly on the static points, but the animated traces are no longer animated.

Video 2 - the plot isn't colour-coded. The selection works correctly on the static points, and the animated trace is animated, but there are still 2 animated points, whereas there should only be 1 per selected group.

Solution

Update

I won't rehash the items I mentioned before this update.

The only changes are in the onRender function. I've added another UDF within it that loops through the frames to change the visibility, whether you're on 'A' or 'B'. The results of this function replace the frames in aData and bData respectively. Let me know if you have any questions after you look at the code comments.

Here's the updated call to create fig.

fig <- plot_ly(S_data) %>%
    add_trace(x = ~fr,
            y = ~N, color = ~Group, 
            type = "scatter",
            mode = "markers") %>%
   add_trace(x = ~fr,
            y = ~N,
            frame = ~fr, 
            type = "scatter",
            mode = "markers",
            split = ~Group, showlegend = F,
            marker = list(color = "fuchsia")) %>%
  animation_slider() %>% fixer() %>% 
  htmlwidgets::onRender(
    "function(el, x) {     /* working within HTMLwidgets */
      sel = document.querySelector('select');     /* get sel and container els*/
      dbc = document.getElementById('dashboard-container');
      xx = JSON.parse(JSON.stringify(x));   /* create deep copy of original data */
      visAdj = function(grp, dt) {          /* function for creating group data  */
        dt.data.forEach(function(elem, i) { /* if trace name == group name */
          if (dt.data[i].name === grp) {dt.data[i].visible = true} 
          if (dt.data[i].name !== grp) {dt.data[i].visible = false}
        })
        return(dt);                         /* rtn dataset */
      };
      ffBld = function(grp, dt) {           /* for creating grouped frame data */
        dt.forEach(function(it, ind) {          /* through each frame */
          it.data.forEach(function(dit, dind) { /* each trace within each frame */
            if(dit.name === grp) {dit.visible = true}  /* change vis by group */
            if(dit.name !== grp) {dit.visible = false}
          })
        })
        return(dt);                         /* rtn frames */
      }
      aData = visAdj('A', JSON.parse(JSON.stringify(xx))); /* create GROUP data*/
      aData.frames = ffBld('A', JSON.parse(JSON.stringify(xx.frames)));
      bData = visAdj('B', JSON.parse(JSON.stringify(xx)));
      bData.frames = ffBld('B', JSON.parse(JSON.stringify(xx.frames)));
    
      selv = sel.value;                        /* establish initial value */
      setInterval(function() {  /* monitor for changes; onChange ev not poss */
        sv = sel.value;            /* what is selected? is it different? */
        if(selv !== sv) {
          tellMe(sv);
          selv = sv;                       /* reset selv for next change */
        }
      }, 1000);                                   /* millisec btw checks */

      tellMe = function(selO) {         /* what do I do if there is a change? */
        if(selO === '' || selO === '(All)') {              /* show all data */
          Plotly.newPlot(el.id, xx);
        } else if (selO === 'A') {                         /* show A data */
          Plotly.newPlot(el.id, aData);
        } else if (selO === 'B') {                         /* show B data */
          Plotly.newPlot(el.id, bData);
        }
      };
    }")

Original Answer

There are a few things that are happening here.

I've added split to the trace with frames - this helps to absolve the issues that crosstalk creates between sharedData and animation frames.
Instead of one line for the first animation frame, there are two (due to the split). (This is the 2nd last line, now the 2nd and 3rd last line of code in the fixer function.)
I've added an onRender function. I wasn't able to determine if it would have been easier to add a button with JS, instead of crosstalk, or not. In this version, you're going to keep the dropdown as you've written it. The onRender function changes what data you see when you select a specific group.

Within the onRender, I've written a lot of comments so that you could see what does what. If you were to use different data, you would need to adjust the lines of code that create the objects aData, bData and the function called tellMe (within onRender, at the end). Since there were only two groups in this data, I didn't do a loop or anything particularly dynamic.

If you have any questions after you look through this code, let me know.

First, the fixer() function. I kept the original line in the code but commented it out.

fixer <- function(plt) {
  plt <- plotly_build(plt)                   # build to get data
                                             # capture current animation order in plot
  curOrd <- invisible(lapply(1:length(plt$x$frames), function(j) {
    plt$x$frames[[j]]$name
  })) %>% unlist()
  
  fixOrd <- match(levels(data$fr), curOrd)    # compare current order; get index to fix
  plt$x$frames <- plt$x$frames[fixOrd]       # rearrange frames & slider (steps)
  plt$x$layout$sliders[[1]]$steps <- plt$x$layout$sliders[[1]]$steps[fixOrd]

                                       # change the base anim frame (when not animating)
  # plt$x$data[[3]] <- plt$x$frames[[1]]$data[[1]]

  plt$x$data[[3]] <- plt$x$frames[[1]]$data[[1]] # need two because of the split
  plt$x$data[[4]] <- plt$x$frames[[1]]$data[[2]]
    # anim Frame fxr prep
  plt # return plot
}

The plot with the onRender function.

fig <- plot_ly(S_data) %>%
    add_trace(x = ~fr,
            y = ~N, color = ~Group, 
            type = "scatter",
            mode = "markers") %>%
   add_trace(x = ~fr,
            y = ~N,
            frame = ~fr, 
            type = "scatter",
            mode = "markers",
            split = ~Group, showlegend = F,
            marker = list(color = "fuchsia")) %>%
  animation_slider() %>% fixer() %>% 
  htmlwidgets::onRender(
    "function(el, x) {     /* working within HTMLwidgets */
      sel = document.querySelector('select');     /* get sel and container els*/
      dbc = document.getElementById('dashboard-container');
      xx = JSON.parse(JSON.stringify(x));   /* create deep copy of original data */
      visAdj = function(grp, dt) {          /* function for creating group data  */
        dt.data.forEach(function(elem, i) {
          if (dt.data[i].name === grp) {    /* if trace name == group name */
            dt.data[i].visible = true;
          } else {
            dt.data[i].visible = false;
          }
        });
        return(dt);                         /* rtn dataset */
      };
      aData = visAdj('A', JSON.parse(JSON.stringify(xx))); /* create GROUP data*/
      bData = visAdj('B', JSON.parse(JSON.stringify(xx)));

      selv = sel.value;                        /* establish initial value */
      setInterval(function() {  /* monitor for changes; onChange ev not poss */
        sv = sel.value;            /* what is selected? is it different? */
        if(selv !== sv) {
          tellMe(sv);
          selv = sv;                       /* reset selv for next change */
        }
      }, 1000);                                   /* millisec btw checks */

      tellMe = function(selO) {         /* what do I do if there is a change? */
        if(selO === '' || selO === '(All)') {              /* show all data */
          Plotly.newPlot(el.id, xx);
        } else if (selO === 'A') {                         /* show A data */
          Plotly.newPlot(el.id, aData);
        } else if (selO === 'B') {                         /* show B data */
          Plotly.newPlot(el.id, bData);
        }
      };
    }")