plotly

R语言plotly包生成交互式图表

基本功能

基本配置

library(plotly)
library(bslib)
library(tidyverse)
library(timetk)
# 重新定义一个中文，且不显示plotlylogo的函数
plot_ly <- function(...) {
  config(plotly::plot_ly(...), displaylogo = FALSE, locale = "zh-cn")
}

添加图层

p <- plot_ly(data = iris, x = ~Sepal.Length, y = ~Sepal.Width) %>%
  add_markers(type = "scatter", mode = "markers")
p

添加颜色

p <- plot_ly(data = iris, x = ~Sepal.Length, y = ~Sepal.Width) %>%
  add_markers(type = "scatter", mode = "markers", color = ~Species)
p

修改刻度

格式化

• 整数格式：“.0f”（例如：1000）

• 浮点数格式：“.2f”（例如：1000.00）

• 百分比格式：“%”（例如：‘.2%’ 输出50.00%）

• 科学计数法格式：“e”（例如：1.00e+03）

• 日期格式：“%Y-%m-%d”（例如：2022-01-01）

p <- p %>% layout(
  xaxis = list(title = "萼片长度", tickformat = ".2f"),
  yaxis = list(title = "萼片宽度", tickformat = ",")
)
p

添加标题

p <- p %>% layout(
  title = "鸢尾花种类与萼片"
)
p

修改边距

p <- p %>% layout(
  margin = 0
)
p

自定义工具提示

自定义工具提示主要用到以下几个参数：

1. text：用于指定工具提示的内容。可以是一个字符向量，每个元素对应一个数据点的工具提示内容。也可以使用\~\~来引用数据框中的列，例如\~\~paste("Label: ", label)。

2. hoveron：用于指定工具提示的触发方式。默认值为”point”，表示当鼠标悬停在数据点上时触发工具提示。其他可选值包括”fill”（当鼠标悬停在填充区域上时触发）和”all”（同时触发点和填充区域）。

3. hoverlabel：用于设置工具提示的样式。可以包括以下参数：

   • bgcolor：工具提示的背景颜色。

   • font：工具提示的字体样式，可以包括size（字体大小）、family（字体类型）、color（字体颜色）等。

   • bordercolor：工具提示的边框颜色。

   • borderwidth：工具提示的边框宽度。

   • namelength：工具提示中显示的变量名的最大长度。

p <- plot_ly(
  x = c(1, 2, 3),
  y = c(1, 2, 1),
  fill = "toself",
  mode = "markers+lines",
  hoverinfo = "text"
)

subplot(
  add_trace(p, text = "triangle", hoveron = "fills"),
  add_trace(p, text = paste0("point", 1:3), hoveron = "points")
)

library(tibble)
library(forcats)

tooltip_data <- tibble(
  x = " ",
  y = 1,
  categories = as_factor(c(
    "Glyphs", "HTML tags", "Unicode",
    "HTML entities", "A combination"
  )),
  text = c(
    "<U+0001F44B> glyphs <U+0CA0>_<U+0CA0>",
    "Hello <span style='color:red'><sup>1</sup><U+2044><sub>2</sub></span>
    fraction",
    "\U0001f44b unicode \U00AE \U00B6 \U00BF",
    "&mu; &plusmn; &amp; &lt; &gt; &nbsp; &times; &plusmn; &deg;",
    paste("<b>Wow</b> <i>much</i> options")
  )
)

plot_ly(tooltip_data, hoverinfo = "text") %>%
  add_bars(
    x = ~x,
    y = ~y,
    color = ~ fct_rev(categories),
    text = ~text
  ) %>%
  layout(
    barmode = "stack",
    hovermode = "x", # 悬浮时比较数据
    hoverlabel = list(bgcolor = "white", font = list(size = 16))
  )

ggplot2转plotly

使用ggplotly可以直接将ggplot2图表转为plotly图表

