3

之前有人问过这个问题,但由于没有reprex,所以没有得到答案,所以让我试一试。

假设我有两个跨越不同日期范围的数据集。我想使用滑块控制每个的可视化。以下表示将直接在下面创建视觉对象。

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

#+ message = FALSE, warning = FALSE
library(plotly)
library(crosstalk)
library(dplyr)
#+
```

```{r}
df1 <- data.frame(d = seq.Date(from = as.Date("2020-01-01"), by = "months", length.out = 100), v = runif(100))
df2 <- data.frame(d = seq.Date(from = as.Date("2020-6-01"), by = "months", length.out = 20), other_v = runif(20))

both_df <- full_join(df1, df2, by = 'd')

both_df_sh <- both_df %>% SharedData$new(group = "boom")

selector <- filter_slider(id = "selector1", label = "select dates", sharedData = both_df_sh, column = ~d)

v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~v, name = "v", color = I("blue"))

other_v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~other_v, name = "other v", color = I("red"))
```

```{r}
crosstalk::bscols(v_p, other_v_p)
```

在此处输入图像描述

这是正确的,因为两个图表都正确显示了它们的日期范围。但是,如果该范围内不存在数据,我的客户希望在图表中看到空白。像这样的东西:

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

#+ message = FALSE, warning = FALSE
library(plotly)
library(crosstalk)
library(dplyr)
#+
```

```{r}
df1 <- data.frame(d = seq.Date(from = as.Date("2020-01-01"), by = "months", length.out = 100), v = runif(100))
df2 <- data.frame(d = seq.Date(from = as.Date("2020-6-01"), by = "months", length.out = 20), other_v = runif(20))

both_df <- full_join(df1, df2, by = 'd')

both_df_sh <- both_df %>% SharedData$new(group = "boom")

selector <- filter_slider(id = "selector1", label = "select dates", sharedData = both_df_sh, column = ~d)

v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~v, name = "v", color = I("blue")) %>% 
  layout(xaxis = list(range = list(min(both_df_sh$data()$d, na.rm = TRUE), 
                            max(both_df_sh$data()$d, na.rm = TRUE))))

other_v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~other_v, name = "other v", color = I("red")) %>% 
  layout(xaxis = list(range = list(min(both_df_sh$data()$d, na.rm = TRUE), 
                            max(both_df_sh$data()$d, na.rm = TRUE))))
```

```{r}
selector
```

```{r}
crosstalk::bscols(v_p, other_v_p)
```

正如预期的那样,这给了我们: 在此处输入图像描述

这就是我想要的!然而,现在,图表不再随 缩放filter_select,它只是隐藏了数据,这并不能创造出可爱的视觉效果: 在此处输入图像描述

所以,我希望图表限制在拖动条时“跳过”......但要做到这一点,我需要当时的值filter_select

我想我可以通过改变这样的限制来事先得到它:

selector_values <- jsonlite::fromJSON(selector$children[[3]]$children[[1]])$values

v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~v, name = "v", color = I("blue")) %>% 
  layout(xaxis = list(range = min(selector_values), max(selector_values)))

other_v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~other_v, name = "other v", color = I("red")) %>% 
  layout(xaxis = list(range = min(selector_values), max(selector_values)))

但是这些值在仪表板启动后不会被重新评估。我需要一种方法来访问这些选择器的当前值......我该怎么做?

4

1 回答 1

1

我们可以使用 plotly 的matches参数来对齐多个图的轴,就像我在这里所做的那样:

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

#+ message = FALSE, warning = FALSE
library(plotly)
library(crosstalk)
library(dplyr)
#+
```

```{r}
df1 <- data.frame(d = seq.Date(from = as.Date("2020-01-01"), by = "months", length.out = 100), v = runif(100))
df2 <- data.frame(d = seq.Date(from = as.Date("2020-6-01"), by = "months", length.out = 20), other_v = runif(20))

both_df <- full_join(df1, df2, by = 'd')

both_df_sh <- both_df %>% SharedData$new(group = "boom")

selector <- filter_slider(id = "selector1", label = "select dates", sharedData = both_df_sh, column = ~d)

v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~v, name = "v", color = I("blue"))

other_v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~other_v, name = "other v", color = I("red")) %>% layout(xaxis = list(matches = "x"))
```

```{r}
selector
```

```{r, out.width='100%'}
subplot(v_p, other_v_p, shareX = TRUE, shareY = TRUE)
```

结果


原答案:

我不确定我是否正确理解了您的预期输出,但如果您想自动缩放 x 轴,只需删除 xaxis rangelayout()调用)。crosstalk将负责根据以下内容提供过滤后的数据filter_slider

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

#+ message = FALSE, warning = FALSE
library(plotly)
library(crosstalk)
library(dplyr)
#+
```

```{r}
df1 <- data.frame(d = seq.Date(from = as.Date("2020-01-01"), by = "months", length.out = 100), v = runif(100))
df2 <- data.frame(d = seq.Date(from = as.Date("2020-6-01"), by = "months", length.out = 20), other_v = runif(20))

both_df <- full_join(df1, df2, by = 'd')

both_df_sh <- both_df %>% SharedData$new(group = "boom")

selector <- filter_slider(id = "selector1", label = "select dates", sharedData = both_df_sh, column = ~d)

v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~v, name = "v", color = I("blue"))

other_v_p <- both_df_sh %>% plot_ly(x = ~d) %>% add_lines(y = ~other_v, name = "other v", color = I("red"))
```

```{r}
selector
```

```{r}
crosstalk::bscols(v_p, other_v_p)
```

结果

使用共享 x 轴和范围滑块的非串扰方法:

library(plotly)
library(dplyr)

df1 <- data.frame(d = seq.Date(from = as.Date("2020-01-01"), by = "months", length.out = 100), v = runif(100))
df2 <- data.frame(d = seq.Date(from = as.Date("2020-6-01"), by = "months", length.out = 20), other_v = runif(20))

both_df <- full_join(df1, df2, by = 'd')

fig1 <- plot_ly(both_df, x = ~ d, y = ~ v, type = "scatter", mode = "lines")
fig2 <- plot_ly(both_df, x = ~ d, y = ~ other_v, type = "scatter", mode = "lines") 

fig_shared_x <- subplot(fig1, fig2, nrows = 2, shareX = TRUE)
fig_shared_x

fig_rangeslider <- fig_shared_x %>% layout(xaxis = list(rangeslider = list(type = "date")))
fig_rangeslider

结果

于 2022-02-02T10:16:10.543 回答