数据可视化期末报告

1 报告要求

• 期末实验报告由5章节5个图形组成，每个章节需要作一个图形。

• 每个章节选择作什么图自主选择，作图前补充完整图形标题名称，例如：图形1——多变量条形图。

• 案例数据自主收集，不同章节可以公用一个数据集。但同学间不允许使用相同数据集。

• 每个章节的数据集合需要通过datatable 函数展示，并简要解释数据来源和变量意义。

• 每个输出图形后需要对图形作简要解读，最少需针对图形提出一个观点。

• 渲染html文件保留代码展示，6月22日前将发布网址提交至共享文档“8、期末报告” 列中。

• 评分标准：

  • 每章节图形各20分

  • 能有效输出图形和合理解释75%

  • 数据独特性强10%

  • 图形个性化强15%

2 类别数据可视化

2.1 案例数据解释与展示

library(DT)
library(readxl)

# 读取数据
上海美食商铺 <- read_excel("数据集/上海美食商铺.xlsx")

# 使用datatable展示数据
datatable(
  上海美食商铺,
  caption = htmltools::tags$caption(
    style = 'caption-side: top; text-align: center; color: black; font-size: 16px;',
    '表1：上海美食商铺详细数据（共41家商铺）'
  ),
  options = list(
    scrollX = TRUE,
    pageLength = 10,
    lengthMenu = c(5, 10, 20, 50),
    autoWidth = TRUE,
    columnDefs = list(
      list(width = '100px', targets = c(0, 2)),
      list(width = '150px', targets = 1),
      list(className = 'dt-center', targets = '_all')
    ),
    initComplete = JS(
      "function(settings, json) {",
      "$(this.api().table().header()).css({'background-color': '#f8f9fa', 'color': '#212529'});",
      "}"
    )
  ),
  rownames = FALSE,
  filter = 'top'
) %>%
  formatRound(columns = c('lon', 'lat'), digits = 7) %>%
  formatRound(columns = c('口味', '环境', '服务'), digits = 1) %>%
  formatCurrency(columns = '人均消费', currency = '¥', digits = 0)

#来源：上海本地餐饮平台采集的商铺数据
#关键变量：
#类别：菜系分类（浙菜/粤菜等）
#口味/环境/服务：十分制评分
#人均消费：人民币价格
#经纬度：商铺地理位置（已隐藏）

2.2 图形1——点阵图（气泡图）

library(ggpubr)
library(RColorBrewer)
library(tibble)  # 新增加载tibble包
library(dplyr)

# 数据准备（修正版）
mat <- 上海美食商铺 %>%
  group_by(类别) %>%
  summarise(
    人均消费 = median(人均消费),
    口味 = mean(口味, na.rm = TRUE),
    环境 = mean(环境, na.rm = TRUE),
    服务 = mean(服务, na.rm = TRUE)
  ) %>%
  as.data.frame() %>%        # 先转换为data.frame
  column_to_rownames("类别") %>%  # 然后转换行名
  as.matrix()

# 设置调色板
palette <- rev(brewer.pal(11, "Spectral"))

# 版本1：圆形气泡图
p1 <- ggballoonplot(
  t(mat),
  size = "value",
  fill = "value",
  shape = 21,
  rotate.x.text = TRUE,
  ggtheme = theme_minimal(),
  fill.gradient = scale_fill_gradientn(colors = palette)
) +
  ggtitle("上海各菜系综合评分（圆形）") +
  theme(plot.title = element_text(size = 12, face = "bold"))

# 版本2：菱形气泡图
p2 <- ggballoonplot(
  t(mat),
  size = "value",
  fill = "value",
  shape = 23,
  rotate.x.text = TRUE,
  ggtheme = theme_minimal(),
  fill.gradient = scale_fill_gradientn(colors = palette)
) +
  ggtitle("上海各菜系综合评分（菱形）") +
  theme(plot.title = element_text(size = 12, face = "bold"))

# 组合输出
ggarrange(p1, p2, 
          ncol = 2, 
          common.legend = TRUE,
          legend = "bottom")

• 图形解读：

• 1核心发现

  • 高价高质组合
    西餐（南通）和本帮菜（北洋）在右上角呈现大红大圆形态，显示其同时具备：

    • 高人均消费（100-150元）

    • 高环境/口味评分（8+分）

    • 服务分相对突出（7.5+分）

  • 性价比之选
    浙菜（浙东）和湘菜（长沙）表现为中等大小橙色气泡，特征：

    • 人均60-80元

    • 口味分7.2-7.5分

    • 环境服务均衡（7分左右）

  2.2.0.1 2. 异常模式

  • 数据矛盾点

    • 赣州菜系显示高消费（深红）但低评分（小气泡），可能原因：
      ✓ 新开业商铺评分积累不足
      ✓ 定位高端但品质未达预期

    • 南京菜系服务分（7.8）显著高于环境分（7.0），反映其服务优先策略

  • 零值警告
    苏丹菜系气泡极小且颜色浅蓝，提示：

    • 样本量过少（可能仅1-2家）

    • 数据可靠性存疑

  2.2.0.2 3. 商业启示

  • 高端市场：西餐/本帮菜可继续强化环境溢价

  • 中端市场：浙菜/湘菜需提升服务分以突破瓶颈

  • 风险警示：赣州菜系需尽快改善品质匹配其定价

