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

2023-12-16 17:55:46

简介

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

  1. 分面中添加不同表格

  2. 分面中添加不同的直线

  3. 基于分面的面积图绘制

  4. 分面中的细节调整汇总

  5. 基于分面的折线图绘制

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

图形含义:随着时间的推移,展示多个测试产品退化累积量的箱线图。这些产品涵盖了两种不同的退化性能(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 拟合结果

数据处理

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

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

最终每个结果的形式和真实数据集的数据结构一致(很重要)!

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")

文章来源:https://blog.csdn.net/qq_37379316/article/details/135033999
本文来自互联网用户投稿,该文观点仅代表作者本人,不代表本站立场。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。