数据可视化期末报告

Author

尹秋林

1 报告要求

期末实验报告由5章节5个图形组成，每个章节需要作一个图形。
每个章节选择作什么图自主选择，作图前补充完整图形标题名称，例如：图形1——多变量条形图。
案例数据自主收集，不同章节可以公用一个数据集。但同学间不允许使用相同数据集。
每个章节的数据集合需要通过datatable 函数展示，并简要解释数据来源和变量意义。
每个输出图形后需要对图形作简要解读，最少需针对图形提出一个观点。
渲染html文件保留代码展示，6月22日前将发布网址提交至共享文档“8、期末报告” 列中。
评分标准：
- 每章节图形各20分
- 能有效输出图形和合理解释75%
- 数据独特性强10%
- 图形个性化强15%

2 类别数据可视化

2.1 案例数据解释与展示

本例采用2020年人口婚姻状况数据进行类别可视化

library(tidyverse)
library(DT)
library(sjPlot)                      # 社会统计数据可视化
library(sf)                        
library(ggiraphExtra)
library(gridExtra)                   # 为使用图形组合函数grid.arrange
library(ggpubr)
library(RColorBrewer)
library(d3r)                           # 为了使用d3_nest函数
library(sunburstR)
data<-read.csv("人口普查婚姻状态2020.csv",fileEncoding ="GBK" ) 
options(DT.options = list(pageLength = 6))
data1 = as.data.frame(data)
DT::datatable(head(data1),rownames = FALSE)

2.2 图形1——多变量条形图

df <- data %>% select(性别,婚姻状况,人口数) %>% 
  summarise(n=sum(人口数),.by=c(性别,婚姻状况)) 

DT::datatable(df,rownames = FALSE)

p1<-ggplot(df,aes(x=性别,y=n,fill=婚姻状况))+
  geom_col(width=0.8,    # 设置条形宽度
  position="dodge",      # 绘制并列条形图
  color="gray50")+       # 设置条形图的边框颜色
  scale_fill_brewer(palette="Set2")+  # 设置填充颜色
  geom_text(aes(label=n),position=position_dodge(0.9),vjust=-0.5,size=3)+          # 设置标签垂直位置和字体大小
  ylim(0,1.1*max(df$n))+      # 设置y轴范围
  ggtitle("婚姻状况条形图")
p1

图形解读：由图可知，截止到2020年男性丧偶的人数低于女性，而未婚的男性远远多于女性。

3 数据分布可视化

3.1 案例数据解释与展示

geom_histogram(bins/binwidth) ，bin参数设定分箱（分组）数量，binwidth参数设定带宽（组距）。

library(gridExtra)
library(dplyr)
library(ggplot2)
data_grouped <- data %>% 
  mutate(
    年龄 = as.character(年龄),  # 确保字符型
    年龄_num = ifelse(年龄 == "65岁及以上", 65, as.numeric(年龄)),  # 转换为数值
    age_group = case_when(
      性别 == "男" & 年龄_num <= 22 ~ "男_15-22岁",
      性别 == "男" & 年龄_num > 22 ~ "男_22岁以上",
      性别 == "女" & 年龄_num <= 20 ~ "女_15-20岁",
      性别 == "女" & 年龄_num > 20 ~ "女_20岁以上"
    )
  )
summary_data <- data_grouped %>% 
  group_by(age_group, 婚姻状况) %>% 
  summarise(total_population = sum(人口数), .groups = "drop")
DT::datatable(summary_data,rownames = FALSE)

3.2 图形2——分布直方图

# 1. 婚姻状况分布直方图
p1 <- ggplot(summary_data, aes(x = 婚姻状况, y = total_population, fill = age_group)) +
  geom_bar(stat = "identity", position = "dodge") +
  geom_text(aes(label = scales::comma(total_population)), 
            position = position_dodge(width = 0.9), 
            vjust = -0.5, size = 3) +
  labs(title = "不同年龄分组的婚姻状况分布", x = "婚姻状况", y = "总人口数", fill = "年龄分组") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "right")

# 2. 按年龄和性别绘制原始年龄分布直方图
p2 <- ggplot(data_grouped, aes(x = 年龄_num, fill = 性别)) +
  geom_histogram(binwidth = 5, alpha = 0.7, position = "dodge") +
  labs(title = "不同性别的年龄分布直方图", x = "年龄", y = "频数", fill = "性别") +
  theme_minimal() +
  scale_x_continuous(breaks = seq(0, 100, by = 10))

# 3.按婚姻状况和年龄分组绘制分面直方图
p3 <- ggplot(data_grouped, aes(x = 年龄_num, fill = 性别)) +
  geom_histogram(binwidth = 5, alpha = 0.7, position = "dodge") +
  facet_wrap(~婚姻状况, ncol = 2) +
  labs(title = "不同婚姻状况的年龄分布（分性别）", x = "年龄", y = "频数") +
  theme_minimal() +
  scale_x_continuous(breaks = seq(0, 100, by = 10))