pm <- GGally::ggpairs(iris, aes(color = Species))
ggplotly(pm)

常用图表

散点图

plot_ly(data = iris, x = ~Sepal.Length, y = ~Sepal.Width, color = ~Species) %>%
  add_trace(type = "scatter", mode = "markers") %>%
  layout(
    xaxis = list(title = "萼片长度", tickformat = ","),
    yaxis = list(title = "萼片宽度", tickformat = ","),
    title = "鸢尾花种类与萼片",
    margin = 0
  )

哑铃图

library(gapminder)
gapminder %>%
  group_by(year, continent) %>%
  summarise(pop = mean(pop)) %>%
  ungroup() %>%
  mutate(year = str_c(year, "年")) %>%
  filter(year %in% c("1952年", "2007年")) %>%
  pivot_wider(names_from = year, values_from = pop) %>%
  plot_ly() %>%
  add_segments(
    x = ~`1952年`,
    y = ~continent,
    xend = ~`2007年`,
    yend = ~continent,
    color = I("gray"),
    showlegend = FALSE
  ) %>%
  add_markers(
    x = ~`1952年`,
    y = ~continent,
    color = I("#01B8AA"),
    name = "1952年"
  ) %>%
  add_markers(
    x = ~`2007年`,
    y = ~continent,
    color = I("#FD625E"),
    name = "2007年"
  ) %>%
  layout(
    xaxis = list(title = "1952年 vs 2007年 各州人口变化", tickformat = ",.0f"),
    yaxis = list(title = "洲")
  )

折线图

p <- economics %>%
  plot_ly(x = ~date, y = ~ unemploy / pop) %>%
  add_lines() %>%
  mutate(rate = unemploy / pop) %>%
  filter(rate == max(rate)) %>%
  rangeslider()
layout(p,
  annotations = list(x = ~date, y = ~rate, text = "峰值"),
  yaxis = list(tickformat = ".2%")
)

日期折线图

当在shiny中绘制可交互式筛选的折线图时，如果x轴的格式设置为日期，当筛选日期少时，可能会出现日期标签重复的情况，如下示例

# 创建示例数据
df <- data.frame(
  Date = as.Date(c("2024-01-01", "2024-01-02", "2024-01-03")),
  Value = c(10, 15, 20)
)

# 绘制图形
p <- plot_ly(df, x = ~Date, y = ~Value, type = "scatter") %>%
  add_lines() %>%
  layout(xaxis = list(tickformat = "%Y-%m-%d", tickmode = "date"))

p

可以通过将日期变为分类变量，并设置x轴的最大标签数量，来避免该情况

p <- plot_ly(df, x = ~Date, y = ~Value, type = "scatter") %>%
  add_lines() %>%
  layout(xaxis = list(tickformat = "%Y-%m-%d", tickmode = "auto", nticks = 10, type = "category"))

p

拟合线

plot_ly(
  economics,
  type = "scatter",
  x = ~date,
  y = ~uempmed,
  name = "失业人数",
  mode = "markers+lines",
  marker = list(color = "steelblue"),
  line = list(color = "steelblue", dash = "dashed")
) %>%
  add_trace(
    x = ~date,
    y = ~ fitted(loess(uempmed ~ as.numeric(date))),
    name = "拟合曲线",
    mode = "markers+lines",
    marker = list(color = "orange"),
    line = list(color = "orange", dash = "dashed")
  ) %>%
  layout(
    title = "失业时间",
    xaxis = list(title = "日期", showgrid = F),
    yaxis = list(title = "失业人数）"),
    margin = list(l = 10, r = 10, autoexpand = T),
    legend = list(
      x = 0,
      y = 1,
      orientation = "v",
      title = list(text = "")
    )
  )

帕累托图

dat <- tibble(
  category = c("A", "B", "C", "D", "E"),
  value = c(50, 30, 20, 15, 5)
) %>%
  arrange(desc(value)) %>%
  mutate(cumpercent = cumsum(value) / sum(value))

