我们可以创建表示两个图例项的两条初始迹线。
之后，我们需要将所有增加和减少的记录道分配到初始记录道引入的图例组中，并隐藏它们的图例项：

library(plotly)
library(dplyr)
library(data.table)

example_data <- structure(list( Date = structure(c(1569888000, 1572566400,
1575158400, 1577836800, 1580515200, 1583020800, 1585699200, 1588291200,
1590969600, 1569888000, 1572566400, 1575158400, 1577836800, 1580515200,
1583020800, 1585699200, 1588291200, 1590969600, 1569888000, 1572566400,
1575158400, 1577836800, 1580515200, 1583020800, 1585699200, 1588291200,
1590969600), class = c("POSIXct",  "POSIXt"), tzone = "UTC"), Percent_change =
c(-45, -50, -25, -30, -40, -35, -1, -5, -25, 30, 45, 50, -30, -40, -35, -1,
-5, -25, 50, -45, -30, -15, -20, -35, -1, -5, -25), Toys = c("Toy 1", "Toy 1",
"Toy 1", "Toy 1", "Toy 1", "Toy 1", "Toy 1", "Toy 1", "Toy 1", "Toy 2", "Toy 2",
"Toy 2", "Toy 2", "Toy 2", "Toy 2", "Toy 2", "Toy 2", "Toy 2", "Toy 3",
"Toy 3", "Toy 3", "Toy 3", "Toy 3", "Toy 3", "Toy 3", "Toy 3", "Toy 3")),
class = c("tbl_df",  "tbl",  "data.frame"), row.names = c(NA, -27L))

percent <- function(x, digits = 2, format = "f", ...) {
  paste0(formatC(x, format = format, digits = digits, ...), "%")
}

my_plot <- . %>%
  plot_ly(
    x = ~ Date[1],
    y = 0,
    type = "bar",
    name = "increasing",
    color = I("darkgreen"),
    legendgroup = "increasing",
    showlegend = ~ all(showlegend)
  ) %>%
  add_trace(
    x = ~ Date[1],
    y = 0,
    type = "bar",
    name = "decreasing",
    color = I("red"),
    legendgroup = "decreasing",
    showlegend = ~ all(showlegend)
  ) %>%
  add_trace(
    x = ~ Date,
    y = ~ Percent_change,
    type = "waterfall",
    # split = ~ legendgroup,
    hoverinfo = "text",
    hovertext = ~ paste("Date :", Date, "<br> % Change:", percent(Percent_change)),
    increasing = list(marker = list(color = "red")),
    decreasing = list(marker = list(color = "green")),
    totals = list(marker = list(color = "blue")),
    textposition = "outside",
    legendgroup = ~ legendgroup,
    showlegend = FALSE
  ) %>%
  add_annotations(
    text = ~ unique(Toys),
    x = 0.5,
    y = 1,
    yref = "paper",
    xref = "paper",
    xanchor = "middle",
    yanchor = "top",
    showarrow = FALSE,
    font = list(size = 15),
    yshift = 10
  )  %>%
  layout(yaxis = list(title = "% Change", ticksuffix = "%"),
         xaxis = list(title = c("Date")),
         legend = list(
           itemclick = FALSE,
           itemdoubleclick = FALSE,
           groupclick = FALSE
         ))

example_data %>%
  dplyr::filter(!is.na(Date))  %>%
  mutate(legendgroup = case_when(
    Percent_change >= 0 ~ "increasing",
    Percent_change < 0 ~ "decreasing",
  )) %>%
  mutate(showlegend = data.table::rleid(Toys, legendgroup) %in% c(1, 2)) %>%
  group_by(Toys) %>%
  distinct() %>%
  do(p = my_plot(.)) %>%
  subplot(
    nrows = 3,
    shareX = FALSE,
    titleY = TRUE,
    titleX = FALSE
  )

PS：如果你更喜欢使用增加和减少部分的单独轨迹来显示你的瀑布，那么在add_trace调用中使用split = ~ legendgroup。此外，你需要在layout调用中将itemclick等设置回TRUE。

您可以在R中编辑图例名称，并使用javascript编辑图例颜色

• 编辑：我将把这个留在这里，因为这是一种不同的方法，有时是有用的，但我认为@ismirsehregal的答案-它不涉及黑客plotly.js创建的对象-更好。*

