The shiny code below generates graphs for 29/06, 30/06 and 01/07 since I have values in my DR columns. However, for 02/07 and 03/07, no, because all columns of DR are 0. When I try to generate a graph for these two days in Shiny, I get the following error Warning: Error in : cols must select at least one column. So, I would like that whenever this happens, a warning message appears, saying that there is no data for this selected day. If possible, it might not show this error message, but only this warning message.
Executable code below
library(shiny)
library(shinythemes)
library(dplyr)
library(tidyverse)
library(lubridate)
library(stringr)
function.test<-function(){
df1 <- structure(
list(date1= c("2021-06-28","2021-06-28","2021-06-28","2021-06-28","2021-06-28","2021-06-28","2021-06-28","2021-06-28"),
date2 = c("2021-06-29","2021-06-29","2021-06-30","2021-06-30","2021-07-01","2021-07-01","2021-07-02","2021-07-03"),
Category = c("FDE","ABC","FDE","ABC","FDE","ABC","ABC","ABC"),
Week= c("Friday","Monday","Wednesday","Wednesday","Friday","Friday","Saturday","Sunday"),
DR1 = c(4,1,6,3,1,3,0,0),
DR01 = c(4,1,4,3,1,3,0,0), DR02= c(4,2,6,2,2,4,0,0),DR03= c(9,5,4,7,5,2,0,0),
DR04 = c(5,4,3,2,3,4,0,0),DR05 = c(5,4,5,4,2,4,0,0),
DR06 = c(2,4,3,2,2,4,0,0),DR07 = c(2,5,4,4,4,2,0,0),
DR08 = c(3,4,5,4,2,4,0,0),DR09 = c(2,3,4,4,4,2,0,0)),
class = "data.frame", row.names = c(NA, -8L))
return(df1)
}
f1 <- function(df1, dmda, CategoryChosse) {
x<-df1 %>% select(starts_with("DR0"))
x<-cbind(df1, setNames(df1$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))
SPV<-df1%>%
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 <- df1 %>%
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"))
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")
if(as.Date(dmda) < min(as.Date(df1$date1))){
datas <- datas %>%
group_by(Category) %>%
slice(1:max(Days) 1) %>%
ungroup
}else{
datas <- datas %>%
group_by(Category) %>%
slice((as.Date(dmda) - min(as.Date(df1$date1) [
df1$Category == first(Category)])):max(Days) 1) %>%
ungroup
}
plot(Numbers ~ Days, xlim= c(0,45), ylim= c(0,30),
xaxs='i',data = datas,main = paste0(dmda, "-", CategoryChosse))
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,max(0, round(coef,1)), cex=1.1,pos=4,offset =1,col="black")
}
ui <- fluidPage(
ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("",
sidebarLayout(
sidebarPanel(
uiOutput("date"),
uiOutput("mycode"),
br(),
),
mainPanel(
tabsetPanel(
tabPanel("", plotOutput("graph",width = "100%", height = "600")
)
),
))
)))
server <- function(input, output,session) {
data <- reactive(function.test())
output$date <- renderUI({
req(data())
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$Category))
})
output$graph <- renderPlot({
req(input$date2,input$code)
f1(data(),as.character(input$date2),as.character(input$code))
})
}
shinyApp(ui = ui, server = server)
CodePudding user response：
We could wrap with tryCatch and return a custom message if we get the 'must select at least one column' error message
server <- function(input, output,session) {
data <- reactive(function.test())
output$date <- renderUI({
req(data())
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,]
print(nrow(df2))
selectInput("code", label = h4("Code"),choices=unique(df2$Category))
})
output$graph <- renderPlot({
req(input$date2,input$code)
tryCatch({
f1(data(),as.character(input$date2),as.character(input$code))
},
error = function(err) {
if(grepl("must select at least one column", err))
msg <- glue::glue("There is no data for the selected {format(as.Date(input$date2), '%d-%m-%Y')}") else err
showNotification(msg, duration = 10)
return(msg)
}
)
})
}
shinyApp(ui = ui, server = server)
- output
