带有 2 条轨迹的 R flexdashboard 动画存在动画滑块问题

Question

这个问题是对here提出和回答的问题的扩展，其中x轴上具有因子级别且因子级别与动画中的帧相同的动画的因子顺序在滑块上混乱。总体来说，这个问题已经得到了

plotly

的回答。但是，在

flexdashboard

中，我使用的是共享数据，原始问题中提供的答案并未涵盖该场景（因为原始问题中未提及）。任何帮助将不胜感激！

玩具示例（Rmd代码）：

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

编辑

我花了一分钟才弄清楚如何上传视频，但这里有 2 个录音。我注释掉了

fixer

部分，这样可以减少故障排除。

视频 1 - 该图采用颜色编码。选择在静态点上可以正常工作，但动画轨迹不再是动画的。

视频 2 - 情节没有颜色编码。选择在静态点上正确工作，并且动画轨迹已动画化，但仍然有 2 个动画点，而每个选定组应该只有 1 个。

Answer 1

这里正在发生一些事情。

1. 我已将

   split

   添加到带有帧的跟踪中 - 这有助于解决

   crosstalk

   在

   sharedData

   和动画帧之间创建的问题。
2. 第一个动画帧不是一行，而是两行（由于分割）。 （这是修复程序函数中的倒数第二行，现在是倒数第二行和第三行代码。）
3. 我添加了一个

   onRender

   功能。我无法确定使用 JS 添加按钮是否会比

   crosstalk

   更容易。在此版本中，您将保留您编写的下拉列表。

   onRender

   功能会更改您选择特定组时看到的数据。

在

onRender

中，我写了很多评论，以便您可以看到什么是做什么的。如果要使用不同的数据，则需要调整创建对象

aData

、

bData

和名为

tellMe

的函数（在最后的

onRender

内）的代码行。由于此数据中只有两组，因此我没有执行循环或任何特别动态的操作。

如果您在阅读此代码后有任何疑问，请告诉我。

首先是

fixer()

功能。我保留了代码中的原始行，但将其注释掉了。

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
}

带有

onRender

函数的绘图。

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