在R中为不同Code（ABC、CDE）分别生成带预测线的散点图

调整方案 #

你的代码问题出在统计汇总环节没有按Code分组，同时绘图逻辑没有做分组遍历，修改思路如下：

• 计算datas时新增按Code分组的逻辑，为每个Code生成独立的统计数据集
• 用分组遍历的方式为每个Code生成对应日期的独立图表，标题可同时标注日期和Code便于区分

修改后完整代码 #

library(dplyr)
library(tidyverse)
library(lubridate)

df1 <- structure(
  list(date1 = c("2021-06-28","2021-06-28","2021-06-28","2021-06-28"),
       date2 = c("2021-07-02","2021-07-02","2021-07-08","2021-07-08"),
       Code = c("ABC","CDE","ABC","CDE"),
       Week= c("Friday","Friday","Thursday","Thursday"),
       DR1 = c(11,17,14,12),
       DR01 = c(14,11,13,12), DR02= c(14,14,16,17),DR03= c(19,17,18,12),
       DR04 = c(11,14,13,13),DR05 = c(12,11,11,11),DR06 = c(14,13,12,11)),
  class = "data.frame", row.names = c(NA, -4L))

# 你可以根据需求修改要生成图表的目标日期
dmda<-"2021-07-02"

x<-df1 %>% select(starts_with("DR0"))
x<-cbind(df1, setNames(df1$DR1 - x, paste0(names(x), "_PV")))
PV<-select(x, date2,Week, Code, DR1, ends_with("PV"))

med<-PV %>%
  group_by(Code,Week) %>%
  summarize(across(ends_with("PV"), median), .groups = "drop")

SPV<-df1 %>%
  inner_join(med, by = c('Code', 'Week')) %>%
  mutate(across(matches("^DR0\\d+$"), ~.x + 
                  get(paste0(cur_column(), '_PV')),
                .names = '{col}_{col}_PV')) %>%
  select(date1:Code, DR01_DR01_PV:last_col())

SPV<-data.frame(SPV)

# 此处新增按Code分组逻辑，生成每个Code对应的数据
datas<-SPV %>%
  filter(date2 == ymd(dmda)) %>%
  group_by(Code) %>%
  summarize(across(starts_with("DR0"), sum), .groups = "drop") %>%
  pivot_longer(-Code, names_pattern = "DR0(.+)", values_to = "val") %>%
  mutate(name = readr::parse_number(name))
colnames(datas)<-c("Code","Days","Numbers")

# 分组遍历每个Code生成独立图表
datas %>%
  group_by(Code) %>%
  group_walk(~{
    # 生成图表，标题同时标注日期和对应Code
    plot(Numbers ~ Days,  xlim= c(0,7), ylim= c(0,30), xaxs='i',
         data = .x, main = paste0(dmda, "-Code:", .y$Code))
    
    model <- nls(Numbers ~ b1*Days^2+b2,start = list(b1 = 0,b2 = 0),
                 data = .x, algorithm = "port")
    
    new.data <- data.frame(Days = with(.x, seq(min(Days),max(Days),len = 45)))
    new.data <- rbind(0, new.data)
    lines(new.data$Days,predict(model,newdata = new.data),lwd=2)
    coef_val<-coef(model)[2]
    points(0, coef_val, col="red",pch=19,cex = 2,xpd=TRUE)
    text(.99,coef_val + 1,round(coef_val,1), cex=1.1,pos=4,offset =1,col="black")
  })

效果说明 #

运行后会自动生成两张独立图表，分别对应Code=ABC和Code=CDE的结果，你提供的ABC对应原图如下：

如果需要同时为所有date2生成对应的图表，只需去掉filter(date2 == ymd(dmda))的筛选条件，在分组时增加date2分组即可。

内容的提问来源于stack exchange，提问作者user16774617