Generate graphics for different categories in R-CodePudding

The code below generates a graph with dots and a "prediction" line, so to speak. However, as you can see for each date there are two Codes: ABC and CDE. So, there will be two different graphics for the same day. But I don't know how to do this. This graph that I generated, I believe it is for ABC. Could you help me make graphics for both 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))

> df1
       date1      date2 Code     Week DR1 DR01 DR02 DR03 DR04 DR05 DR06
1 2021-06-28 2021-07-02  ABC   Friday  11   14   14   19   11   12   14
2 2021-06-28 2021-07-02  CDE   Friday  17   11   14   17   14   11   13
3 2021-06-28 2021-07-08  ABC Thursday  14   13   16   18   13   11   12
4 2021-06-28 2021-07-08  CDE Thursday  12   12   17   12   13   11   11

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

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)

datas<-SPV %>%
  filter(date2 == ymd(dmda)) %>%
  summarize(across(starts_with("DR0"), sum)) %>%
  pivot_longer(everything(), names_pattern = "DR0(. )", values_to = "val") %>%
  mutate(name = readr::parse_number(name))
colnames(datas)<-c("Days","Numbers")


plot(Numbers ~ Days,  xlim= c(0,7), ylim= c(0,30), xaxs='i',data = datas,main = dmda)

model <- nls(Numbers ~ b1*Days^2 b2,start = list(b1 = 0,b2 = 0),data = datas, algorithm = "port")

new.data <- data.frame(Days = with(datas, 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<-coef(model)[2]
points(0, coef, col="red",pch=19,cex = 2,xpd=TRUE)
text(.99,coef   1,round(coef,1), cex=1.1,pos=4,offset =1,col="black")

CodePudding user response：

In the last step, we need to group by 'Code' and summarise before doing the pivot_longer. Thus, we have a 'Code' column

library(dplyr)
library(tidyr)
datas <- SPV %>%
  filter(date2 == ymd(dmda)) %>% 
  group_by(Code) %>%
  summarize(across(starts_with("DR0"), sum)) %>%
  pivot_longer(cols = -Code, names_pattern = "DR0(. )", 
         values_to = "val") %>% 
  mutate(name = readr::parse_number(name))
colnames(datas)[-1] <-c("Days","Numbers")

-output

> datas
# A tibble: 12 × 3
   Code   Days Numbers
   <chr> <dbl>   <dbl>
 1 ABC       1      11
 2 ABC       2      11
 3 ABC       3      11
 4 ABC       4      11
 5 ABC       5      11
 6 ABC       6      11
 7 CDE       1      17
 8 CDE       2      17
 9 CDE       3      17
10 CDE       4      17
11 CDE       5      17
12 CDE       6      17

Inorder to do the plotting by 'Code', split or either loop over the unique values of 'Code', extract the subset of data and plot

lstdatas <- split(datas, datas$Code)
par(mfrow = c(2, 1))
lapply(names(lstdatas), function(nm) {
   dat <- lstdatas[[nm]]
   plot(Numbers ~ Days,  xlim= c(0,7), ylim= c(0,30),
       xaxs='i',data = dat,main = paste0(dmda, "-", nm))

  model <- nls(Numbers ~ b1*Days^2 b2,start = list(b1 = 0,b2 = 0),data = dat, algorithm = "port")

  new.data <- data.frame(Days = with(dat, 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<-coef(model)[2]
   points(0, coef, col="red",pch=19,cex = 2,xpd=TRUE)
   text(.99,coef   1,round(coef,1), cex=1.1,pos=4,offset =1,col="black")
   })

-output

If we want this as a function

f1 <- function(dat, code_nm) {
    dat <- subset(dat,  Code == code_nm)
    plot(Numbers ~ Days,  xlim= c(0,7), ylim= c(0,30),
       xaxs='i',data = dat,main = paste0(dmda, "-", code_nm))

  model <- nls(Numbers ~ b1*Days^2 b2,start = list(b1 = 0,b2 = 0),data = dat, algorithm = "port")

  new.data <- data.frame(Days = with(dat, 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<-coef(model)[2]
   points(0, coef, col="red",pch=19,cex = 2,xpd=TRUE)
   text(.99,coef   1,round(coef,1), cex=1.1,pos=4,offset =1,col="black")
}

Then call the function as

f1(datas, "ABC")
f1(datas, "CDE")