3 数据分布可视化

3.1 案例数据解释与展示

# 使用datatable展示数据
datatable(
  上海美食商铺,
  caption = htmltools::tags$caption(
    style = 'caption-side: top; text-align: center; color: black; font-size: 16px;',
    '表1：上海美食商铺详细数据（共41家商铺）'
  ),
  options = list(
    scrollX = TRUE,
    pageLength = 10,
    lengthMenu = c(5, 10, 20, 50),
    autoWidth = TRUE,
    columnDefs = list(
      list(width = '100px', targets = c(0, 2)),
      list(width = '150px', targets = 1),
      list(className = 'dt-center', targets = '_all')
    ),
    initComplete = JS(
      "function(settings, json) {",
      "$(this.api().table().header()).css({'background-color': '#f8f9fa', 'color': '#212529'});",
      "}"
    )
  ),
  rownames = FALSE,
  filter = 'top'
) %>%
  formatRound(columns = c('lon', 'lat'), digits = 7) %>%
  formatRound(columns = c('口味', '环境', '服务'), digits = 1) %>%
  formatCurrency(columns = '人均消费', currency = '¥', digits = 0)

#来源：上海本地餐饮平台采集的商铺数据
#关键变量：
#类别：菜系分类（浙菜/粤菜等）
#口味/环境/服务：十分制评分
#人均消费：人民币价格
#经纬度：商铺地理位置（已隐藏）

3.2 图形2——小提琴图

library(ggplot2)
library(ggpubr)
library(ggsignif)

# 数据准备
main_cuisines <- c("浙菜", "粤菜", "西餐", "烧烤", "火锅", "海鲜")
plot_data <- 上海美食商铺[上海美食商铺$类别 %in% main_cuisines, ]

# 设置比较组（选取有商业分析价值的对比）
compared <- list(c("西餐", "浙菜"), 
                 c("西餐", "粤菜"),
                 c("火锅", "海鲜"),
                 c("烧烤", "海鲜"))

# 创建图形
p <- ggplot(plot_data, aes(x=类别, y=口味, fill=类别)) +
  # 几何对象
  geom_violin(alpha=0.7, trim=FALSE, width=0.8) +
  geom_boxplot(width=0.15, outlier.shape=21, outlier.size=2, 
               outlier.fill="white", show.legend=FALSE) +
  # 统计检验
  stat_compare_means(
    comparisons = compared,
    method = "wilcox.test",
    label = "p.signif",
    tip.length = 0.01,
    size = 4,
    vjust = 0.5
  ) +
  stat_compare_means(
    method = "kruskal.test", 
    label.y = 9.5,
    label.x = 1.5
  ) +
  # 视觉美化
  scale_fill_manual(values = c("#4E79A7", "#F28E2B", "#E15759", "#76B7B2", "#59A14F", "#EDC948")) +
  labs(
    title = "上海主要菜系口味评分对比分析",
    subtitle = "箱线图展示中位数与离群值，小提琴图显示概率密度分布",
    x = NULL,
    y = "口味评分（10分制）",
    caption = paste0("数据来源：上海餐饮平台 | ",
                    "显著性检验：Kruskal-Wallis检验+Wilcoxon秩和检验\n",
                    "* p<0.05, ** p<0.01, *** p<0.001")
  ) +
  # 主题定制
  theme_minimal(base_size = 12) +
  theme(
    legend.position = "none",
    axis.text.x = element_text(angle = 30, hjust = 1, face = "bold"),
    plot.title = element_text(size = 16, face = "bold", hjust = 0.5),
    plot.subtitle = element_text(size = 10, hjust = 0.5, color = "gray40"),
    panel.grid.major.x = element_blank(),
    plot.caption = element_text(size = 8, color = "gray50", hjust = 0)
  ) +
  # 均值标记
  stat_summary(
    fun = mean, 
    geom = "point", 
    shape = 23, 
    size = 3, 
    fill = "white",
    color = "red"
  ) +
  # 参考线
  geom_hline(yintercept = mean(plot_data$口味), 
             linetype = "dashed", 
             color = "gray50", 
             alpha = 0.5)

print(p) 

• 图形解读：

  3.2.0.1 整体趋势

  • Kruskal-Wallis检验p值=0.12（>0.05），说明六大菜系口味评分无统计学显著差异

  • 但西餐中位数最高（约7.8分），浙菜最低（约7.1分），存在商业意义差异

