Could you help me adjust the code below. I made the code in shiny to generate graphics depending on the day and the chosen category. For the day 30/06 for both categories (FDE and ABC), it is generating the graph correctly, however for the day 01/07, it is repeating the same graphs of 30/06. So, I would like to adjust this, that is, adjust the code so that it generates the correct graphics for the 01/07. Every help is welcome.
Executable code below.
library(shiny)
library(shinythemes)
library(dplyr)
library(tidyverse)
library(lubridate)
library(stringr)
function.test<-function(dmda,CodeChosse = "FDE"){
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"),
Code = c("FDE","ABC","FDE","ABC"),
Week= c("Wednesday","Wednesday","Friday","Friday"),
DR1 = c(4,1,6,3),
DR01 = c(4,1,4,3), DR02= c(4,2,6,2),DR03= c(9,5,4,7),
DR04 = c(5,4,3,2),DR05 = c(5,4,5,4),
DR06 = c(2,4,3,2),DR07 = c(2,5,4,4),
DR08 = c(3,4,5,4),DR09 = c(2,3,4,4)),
class = "data.frame", row.names = c(NA, -4L))
dmda<-"2021-06-30"
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) %>%
dplyr::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)
mat1 <- df1 %>%
filter(date2 == dmda, Code == CodeChosse) %>%
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"))
SPV<-SPV %>%
filter(date2 == dmda, Code == CodeChosse) %>%
select(-any_of(dropnames))
datas<-SPV %>%
filter(date2 == ymd(dmda)) %>%
group_by(Code) %>%
dplyr::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")
datas <- datas %>%
group_by(Code) %>%
slice((as.Date(dmda) - min(as.Date(df1$date1) [
df1$Code == first(Code)])):max(Days) 1) %>%
ungroup
f1 <- function(dat, code_nm) {
dat <- subset(dat, Code == code_nm)
plot(Numbers ~ Days, xlim= c(0,45), ylim= c(0,30),
xaxs='i',data = dat,main = paste0(dmda, "-", code_nm))
if (var(dat$Numbers)>0){
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,max(0, round(coef,1)), cex=1.1,pos=4,offset =1,col="black")} else {
yz <- unique(dat$Numbers)
lines(c(0,dat$Days), c(yz, dat$Numbers), lwd = 2)
points(0, yz, col = "red", pch = 19, cex = 2, xpd = TRUE)
text(.1,yz .5, round(yz,1), cex=1.1,pos=4,offset =1,col="black")
}
}
Plot1<- f1(datas, CodeChosse)
return(list(
"Plot1" = Plot1,
date2 = df1$date2,
data = df1
))
}
ui <- fluidPage(
ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("",
sidebarLayout(
sidebarPanel(
uiOutput("date"),
textInput("Week", label = h4("Week"), value = ""),
uiOutput("mycode"),
br(),
),
mainPanel(
tabsetPanel(
tabPanel("", plotOutput("graph",width = "100%", height = "600")
)
),
))
)))
server <- function(input, output,session) {
data <- reactive(function.test("2021-06-01"))
output$date <- renderUI({
all_dates <- seq(as.Date('2021-01-01'), as.Date('2021-01-15'), by = "day")
disabled <- as.Date(setdiff(all_dates, as.Date(data()$date2)), origin = "1970-01-01")
dateInput(input = "date2",
label = h4("Data"),
min = min(data()$date2),
max = max(data()$date2),
value = min(data()$date2),
format = "dd-mm-yyyy",
datesdisabled = disabled)
})
output$mycode <- renderUI({
req(input$date2)
df1 <- data()$data
df2 <- df1[as.Date(df1$date2) %in% input$date2,]
selectInput("code", label = h4("Code"),choices=unique(df2$Code))
})
output$graph <- renderPlot({
req(input$date2,input$code)
function.test(input$date2,as.character(input$code))[["Plot1"]]
})
observeEvent(input$date2, {
updateTextInput(session, 'Week', value = weekdays(input$date2))
})
}
shinyApp(ui = ui, server = server)
CodePudding user response：
Your issue is due to the assignment dmda<-"2021-06-30" inside the function. Therefore, dmda will always be that date regardless of what you select in your dateInput. Next, you have not accounted for your initial call with the date "2021-06-01", and how to deal with dates not in df1$date2. It would be best if you streamline your function with appropriate outputs. I will leave that to you, as you do need your initial raw data from df1 to check the dates while defining choices for code. I have done some streamlining now. The following should resolve your issue.
library(shiny)
library(shinythemes)
library(dplyr)
library(tidyverse)
library(lubridate)
library(stringr)
dfa <- 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"),
Code = c("FDE","ABC","FDE","CBC"),
Week= c("Wednesday","Wednesday","Friday","Friday"),
DR1 = c(4,1,6,3),
DR01 = c(4,1,4,3), DR02= c(4,2,6,2),DR03= c(9,5,4,7),
DR04 = c(5,4,3,2),DR05 = c(5,4,5,4),
DR06 = c(2,4,3,2),DR07 = c(2,5,4,4),
DR08 = c(3,4,5,4),DR09 = c(2,3,4,4)),
class = "data.frame", row.names = c(NA, -4L))
function.test<-function(dt,dmda,CodeChosse){
df1 <- dt
# dmda<-"2021-06-30"
if (sum(df1$date2 %in% dmda)<1) dmda <- df1$date2[1] #####<------- note the change here
chk2 <- df1 %>% dplyr::filter(date2 == dmda)
if (sum(chk2$Code %in% CodeChosse) <1) CodeChosse <- chk2$Code[1]
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) %>%
dplyr::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)
mat1 <- df1 %>%
dplyr::filter(date2 == dmda, Code == CodeChosse) %>%
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"))
SPV<-SPV %>%
dplyr::filter(date2 == dmda, Code == CodeChosse) %>%
select(-any_of(dropnames))
datas<-SPV %>%
dplyr::filter(date2 == dmda) %>%
group_by(Code) %>%
dplyr::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")
datas <- datas %>%
group_by(Code) %>%
slice((as.Date(dmda) - min(as.Date(df1$date1) [df1$Code == first(Code)])):max(Days) 1) %>% ## this will be an issue if dmda < min(df1$date2)
ungroup
f1 <- function(dat, code_nm) {
#dat <- subset(dat, Code == code_nm)
plot(Numbers ~ Days, xlim= c(0,45), ylim= c(0,30),
xaxs='i',data = dat,main = paste0(dmda, "-", code_nm))
if (var(dat$Numbers)>0){
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,max(0, round(coef,1)), cex=1.1,pos=4,offset =1,col="black")} else {
yz <- unique(dat$Numbers)
lines(c(0,dat$Days), c(yz, dat$Numbers), lwd = 2)
points(0, yz, col = "red", pch = 19, cex = 2, xpd = TRUE)
text(.1,yz .5, round(yz,1), cex=1.1,pos=4,offset =1,col="black")
}
}
Plot1<- f1(datas, CodeChosse)
return(list(
"Plot1" = Plot1
))
}
ui <- fluidPage(
ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("",
sidebarLayout(
sidebarPanel(
uiOutput("date"),
textInput("Week", label = h4("Week"), value = ""),
uiOutput("mycode"),
br(),
),
mainPanel(
tabsetPanel(
tabPanel("", plotOutput("graph",width = "100%", height = "600")
)
),
))
)))
server <- function(input, output,session) {
#data <- reactive(function.test("2021-06-01"))
data <- reactive(dfa)
output$date <- renderUI({
all_dates <- seq(as.Date('2021-01-01'), as.Date('2021-01-15'), by = "day")
disabled <- as.Date(setdiff(all_dates, as.Date(data()$date2)), origin = "1970-01-01")
dateInput(input = "date2",
label = h4("Data"),
min = min(data()$date2),
max = max(data()$date2),
value = min(data()$date2),
format = "dd-mm-yyyy",
datesdisabled = disabled)
})
output$mycode <- renderUI({
req(input$date2)
df1 <- data()
df2 <- df1[as.Date(df1$date2) %in% input$date2,]
selectInput("code", label = h4("Code"),choices=unique(df2$Code))
})
output$graph <- renderPlot({
req(input$date2,input$code)
function.test(data(),as.character(input$date2),as.character(input$code))[["Plot1"]]
})
observeEvent(input$date2, {
updateTextInput(session, 'Week', value = weekdays(input$date2))
})
}
shinyApp(ui = ui, server = server)