步骤：
1.重新定义my_plot()函数，使其将第一个轨迹命名为"decreasing"，将第二个轨迹命名为"increasing"。
1.附加一些javascript来手动更改图例颜色。
1.调用函数，隐藏第三个图例，并附加javascript

1.重新定义函数

这与您的函数相同，只是它将前两组Map为"递增"或"递减"。

my_plot <- function(x,
                    group_name,
                    groups_to_show_legend = c(
                        "Toy 1" = "decreasing", "Toy 2" = "increasing"
                    )) {
    x %>%
        plot_ly(
            x = ~Date, y = ~Percent_change, type = "waterfall",
            hoverinfo = "text",
            hovertext = ~ paste(
                "Date :", Date,
                "<br> % Change:", percent(Percent_change)
            ),
            increasing = list(marker = list(color = "red")),
            decreasing = list(marker = list(color = "green")),
            totals = list(marker = list(color = "blue")),
            textposition = "outside",
            legendgroup = "trace 1",
            name = groups_to_show_legend[group_name]
        ) %>%
        add_annotations(
            text = ~ unique(Toys),
            x = 0.5,
            y = 1,
            yref = "paper",
            xref = "paper",
            xanchor = "middle",
            yanchor = "top",
            showarrow = FALSE,
            font = list(size = 15),
            yshift = 10
        ) %>%
        layout(
            yaxis = list(
                title = "% Change",
                ticksuffix = "%"
            ),
            xaxis = list(title = c("Date")),
            showlegend = TRUE
        )
}

2.附加一些javascript

我们可以在R中定义一个javascript字符串，并将其提供给由plotly创建的htmlwidget，这使得"递减"符号为红色，"递增"符号为绿色。

js_text <- htmltools::HTML('
    let legend = document.querySelector(\'.scrollbox\');\n
    let symbols = legend.getElementsByClassName("legendsymbols");\n
    const re = new RegExp("fill: rgb.*?;", "ig");\n
    symbols[0].innerHTML = symbols[0].innerHTML.replaceAll(re, "fill: rgb(255, 0, 0);");\n
    symbols[1].innerHTML = symbols[1].innerHTML.replaceAll(re, "fill: rgb(0, 128, 0);");\n
')

3.调用函数，隐藏第三个图例，并追加javascript

我用split()和purrr::imap()替换了过时的do()，这样我们还可以为函数提供组名：

example_data |>
    dplyr::filter(!is.na(Date)) |>
    group_by(Toys) |>
    distinct() |>
    split(~Toys) |>
    purrr::imap(my_plot) |>
    subplot(
        nrows = 3,
        shareX = FALSE,
        titleY = TRUE,
        titleX = FALSE
    ) |>
    style(showlegend = FALSE, traces = 3)  |>
    htmlwidgets::prependContent(
        htmlwidgets::onStaticRenderComplete(js_text)
    )

我们使用htmlwidgets::prependContent()将此代码附加到plotly对象，并使用htmlwidgets::onStaticRenderComplete()确保它在加载对象后立即运行。

您可以使用style删除多个traces。这将为图表创建一个图例，如下所示：

library(plotly)
library(dplyr)
my_plot <- . %>% 
  plot_ly(x = ~Date, y = ~Percent_change, type = "waterfall",
          hoverinfo = "text",
          hovertext = ~paste("Date :", Date,
                             "<br> % Change:", percent(Percent_change)),
          increasing = list(marker = list(color = "red")),
          decreasing = list(marker = list(color = "green")),
          totals = list(marker = list(color = "blue")),
          textposition = "outside", legendgroup = "trace 1") %>%
  add_annotations(
    text = ~unique(Toys),
    x = 0.5,
    y = 1,
    yref = "paper",
    xref = "paper",
    xanchor = "middle",
    yanchor = "top",
    showarrow = FALSE,
    font = list(size = 15),
    yshift = 10
  )  %>%
  layout(yaxis = list(title = "% Change",
                      ticksuffix = "%"),
         xaxis = list(title = c("Date")),
         showlegend = TRUE)

example_data %>%
  dplyr::filter(!is.na(Date)) %>% 
  group_by(Toys) %>%
  distinct()  %>%
  do(p = my_plot(.)) %>%
  subplot(nrows = 3, shareX = FALSE, titleY= TRUE, titleX= FALSE) %>%
  style(showlegend = FALSE, traces = c(1,2))

创建于2023年2月8日，使用reprex v2.0.2