当前位置：首页 > news >正文

R语言｜分面中嵌入趋势线

news 来源：原创 2025/5/10 3:14:56

简介

关于分面的推文，小编根据实际科研需求，已经分享了很多技巧。例如：

分面中添加不同表格
分面中添加不同的直线
基于分面的面积图绘制
分面中的细节调整汇总
基于分面的折线图绘制

最近科研中又遇到了与分面相关的需求：在分面中添加拟合线。本期就针对该问题，绘制出以下图形：

图形含义：随着时间的推移，展示多个测试产品退化累积量的箱线图。这些产品涵盖了两种不同的退化性能（PC）。图中的红线表示通过提出的模型拟合得到的平均产品退化累积量，而两条粉色线表示相应的90%置信区间。

选择绘制箱线图的原因在于想要突显多个产品之间的异质性，并强调退化路径分布特征呈现出的厚尾现象。

注意：本文图形是小编在研究领域中常用的图形，通过这里进行总结，希望能给读者们一些启发。

教程

数据介绍

由于数据模拟产生比较复杂，且不是本文的重点。小编以某个测试数据集为例，数据和代码可在我的 Github 中找到。cal_data 为处理好的真实数据。PC 表示性能退化指标，共两个， Unit 表示希望展示的离散时间点，value 表示退化累积量。 data_fit 表示根据所提模型拟合得到的区间估计和点估计。该数据集为列表形式，包含三个数据框，分别为：Low，Mean，Up。

load("true_data.RData")
load("data_fit.RData")

cal_data

data_fit 拟合结果

数据处理

根据真实数据集的数据结构，我们将拟合结果也转化成类似结构。主要思路：

将列表合并为一个数据框 bind_rows()；
宽表转化为长表 pivot_longer()；
提取三种估计的结果。

最终每个结果的形式和真实数据集的数据结构一致（很重要）！

time2 = seq(3,m,3) #希望展示的数据点（离散）
  merged_df2 <- bind_rows(data_fit, .id = "Unit") #合并数据
  merged_df2$Unit = rep(c("Low","Mean","Up"),each = length(0:m))
  mer_dat = merged_df2 %>% pivot_longer(cols = !c(Time,Unit), names_to = "PC", values_to = "Value")
  # 数据筛选，用于画直线
  mer_dat1 = mer_dat[mer_dat$"Time" %in% time2 & mer_dat$"Unit" == "Low", 2:4]; colnames(mer_dat1) = c("Unit","PC","value")
  mer_dat2 = mer_dat[mer_dat$"Time" %in% time2 & mer_dat$"Unit" == "Mean", 2:4]; colnames(mer_dat2) = c("Unit","PC","value")
  mer_dat3 = mer_dat[mer_dat$"Time" %in% time2 & mer_dat$"Unit" == "Up", 2:4]; colnames(mer_dat3) = c("Unit","PC","value")

mer_dat1

分面画图

通过添加三个 geom_smooth() 实现分面中添加拟合线。运行以下代码即可得到：

ggplot() + 
    geom_boxplot(data = true_data, aes(factor(Unit,levels = time2),value,fill=factor(Unit,levels = time2))) +
    geom_smooth(data= mer_dat1, aes(factor(Unit,levels = time2),value,group=1),
                color="#EE81C3", method="loess", linetype = 2,se = FALSE) +
    geom_smooth(data= mer_dat2, aes(factor(Unit,levels = time2),value,group=1),
                color="#DC3F20", method="loess",linetype = 1,se = FALSE) +
    geom_smooth(data= mer_dat3, aes(factor(Unit,levels = time2),value,group=1),
                color="#EE81C3", method="loess",linetype = 2,se = FALSE) +
    facet_wrap(vars(PC),scale="free") +
    scale_fill_viridis(discrete = TRUE,alpha = 0.8) + 
    theme_bw() + theme(panel.grid = element_blank(),legend.position = "none") +
    xlab("Time") + ylab("Y(t)")

函数汇总

为了方便起见，小编将其转化为了一个函数供大家参考：

boxplot.path.fit = function(data_fit = data_fit, cal_data = cal_data, leg.pos = "none"){
  time2 = seq(3,m,3) #希望展示的数据点（离散）
  
  merged_df2 <- bind_rows(data_fit, .id = "Unit") #合并数据
  merged_df2$Unit = rep(c("Low","Mean","Up"),each = length(0:m))
  mer_dat = merged_df2 %>% pivot_longer(cols = !c(Time,Unit), names_to = "PC", values_to = "Value")
  # 数据筛选，用于画直线
  mer_dat1 = mer_dat[mer_dat$"Time" %in% time2 & mer_dat$"Unit" == "Low", 2:4]; colnames(mer_dat1) = c("Unit","PC","value")
  mer_dat2 = mer_dat[mer_dat$"Time" %in% time2 & mer_dat$"Unit" == "Mean", 2:4]; colnames(mer_dat2) = c("Unit","PC","value")
  mer_dat3 = mer_dat[mer_dat$"Time" %in% time2 & mer_dat$"Unit" == "Up", 2:4]; colnames(mer_dat3) = c("Unit","PC","value")
  
  p1 = ggplot() + 
    geom_boxplot(data = cal_data, aes(factor(Unit,levels = time2),value,fill=factor(Unit,levels = time2))) +
    geom_smooth(data= mer_dat1, aes(factor(Unit,levels = time2),value,group=1),
                color="#EE81C3", method="loess", linetype = 2,se = FALSE) +
    geom_smooth(data= mer_dat2, aes(factor(Unit,levels = time2),value,group=1),
                color="#DC3F20", method="loess",linetype = 1,se = FALSE) +
    geom_smooth(data= mer_dat3, aes(factor(Unit,levels = time2),value,group=1),
                color="#EE81C3", method="loess",linetype = 2,se = FALSE) +
    facet_wrap(vars(PC),scale="free") +
    scale_fill_viridis(discrete = TRUE,alpha = 0.8) + 
    theme_bw() + theme(panel.grid = element_blank(),legend.position = leg.pos) +
    xlab("Time") + ylab("Y(t)")
  
  return(p1)
}

boxplot.path.fit(data_fit = data_fit, cal_data = cal_data, leg.pos = "none")