I'm having a problem when I select options in my selectInput. Note that if I select 30/06, two ids will appear, which are 1 and 5. If I choose 5, I would have to show only 1 code, as I have only one observation for id =5, however, as you can see by the image below, it is appearing twice. So I need to adjust this questions on my server.
Executable code below:
library(shiny)
library(shinythemes)
library(dplyr)
library(tidyverse)
library(lubridate)
library(stringr)
df1 <- structure(
list(id=c("1","5","1","1"),
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,7,6,3),
DR01 = c(4,1,4,3), DR02= c(4,9,6,2),DR03= c(9,5,4,7),
DR04 = c(5,6,3,2),DR05 = c(5,4,5,4),
DR06 = c(2,6,3,2),DR07 = c(2,2,4,4),
DR08 = c(3,6,5,4),DR09 = c(2,3,4,4)),
class = "data.frame", row.names = c(NA, -4L))
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")
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)
coef<-coef(model)[2]
points(0, coef, col="red",pch=19,cex = 2,xpd=TRUE)
}
ui <- fluidPage(
ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("",
sidebarLayout(
sidebarPanel(
uiOutput("date"),
uiOutput("id"),
uiOutput("mycode"),
br(),
),
mainPanel(
tabsetPanel(
tabPanel("", plotOutput("graph",width = "100%", height = "600")
)
),
))
)))
server <- function(input, output,session) {
data <- reactive(df1)
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),
format = "dd-mm-yyyy",
datesdisabled = disabled)
})
output$id <- renderUI({
req(input$date2)
df1 <- data()
df2 <- df1[as.Date(df1$date2) %in% input$date2,]
selectInput("idd", label = h4("Id"),choices=unique(df2$id))
})
output$mycode <- renderUI({
req(input$date2,input$idd)
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$idd,input$code)
f1(data(),as.character(input$date2),as.character(input$code))
})
}
shinyApp(ui = ui, server = server)
CodePudding user response：
This is fairly convoluted, but I think a couple of minor adjustments might be helpful here. First, you might want to double check what inputs you include in req. Second, you may want to filter your data based on input$idd when you provide code options. Let me know if this is helpful.
server <- function(input, output, session) {
data <- reactive(df1)
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),
format = "dd-mm-yyyy",
datesdisabled = disabled)
})
output$id <- renderUI({
req(input$date2)
df1 <- data()
df2 <- df1[as.Date(df1$date2) %in% input$date2,]
selectInput("idd", label = h4("Id"),choices=unique(df2$id))
})
output$mycode <- renderUI({
req(input$date2, input$idd)
df1 <- data()
df2 <- df1[as.Date(df1$date2) %in% input$date2 & input$idd == df1$id, ]
selectInput("code", label = h4("Code"),choices=unique(df2$Category))
})
output$graph <- renderPlot({
req(input$date2, input$idd, input$code)
f1(data(),as.character(input$date2),as.character(input$code))
})
}