plot_ly(data = dat) %>%
  add_bars(
    x = ~category,
    y = ~value,
    showlegend = F,
    color = I("gray60"),
    name = "数量"
  ) %>%
  add_lines(
    x = ~category,
    y = ~cumpercent,
    yaxis = "y2",
    showlegend = F,
    color = I("gray40"),
    name = "累计占比"
  ) %>%
  layout(
    yaxis2 = list(
      tickfont = list(color = "black"),
      overlaying = "y",
      tickformat = ".1%",
      side = "right",
      title = "累积百分比（%）",
      showgrid = F,
      automargin = TRUE
    ),
    xaxis = list(
      title = "分类",
      showgrid = F,
      showline = F
    ),
    yaxis = list(
      title = "数量",
      showgrid = F,
      showline = F
    )
  )

折线卡

data <- data.frame(
  x = tk_make_timeseries(start_date = "2024-01-01", end_date = "2024-01-31"),
  y = runif(31, 50, 100)
)

p <- data %>%
  plot_ly(
    x = ~x,
    y = ~y
  ) %>%
  add_lines(
    color = I("#00b280"),
    fill = "tozeroy",
    span = I(1),
    alpha = 0.2
  ) %>%
  layout(
    xaxis = list(
      tickformat = "%Y-%m-%d",
      visible = FALSE,
      showgrid = FALSE,
      title = ""
    ),
    yaxis = list(
      visible = FALSE,
      showgrid = FALSE,
      title = ""
    ),
    hovermode = "x",
    margin = list(
      t = 0,
      r = 0,
      l = 0,
      b = 0
    ),
    # font = list(color = color),
    paper_bgcolor = "transparent",
    plot_bgcolor = "transparent"
  ) %>%
  config(displayModeBar = FALSE)
card(p, full_screen = T)

Expand

柱状图

mtcars %>%
  plot_ly(x = ~ factor(vs)) %>%
  add_histogram()

# barmode:stack 纵向堆叠


diamonds %>%
  count(cut, clarity) %>%
  plot_ly(x = ~cut, y = ~n, color = ~clarity) %>%
  add_bars() %>%
  layout(barmode = "stack")

# barmode:dodge 横向堆叠
diamonds %>%
  count(cut, clarity) %>%
  plot_ly(x = ~cut, y = ~n, color = ~clarity) %>%
  add_bars() %>%
  layout(barmode = "dodge")

箱线图

bslib::card(
  iris %>%
    plot_ly(
      x = ~Species,
      y = ~Sepal.Length
    ) %>%
    add_boxplot() %>%
    layout(yaxis = list(title = "")),
  full_screen = TRUE
)

Expand

漏斗图

dat <- data.frame(
  event = c("浏览", "下载", "下单", "结算"),
  value = c(80, 60, 50, 10)
) %>%
  transform(percent = value / cumsum(value))

plot_ly(data = dat) %>%
  add_trace(
    type = "funnel",
    y = ~event,
    x = ~value,
    marker = list(color = RColorBrewer::brewer.pal(n = 4, name = "Pastel2")),
    text = ~ paste0(value, "<br>", scales::percent(percent)),
    textposition = "auto",
    textinfo = "value+percent previous",
    hoverinfo = "text"
  ) %>%
  plotly::layout(yaxis = list(categoryarray = ~event, title = ""))

雷达图

plot_ly(type = "scatterpolar", mode = "markers", fill = "toself") %>%
  add_trace(
    r = runif(n = 6, min = 0, max = 100),
    color = I("lightblue"),
    theta = LETTERS[1:6],
    name = "类型1"
  ) %>%
  add_trace(
    r = runif(n = 6, min = 0, max = 100),
    color = I("pink"),
    theta = LETTERS[1:6],
    name = "类型2"
  ) %>%
  layout(polar = list(radialaxis = list(
    visible = T, range = c(0, 100)
  )))