grid.arrange(p1,p2,p3,nrow=3)

图形解读：

图1：“有配偶” 是绝对主力，尤其「男_22岁以上」「女_20岁以上」占比极高，反映年长群体婚姻状态以已婚为主。“未婚” 在年轻分组（男_15-22、女_15-20 ）占比相对更高，符合“年轻群体未婚比例高”的社会常识。“离婚/丧偶” 占比极低，且各年龄分组差异小，说明这两种状态在样本中不普遍。

图2：不同性别的年龄分布直方图，在20-60岁区间，男女频数高度重叠、柱子高度相近，说明成年阶段男女人口分布相对均衡。10-20岁、60-70岁区间，男女频数有差异（如10-20岁男性稍多），反映低龄/高龄阶段可能存在性别分布差异。

图3：“未婚”：集中在20-40岁区间，且男女分布相近，说明未婚群体以中青年为主。“有配偶”：覆盖20-60岁宽区间，男女频数均较高，反映已婚群体年龄跨度大，且性别分布均衡。“离婚/丧偶”：各年龄区间频数低，且分布零散，进一步验证这两种婚姻状态在样本中占比极小。

4 变量关系可视化

4.1 案例数据解释与展示

# 加载所需包
library(ggplot2)
library(dplyr)
library(viridis)
library(scales)
# 数据预处理：转换年龄为数值型
data$年龄 <- as.numeric(as.character(data$年龄))
# 按年龄、婚姻状况和性别分组汇总人口数
grouped_data <- data %>%
  group_by(年龄, 婚姻状况, 性别) %>%
  summarise(总人口数 = sum(人口数)) %>%
  ungroup()
DT::datatable(grouped_data,rownames = FALSE)

4.2 图形3——分组散点图（按因子变量分面）

# 转换为因子并设置顺序
grouped_data$婚姻状况 <- factor(grouped_data$婚姻状况, levels = c("未婚", "有配偶", "离婚", "丧偶"))
grouped_data$性别 <- factor(grouped_data$性别, levels = c("男", "女"))
# 创建颜色 palette
marriage_colors <- viridis_pal(direction = 1)(4)
names(marriage_colors) <- levels(grouped_data$婚姻状况)
# 绘制分面散点图
ggplot(grouped_data, aes(x = 年龄, y = 总人口数, color = 性别, shape = 性别)) +
  # 添加散点
  geom_point(size = 3, alpha = 0.8) + # 添加趋势线
  geom_smooth(method = "loess", se = FALSE, size = 1) + # 按婚姻状况分面
  facet_wrap(~婚姻状况, ncol = 2, scales = "free_y") +# 设置颜色和形状
  scale_color_manual(values = c("男" = "#00A1FF", "女" = "#5ed935"), name = "性别") +
  scale_shape_manual(values = c("男" = 16, "女" = 17), name = "性别") +
  # 设置坐标轴和标题
  labs(
    x = "年龄",
    y = "总人口数",
    title = "不同婚姻状况下人口数随年龄的变化",
    subtitle = "2020年人口普查数据（按性别分组）",
    ) + # 优化坐标轴
  scale_x_continuous(breaks = seq(15, 70, by = 5),limits = c(15, 70)) +
  scale_y_continuous(label = comma,breaks = pretty_breaks(n = 5)) +
  # 设置主题
  theme_minimal() +
  theme(plot.title = element_text(size = 18,face = "bold",hjust = 0.5, margin = margin(b = 10)),plot.subtitle = element_text(size = 12,hjust = 0.5, margin = margin(b = 15)),
  plot.caption = element_text(size = 10, hjust = 0,margin = margin(t = 10)),axis.title = element_text(size = 14,face = "bold"),axis.text = element_text(size = 12,color = "gray20"),
    # 图例样式
legend.title = element_text( size = 12,face = "bold"),legend.text = element_text(size = 11),legend.position = "bottom",legend.background = element_rect(fill = alpha("white", 0.8),color = "gray80"),
    # 分面网格样式
panel.grid.minor = element_blank(),panel.grid.major.x = element_blank(),
panel.grid.major.y = element_line( color = "gray90",linetype = "dashed"),
panel.border = element_rect(color = "gray80",fill = NA,size = 0.5),
    # 分面标题样式
strip.text = element_text(size = 13,face = "bold",margin = margin(5, 10, 5, 10)  # 调整文字的内边距
    ),
strip.background = element_rect(fill = alpha(viridis(4), 0.2),#设置分面标题背景色
  color = NA  # 去掉背景边框，若需要边框可设置具体颜色
    )
  )

图形解读：