• 关键发现

  • 西餐优势：评分分布集中（箱体窄），75%店铺集中在7.5-8.5分，品质稳定

  • 浙菜问题：存在低分离群点（约6分），且评分方差最大（小提琴体最宽）

  • 火锅潜力：虽中位数与海鲜相当，但存在8.5分以上的高端店铺（上边缘离群点）

• 商业建议

  • 西餐可维持现有定位，浙菜需排查低分店铺（特别是6分以下异常值）

  • 火锅可借鉴高端店铺（8.5+分）的成功经验进行推广

  • 需扩大样本量（当前p值接近临界值），特别是烧烤类数据较少

4 变量关系可视化

4.1 案例数据解释与展示

# 创建数据集：汽车性能数据
data(mtcars)

# 显示数据
datatable(mtcars, 
          caption = "表3：mtcars数据集(汽车性能数据)",
          options = list(pageLength = 5))

# 数据来源：R内置数据集
# 变量说明：
# - mpg: 每加仑英里数(燃油效率)
# - hp: 马力
# - wt: 重量(千磅)
# - 其他变量省略说明

4.2 图形3——气泡图

library(ggplot2)
library(RColorBrewer)
library(dplyr)  # 确保加载dplyr包
library(ggrepel)

# 创建标记数据（提前处理）
label_data <- mtcars %>% 
  filter(hp > 250 | mpg > 30) %>%
  mutate(car_name = rownames(.))

# 精简版气泡图
ggplot(mtcars, aes(x = wt, y = mpg, size = hp, color = factor(cyl))) +
  geom_point(alpha = 0.7) +
  scale_size(
    range = c(3, 10),
    breaks = c(100, 200, 300),
    name = "马力"
  ) +
  scale_color_brewer(
    palette = "Dark2",
    labels = c("4缸", "6缸", "8缸"),
    name = "发动机"
  ) +
  labs(
    title = "汽车重量与燃油效率关系（按动力系统分组）",
    subtitle = "气泡大小代表马力值，颜色区分汽缸数量",
    x = "重量（千磅）", 
    y = "燃油效率（英里/加仑）",
    caption = "数据来源：R内置mtcars数据集"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(size = 13, face = "bold", hjust = 0.5),
    plot.subtitle = element_text(size = 10, hjust = 0.5, color = "gray40"),
    legend.position = "bottom",
    legend.box = "horizontal",
    legend.text = element_text(size = 9),
    panel.grid.minor = element_blank(),
    plot.margin = unit(c(5,10,5,5), "pt")
  ) +
  # 修正后的标签标注
  ggrepel::geom_text_repel(
    data = label_data,
    aes(label = car_name),  # 使用提前创建的列名
    size = 3,
    box.padding = 0.5,
    segment.color = "gray70"
  ) +
  geom_hline(yintercept = mean(mtcars$mpg), linetype = "dashed", alpha = 0.3) +
  geom_vline(xintercept = mean(mtcars$wt), linetype = "dashed", alpha = 0.3)

• 图形解读：
• 重量惩罚效应
  图形清晰呈现”越重越费油”的基本规律，最重车型（8缸）比最轻车型（4缸）燃油效率低2倍以上
• 技术突围亮点

  • Lotus Europa以跑车身份实现30mpg，展示轻量化设计的潜力

  • 6缸车分布带较宽（15-25mpg），说明同规格下存在优化空间

• 市场细分启示
  4缸=经济型，6缸=均衡型，8缸=性能型，三组几乎无重叠，反映厂商精准定位策略

5 样本相似性可视化

5.1 案例数据解释与展示

library(DT)
datatable(esoph,
          caption = "表1：食管癌病例对照研究数据 (R内置esoph数据集)",
          options = list(
            pageLength = 5,
            dom = 'tip',
            language = list(
              search = "搜索:",
              info = "显示 _START_ 至 _END_ 条，共 _TOTAL_ 条"
            )
          )) %>%
  formatPercentage("ncases", 1) %>%
  formatPercentage("ncontrols", 1)

#数据说明：
#来源：法国食管癌病例对照研究
#变量：agegp：年龄分组（6组）
#alcgp：酒精消费量分组（4组）
#tobgp：烟草消费量分组（4组）
#ncases：病例数
#ncontrols：对照组人数

5.2 图形4——热图

library(pheatmap)

# 1. 正确计算风险比矩阵
risk_matrix <- with(esoph, {
  tapply(ncases/(ncases + ncontrols), 
         list(paste(agegp, alcgp), tobgp),
         mean)
})

# 2. 处理可能的NA值（用0替换）
risk_matrix[is.na(risk_matrix)] <- 0

