You can add
if(length(dropnames) == 9) return(NA)
after the line that creates dropnames.
See below for the full code with that modification. I also changed the code of the function, so that you can feed it a data object, instead of hard-coding df1 into it.
library(dplyr)
library(lubridate)
library(tidyr)
df1 <- structure(
list(
date1 = c("2021-06-28", "2021-06-28", "2021-06-28", "2021-06-28"),
date2 = c("2021-06-30", "2021-06-30", "2021-07-01", "2021-07-01"),
Category = c("FDE", "ABC", "FDE", "ABC"),
Week = c("Wednesday", "Wednesday", "Friday", "Friday"),
DR1 = c(4, 1, 6, 1),
DR01 = c(4, 1, 4, 3),
DR02 = c(4, 2, 6, 0),
DR03 = c(9, 5, 4, 0),
DR04 = c(5, 4, 3, 3),
DR05 = c(5, 4, 5, 0),
DR06 = c(2, 4, 3, 3),
DR07 = c(2, 5, 4, 0),
DR08 = c(3, 4, 5, 0),
DR09 = c(2, 3, 4, 0)
),
class = "data.frame",
row.names = c(NA, -4L)
)
df2 <- structure(
list(
date1 = c("2021-06-28", "2021-06-28", "2021-06-28", "2021-06-28"),
date2 = c("2021-06-30", "2021-06-30", "2021-07-01", "2021-07-01"),
Category = c("FDE", "ABC", "FDE", "ABC"),
Week = c("Wednesday", "Wednesday", "Friday", "Friday"),
DR1 = c(4, 1, 6, 0),
DR01 = c(4, 1, 4, 0),
DR02 = c(4, 2, 6, 0),
DR03 = c(9, 5, 4, 0),
DR04 = c(5, 4, 3, 0),
DR05 = c(5, 4, 5, 0),
DR06 = c(2, 4, 3, 0),
DR07 = c(2, 5, 4, 0),
DR08 = c(3, 4, 5, 0),
DR09 = c(2, 3, 4, 0)
),
class = "data.frame",
row.names = c(NA, -4L)
)
return_coef <- function(dmda, CategoryChosse, data) {
x <- data %>% select(starts_with("DR0"))
x <- cbind(data, setNames(data$DR1 - x, paste0(names(x), "_PV")))
PV <- select(x, date2, Week, Category, DR1, ends_with("PV"))
med <- PV %>%
group_by(Category, Week) %>%
summarize(across(ends_with("PV"), median), .groups = "drop")
SPV <- data %>%
inner_join(med, by = c('Category', 'Week')) %>%
mutate(across(matches("^DR0\\d+$"), ~ .x +
get(paste0(
cur_column(), '_PV'
)),
.names = '{col}_{col}_PV')) %>%
select(date1:Category, DR01_DR01_PV:last_col())
SPV <- data.frame(SPV)
mat1 <- data %>%
filter(date2 == dmda, Category == CategoryChosse) %>%
select(starts_with("DR0")) %>%
pivot_longer(cols = everything()) %>%
arrange(desc(row_number())) %>%
mutate(cs = cumsum(value)) %>%
filter(cs == 0) %>%
pull(name)
(dropnames <- paste0(mat1, "_", mat1, "_PV"))
if(length(dropnames) == 9) return(NA)
SPV <- SPV %>%
filter(date2 == dmda, Category == CategoryChosse) %>%
select(-any_of(dropnames))
datas <- SPV %>%
filter(date2 == ymd(dmda)) %>%
group_by(Category) %>%
summarize(across(starts_with("DR0"), sum)) %>%
pivot_longer(
cols = -Category,
names_pattern = "DR0(.+)",
values_to = "val"
) %>%
mutate(name = readr::parse_number(name))
colnames(datas)[-1] <- c("Days", "Numbers")
datas <- datas %>%
group_by(Category) %>%
slice((as.Date(dmda) - min(as.Date(data$date1) [data$Category == first(Category)])):max(Days) +
1) %>%
ungroup()
mod <-
nls(
Numbers ~ b1 * Days ^ 2 + b2,
start = list(b1 = 0, b2 = 0),
data = datas,
algorithm = "port"
)
as.numeric(coef(mod)[2])
}
cbind(df1[2:3], coef = mapply(\(x, y) return_coef(x, y, data = df1), df1$date2, df1$Category))
#> date2 Category coef
#> 1 2021-06-30 FDE 4
#> 2 2021-06-30 ABC 1
#> 3 2021-07-01 FDE 6
#> 4 2021-07-01 ABC 1
cbind(df2[2:3], coef = mapply(\(x, y) return_coef(x, y, data = df2), df2$date2, df2$Category))
#> date2 Category coef
#> 1 2021-06-30 FDE 4
#> 2 2021-06-30 ABC 1
#> 3 2021-07-01 FDE 6
#> 4 2021-07-01 ABC NA
return_coef(
dmda = df2$date2[4],
CategoryChosse = df2$Category[4],
data = df2
)
#> [1] NA