（1）图形一未婚年轻群体占比极高，20 - 30岁人口数达到峰值，随年龄增长快速下降；符合“多数人年轻时未婚，婚后转入‘有配偶’状态”的社会现实。

（2）图形二有配偶，中年段（30 - 60岁）人口数稳定且集中，是占比最高的群体；反映婚姻“黄金期”的人口分布，体现成家后长期稳定的婚姻状态。

（3）图形三离婚，集中在中老年段（40 - 60岁），形成明显峰值后回落；与婚姻生命周期契合（婚后多年可能因各种原因离婚），且高龄后再婚/状态变化导致人口数下降。

（4）图形四丧偶，高龄段（60岁以上）缓慢上升，年轻群体占比极低；符合“年龄越大，丧偶概率越高”的规律。

5 样本相似性可视化

5.1 案例数据解释与展示

采用dplyr::filter 函数选出年龄在25, 30, 35, 40, 45, 50, “65岁及以上”的七个组

ggiraphExtra::ggRadar 默认将全部数值变量都用于绘图
通过ylim参数可以控制图形外观；rescale 参数控制归一化
theme(axis.text.x=element_text(angle=myangle)) 控制标签旋转角度

# 加载必要的包

library(dplyr)
library(gridExtra)

# 筛选2020年数据，并聚焦关键年龄组（25-50岁及65岁以上）
data2 <- data1 %>%
  filter(调查年份 == 2020, 
         年龄 %in% c(25, 30, 35, 40, 45, 50, "65岁及以上"))

# 整理数据：按年龄和婚姻状态汇总人口数
df <- data2 %>%
  group_by(年龄, 婚姻状况) %>%
  summarise(人口数 = sum(人口数)) %>%
  ungroup() %>%
  pivot_wider(names_from = 婚姻状况, values_from = 人口数) %>%
  rename(
    "年龄" = 年龄,
    "未婚" = 未婚,
    "有配偶" = "有配偶",
    "离婚" = 离婚,
    "丧偶" = 丧偶
  )
DT::datatable(df,rownames = FALSE)

5.2 图形4——雷达图

# 设置图形主题
myangle <- seq(-20, -340, length.out = 4)  # 4个支出项目对应4个标签角度
mytheme <- theme_bw() +
  theme(
    legend.position = "bottom",  # 图例置于底部
    axis.text.x = element_text(
      size = 9, 
      color = "blue4", 
      angle = myangle,  # 标签角度垂直于坐标轴
      hjust = 1
    )
  )

# 图（a）：使用原始数据绘制雷达图
p1 <- ggRadar(
  data = df, 
  aes(group = 年龄),  # 按年龄分组
  rescale = FALSE,      # 不进行数据归一化
  ylim = c(-10000, 12000),  # 根据原始数据范围设置y轴
  alpha = 0,            # 透明度为0（仅显示线条）
  size = 2              # 线条粗细
) +
mytheme +
xlab("婚姻状态") +       # x轴标签
ylab("人口数") +         # y轴标签
ggtitle("各年龄组婚姻状态人口分布（原始数据）")  # 标题

# 图（b）：使用归一化数据绘制雷达图
p2 <- ggRadar(
  data = df, 
  aes(group = 年龄),  # 按年龄分组
  rescale = TRUE,       # 数据归一化到[0,1]
  ylim = c(-0.1, 1.1),  # 归一化后y轴范围
  alpha = 0.3,          # 透明度0.3（显示半透明区域）
  size = 2              # 线条粗细
) +
mytheme +
xlab("婚姻状态") +
ylab("归一化值") +
ggtitle("各年龄组婚姻状态人口分布（归一化后）")

# 组合两张图并显示
gridExtra::grid.arrange(p1, p2, ncol = 2)

图形解读：

已婚：各年龄组中，已婚占比（数值）最高，尤其是 65 岁及以上组（粉色点最远），反映已婚是各年龄段最普遍的状态；

未婚：仅在低龄组（25 岁、35 岁）有明显数值，高龄组（50+、65+）几乎无未婚，符合“年龄越大，未婚占比越低”的常识；

离婚/丧偶：整体数值低，仅 65 岁及以上组丧偶有一定占比（粉色点在“丧偶”轴有延伸）。

右侧：归一化数据雷达图（看“相对比例”）

已婚：各年龄组“已婚”归一化值都较高，但 25 岁组（红色）明显低于其他组 → 说明 25 岁已婚比例低（符合年轻人未婚/晚婚趋势），35+ 岁组已婚比例接近且普遍高；

未婚：仅 25 岁组（红色）在“未婚”轴有显著延伸 → 25 岁未婚比例远高于其他年龄组；

离婚：35 岁（绿色）、45 岁（蓝色）组在“离婚”轴有一定延伸 → 中年组离婚比例相对高；

