r - R 中使用多个交互下拉菜单的绘图轨迹的可见性

Question

我想要几个下拉菜单来指定显示哪些数据。

使用 Shiny ，我可以单独传递所有选定的条件值，然后根据它们的相互作用相应地过滤数据集。

在下面的例子中是否可以获得相同的功能而不需要 Shiny ？

library(plotly)
means = c(0,1,10)
scales = c(1,5)

sample.size = 100

t.visible = rep(F,2*length(means)*length(scales))
t.buttons = list()

pl = plot_ly()

for(i in 1:length(means)){
  for(j in 1:length(scales)){

    tt.visible = (i==1)&(j==1)

    pl = pl %>% 
          add_trace(x=0:sample.size,y=c(0,cumsum(means[i]+scales[j]*rnorm(sample.size))),type='scatter',mode='lines',color='one', visible = tt.visible) %>%
          add_trace(x=0:sample.size,y=c(0,cumsum(means[i]+scales[j]*rt(sample.size,df=5))),type='scatter',mode='lines',color='two',visible = tt.visible)

    tt.visible = t.visible
    tt.visible[(i-1)*length(scales)*2+(j-1)*2+(1:2)] = T

    t.buttons[[(i-1)*length(scales)+j]] = list(
      method = 'update',
      args = list(list(visible = tt.visible),
                  list(title = paste0('mean = ',means[i],'; scale = ',scales[j]))),
      label = paste0('mean = ',means[i],'; scale = ',scales[j])
    )
  }
}

pl = pl %>% layout(
  title = paste0('mean = ',means[1],'; scale = ',scales[1]),
  xaxis = list(title='time'),
  yaxis = list(title='value'),
  updatemenus = list(list(active = 0,
                          buttons = t.buttons))
)

特别是，有没有办法拥有两个独立的(交互)按钮，一个用于 means 向量，一个用于 scales 向量？

Answer 1

您可以创建自己的下拉菜单，并使用一点 JavaScript 动态显示和隐藏痕迹。

• 根据您的输入数组动态创建下拉菜单
• 向两个菜单添加一个事件监听器
• 根据选择设置 Plotly 数据的可见

使用 htmlwidgets 时，包含 Plotly 图表的 div 作为参数传递(本例中为 el)。数据可以在 data 属性中找到。

library(plotly)
library(htmlwidgets)

means = c(0,1,10)
scales = c(1,5)
sample.size = 100

pl = plot_ly()

for(i in 1:length(means)){
  for(j in 1:length(scales)){
    trace_name <- paste('means:', means[i], '; scale:', scales[j])
    pl = pl %>% 
      add_trace(x=0:sample.size,
                y=c(0,cumsum(means[i]+scales[j]*rnorm(sample.size))),
                type='scatter',
                mode='lines',
                color='one',
                mode='line',
                visible = (i==1)&(j==1),
                name = trace_name) %>%
      add_trace(x=0:sample.size,
                y=c(0,cumsum(means[i]+scales[j]*rt(sample.size,df=5))),
                type='scatter',
                mode='lines',
                color='two',
                visible = (i==1)&(j==1),
                name = trace_name)
  }
}

javascript <- "
var select_mean = document.createElement('select');
select_mean.id = 'mean';
var select_scale = document.createElement('select');
select_scale.id = 'scale';
el.append(document.createTextNode('Means'));
el.append(select_mean);
el.append(document.createTextNode('Scale'));
el.append(select_scale);
function showTraces() {
  var select_scale = document.getElementById('scale');
  var select_mean = document.getElementById('mean');
  var scale = select_scale.options[select_scale.selectedIndex].text;
  var mean = select_mean.options[select_mean.selectedIndex].text;
  var traceName = 'means: ' + mean + ' ; ' + 'scale: ' + scale;
  for (var i = 0; i < el.data.length; i += 1) {
    el.data[i].visible = el.data[i].name.indexOf(traceName) > -1
  }
  Plotly.redraw(el)
}
select_scale.addEventListener('change', function() {
    showTraces();
});
select_mean.addEventListener('change', function() {
    showTraces();
});
"
for(i in 1:length(means)){
  javascript <- paste(javascript, "
var option = document.createElement('option');
option.text = '", means[i], "';
select_mean.append(option);", sep='')
}

for(j in 1:length(scales)) {
  javascript <- paste(javascript, "
var option = document.createElement('option');
option.text = '", scales[j], "';
select_scale.append(option);", sep='')
}

w <- as_widget(pl)
w <- htmlwidgets::onRender(w, paste("function(el, x, data) {", javascript, "}"), data=list('a', 'b'))
htmlwidgets::saveWidget(w, "buttons.html")
w