旭日图

library(dplyr)
library(plotme)
starwars_count <- count(starwars, species, eye_color, name)

count_to_sunburst(starwars_count)

count_to_sunburst(starwars_count, fill_by_n = TRUE)

树图

count_to_treemap(starwars_count, sort_by_n = TRUE)

播放轴

library(plotly)
library(gapminder)
plot_ly(
  gapminder,
  x = ~gdpPercap,
  y = ~lifeExp,
  frame = ~year,
  color = ~continent,
  sizes = c(10, 1000)
) %>%
  add_trace(
    type = "scatter",
    mode = "markers",
    size = ~pop
  ) %>%
  animation_button(label = "播放")

组合图

subplot将多个ployly图表合并为一个

panel <- . %>%
  plot_ly(x = ~date, y = ~value) %>%
  add_lines() %>%
  add_annotations(
    text = ~ unique(variable),
    x = 0.5,
    y = 1,
    yref = "paper",
    xref = "paper",
    yanchor = "bottom",
    showarrow = FALSE,
    font = list(size = 15)
  ) %>%
  layout(
    showlegend = FALSE,
    shapes = list(
      type = "rect",
      x0 = 0,
      x1 = 1,
      xref = "paper",
      y0 = 0,
      y1 = 16,
      yanchor = 1,
      yref = "paper",
      ysizemode = "pixel",
      fillcolor = toRGB("gray80"),
      line = list(color = "transparent")
    )
  )

economics_long %>%
  group_by(variable) %>%
  do(p = panel(.)) %>%
  subplot(nrows = NROW(.), shareX = TRUE)

借助ggplot2实现分面

# 使用ggplot2创建基础图形
p <- ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  facet_wrap(~cyl) # 按照气缸数分面

# 将ggplot对象转换为plotly对象
ggplotly(p)

双轴图

p <- economics %>%
  mutate(year = year(date)) %>%
  group_by(year) %>%
  summarise(pop = mean(pop), unemploy = mean(unemploy)) %>%
  mutate(unemploy_rate = unemploy / pop) %>%
  plot_ly() %>%
  add_bars(
    x = ~year, y = ~pop,
    color = I("steelblue"),
    name = "人口",
    text = ~ paste0(
      "年份：", year, "<br>",
      "人口：", format(pop, big.mark = ","), "<br>",
      "失业人口：", format(unemploy, big.mark = ","), "<br>",
      "失业率：", scales::percent(unemploy_rate, accuracy = 0.01), "<br>"
    ),
    hoverinfo = "text",
    textposition = "none" # 隐藏标签
  ) %>%
  add_lines(
    x = ~year, y ~ unemploy_rate,
    name = "失业率", yaxis = "y2",
    text = ~ paste("失业率：", scales::percent(unemploy_rate, accuracy = 0.01), "<br>"),
    hoverinfo = "text",
    line = list(shape = "spline", width = 2, dash = "line")
  ) %>%
  layout(
    title = "历年人口与失业率",
    yaxis2 = list(
      tickfont = list(color = "black"),
      overlaying = "y",
      side = "right",
      title = "失业率（%）",
      tickformat = ".1%",
      showgrid = F,
      rangemode = "tozero", # y轴从0开始
      automargin = TRUE
    ),
    xaxis = list(title = "日期", showgrid = F, showline = F),
    yaxis = list(title = " ", showgrid = F, rangemode = "tozero", showline = F),
    margin = list(l = 10, r = 10, autoexpand = T),
    legend = list(
      x = 0, y = 1, orientation = "h",
      title = list(text = " ")
    )
  )
p

分面

htmlwidgets

https://www.htmlwidgets.org是一个网站，收集了所有的R包的交互式组件。这些组件可以让用户在R语言中创建交互式图表、地图、表格和其他可视化元素。这些组件可以通过HTML和JavaScript嵌入到网页中，使得用户可以在网页上与数据进行交互和探索