丧偶：65 岁及以上组（粉色）在“丧偶”轴延伸最远 → 高龄组丧偶比例显著高于其他组。

价值：归一化后，消除了年龄组人口基数的影响，能直接对比“各婚姻状态的比例差异”：

低龄（25 岁）→ 未婚比例高；

中年（35-45 岁）→ 离婚比例相对高；

高龄（65+ 岁）→ 丧偶比例高。

6 时间序列可视化

6.1 案例数据解释与展示

采用上海机场股票历史数据，从2024-5-26至2025-6-26，为期一年数据进行分析
该数据中data为为日期变量，但该日期变量不规则（不连续），周末和公众假期没有交易数据
利用数据作K线图
通过zoo::rollmean 时间收盘价的5天、10天和20天的移动平均
将日期变量转化为id变量

library(dplyr)
library(gridExtra)
library(zoo)
library(DT)
library(ggplot2)
data3<-read.csv("上海机场股票交易.csv" ) 

data4 <- data3 %>% 
  mutate(日期 = as.Date(日期, format = "%Y-%m-%d")) %>% 
  arrange(日期) %>% 
  mutate(收盘_zoo = zoo::zoo(收盘, order.by = 日期)) %>% 
  mutate(
    ma5 = zoo::rollmean(收盘_zoo, k = 5, fill = NA, align = "right"),
    ma10 = zoo::rollmean(收盘_zoo, k = 10, fill = NA, align = "right"),
    ma20 = zoo::rollmean(收盘_zoo, k = 20, fill = NA, align = "right"),
    date_index = seq_along(日期)
  )
DT::datatable(data4, rownames = FALSE)

6.2 图形5——不规则时间序列图

p1 <- data4 |> ggplot(aes(x = date_index)) +
  geom_segment(aes(x = date_index, xend = date_index, y = 低, yend = 高)) +
  geom_rect(aes(xmin = date_index - 0.4, xmax = date_index + 0.4,
                ymin = pmin(开盘,收盘), ymax = pmax(开盘,收盘),
                fill = 收盘 > 开盘)) +
  geom_line(aes(y = ma5, color = "MA5"), size = 0.8) +
  geom_line(aes(y = ma10, color = "MA10"), size = 0.8) +
  geom_line(aes(y = ma20, color = "MA20"), size = 0.8) +
  scale_fill_manual(values = c("TRUE" = "red", "FALSE" = "green")) +
  scale_color_manual(values = c("MA5" = "blue", "MA10" = "orange", "MA20" = "purple")) +
  scale_x_continuous(breaks = seq(1, nrow(data4), by = 20), labels = format(data4$日期[seq(1, nrow(data4), by = 20)], "%Y-%m-%d")) +
  theme_minimal() + guides(fill="none")+
  theme(legend.position = "top",
        axis.title.x = element_blank(),
        axis.text.x = element_blank(),
        plot.margin = margin(b = 0)) +
  labs(x = "", y = "", title = "上海机场股票K线图", color = "移动平均线")

p2 <- data4 |> ggplot(aes(x = date_index, y = 交易量)) +
  geom_bar(stat = "identity", aes(fill = 收盘 > 开盘),width = 1) +
  scale_fill_manual(values = c("TRUE" = "red", "FALSE" = "green")) +
  scale_x_continuous(breaks = seq(1, nrow(data4), by = 20), labels = format(data4$日期[seq(1, nrow(data4), by = 20)], "%Y-%m-%d")) +
  theme_minimal() +
  theme(legend.position = "none",
        axis.text.x = element_text(angle = 45, hjust = 1),
        plot.margin = margin(t = 0)) +
  labs(x = "", y = "", title = "")
gridExtra::grid.arrange(p1,p2,ncol=1,
                        heights = c(2, 1))

图形解读：MA5（紫色）、MA10（橙色）、MA20（蓝色）：分别代表 5 日、10 日、20 日收盘价的平均值，反映股价短期、中期趋势。图中可见：均线整体呈下行趋势（尤其是后期三线黏合向下），说明股票中期走弱；某时段均线向上交叉（如图中尖峰处），曾短暂出现上涨信号，但未持续。下方：成交量集中在左侧时段（柱形更长），说明前期交易更活跃，后期交易量萎缩（柱形变短），市场关注度下降；股价尖峰（上涨）时，对应成交量显著放大（红色长柱），符合“价涨量增”的短期异动特征。

中期趋势：均线长期下行 + 后期交易量萎缩，反映股票中期走弱，缺乏持续上涨动力；

短期异动：图中尖峰（股价、成交量同步放大），可能是消息刺激或短期资金炒作，但未改变整体下行趋势；

交易信号：当前形态偏空（均线向下、量能不足），需关注均线是否拐头、成交量能否持续放大，判断趋势反转可能。