# 3. 绘制热图
pheatmap(risk_matrix,
         main = "食管癌风险因素交互作用热图\n（年龄×酒精消费 vs 烟草消费）",
         color = colorRampPalette(c("#4575B4", "white", "#D73027"))(100),
         cluster_rows = TRUE,
         cluster_cols = TRUE,
         clustering_method = "ward.D2",
         border_color = "gray60",
         cellwidth = 25, 
         cellheight = 15,
         angle_col = 45,
         display_numbers = TRUE,
         number_format = "%.2f",
         fontsize_row = 8,
         fontsize_col = 9)

• 图形解读：
• 最高危人群

  • 55-74岁重度饮酒者（120+g/d）风险比达0.83-1.00

  • 每增加20g烟草消费，风险平均升高15-20%

• 关键保护因素

  • 45岁以下+每日酒精<40g者风险趋近于0

  • 烟草零消费可降低50%以上风险

• 异常警示

  • 35-44岁重度烟酒者风险异常高（0.67）

  • 75岁以上数据可能低估真实风险

6 时间序列可视化

6.1 案例数据解释与展示

library(DT)
library(readr)
全球实际利率数据_FRED_ <- read_csv("数据集/全球实际利率数据（FRED）.csv")
datatable(全球实际利率数据_FRED_,
          caption = "表1：全球实际利率数据 (2000.01-2025.06)",
          options = list(
            pageLength = 10,  # 每页显示10行
            lengthMenu = c(10, 25, 50)  # 自定义每页显示选项
          )) %>%
  formatRound("REAINTRATREARAT10Y", digits = 2)  # 利率保留2位小数

#数据来源：fred数据网站

6.2 图形5——折线图

library(ggplot2)
library(lubridate)
library(tidyr)

# 转换日期格式
全球实际利率数据_FRED_$observation_date <- as.Date(全球实际利率数据_FRED_$observation_date)

# 准备数据
df_long <- 全球实际利率数据_FRED_ %>%
  select(日期 = observation_date, 实际利率 = REAINTRATREARAT10Y)

# 自定义主题（修正legend.position警告）
mytheme <- theme(
  legend.position.inside = c(0.15, 0.85),  # 使用新参数替代被弃用的写法
  legend.background = element_blank(),
  panel.grid.minor = element_blank(),
  plot.title = element_text(face = "bold")
)

# 绘制折线图（使用geom_rect替代geom_tshighlight）
ggplot(df_long, aes(x = 日期, y = 实际利率)) +
  # 高亮区域（替代geom_tshighlight）
  annotate("rect", 
           xmin = as.Date("2008-09-01"),
           xmax = as.Date("2009-06-01"),
           ymin = -Inf, ymax = Inf,
           fill = "lightpink", alpha = 0.2) +
  annotate("rect",
           xmin = as.Date("2020-03-01"),
           xmax = as.Date("2021-03-01"),
           ymin = -Inf, ymax = Inf,
           fill = "lightblue", alpha = 0.2) +
  # 主趋势线
  geom_line(color = "#1F77B4", linewidth = 0.8) +
  # 关键事件标记
  geom_vline(xintercept = as.Date(c("2001-09-01", "2008-09-15", "2020-03-01")),
             linetype = "dashed", color = "red", alpha = 0.5) +
  # 零利率线
  geom_hline(yintercept = 0, linetype = "dashed", color = "black") +
  # 标签和坐标轴
  labs(
    title = "全球10年期实际利率趋势 (2000-2025)",
    subtitle = "粉色区域：2008金融危机时期 | 蓝色区域：COVID-19疫情时期",
    x = "年份",
    y = "实际利率 (%)",
    caption = "数据来源：FRED经济数据库"
  ) +
  scale_x_date(
    date_breaks = "2 years",
    date_labels = "%Y",
    expand = c(0, 0)
  ) +
  scale_y_continuous(breaks = seq(-2, 4, by = 1)) +
  mytheme

• 图形解读：

1. 危机响应模式

   • 2008金融危机（粉色区域）：利率从1.2%急速降至0.5%，反映”零利率政策”的快速启动

   • 2020疫情（蓝色区域）：首次突破零下限至-0.4%，显示非常规货币政策力度

2. 长期结构性变化

   • 前十年（2000-2010）：利率中枢从3.5%降至0%，标志全球化红利期结束

   • 低利率时代（2010-2020）：长期在0%附近波动，与”长期停滞”理论吻合

   • 新周期（2022-）：陡峭加息至2%，打破二十年下行趋势

3. 关键转折点

   • 2012年：欧债危机导致短暂负利率（-0.17%）

   • 2022Q2：俄乌冲突后创2008年来最大单季涨幅（+1.2%）

   • 2023年：利率在1.5-2%区间持续震荡

4. 当前启示

   • 2%利率平台可能成为新常态

   • 央行政策框架从”刺激增长”转向”抗通胀优先”

   • 负利率工具或成历史性政策实验