Error on filtering on data for R Shiny app - filter

Question

I am trying to crate a Shiny app for price forecasting. price curve categorized based on 3 filed: 1- curve name, 2- peak type and 3- delivery.
I have a question in Server function for my app, I have following code and ui section is working fine but I think server function filtering on data has some problem, I really apricate if anyone can help me on this.
Data sets"
head(data,10)
date curve_code curve peak_code delivery period peak price
1 0001-10-20 3 ICE NYISO A Monthly Futures 0 2024-05 17 OFF_PEAK 19.05
2 0001-10-20 4 ICE NYISO C Monthly Futures 1 2024-02 14 PEAK 66.90
3 0001-10-20 3 ICE NYISO A Monthly Futures 0 2023-05 5 OFF_PEAK 19.85
4 0001-10-20 3 ICE NYISO A Monthly Futures 1 2023-03 3 PEAK 35.30
5 0001-10-20 3 ICE NYISO A Monthly Futures 0 2023-08 8 OFF_PEAK 39.20
6 0001-10-20 4 ICE NYISO C Monthly Futures 0 2023-11 11 OFF_PEAK 24.30
7 0001-10-20 5 ICE NYISO F Monthly Futures 0 2023-03 3 OFF_PEAK 72.25
8 0001-10-20 3 ICE NYISO A Monthly Futures 1 2023-07 7 PEAK 56.45
9 0001-10-20 6 ICE NYISO G Monthly Futures 1 2024-07 19 PEAK 69.75
10 0001-10-20 5 ICE NYISO F Monthly Futures 0 2023-07 7 OFF_PEAK 53.25
and here is my code
## app.R ##
library(shinydashboard)
ui <- dashboardPage(
header <- dashboardHeader(title = " Price Forecasting"),
## Sidebar content
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("price forecasting", tabName = "dashboard1", icon = icon("chart-bar")),
menuItem(" Log-Return forecasting", tabName = "dashboard2", icon = icon("chart-bar")),
menuItem("Choose Curve Name", tabName = "controller", icon = icon("th"))
)
),
## Body content
body <- dashboardBody(
tabItems(
# First Tab Content
tabItem(tabName = "dashboard1",
fluidRow(
box(title = "Forecast Auto-Arima Method", status = "primary", solidHeader = TRUE, collapsible = T, plotOutput("plot1", height = 400),
verbatimTextOutput("detail1")
),
box(title = "Timeseries Decomposition", status = "primary", solidHeader = TRUE, collapsible = T, plotOutput("plot2", height = 400),
verbatimTextOutput("detail2")
),
)
),
# Second Tab Content
tabItem(tabName = "dashboard2",
fluidRow(
box(title = "Log-return Forecast Auto-Arima Method", status = "primary", solidHeader = TRUE, collapsible = TRUE, plotOutput("plot4", height = 400),
verbatimTextOutput("detail3")
),
box(title = "Log-return Timeseries Decomposition", status = "primary", solidHeader = TRUE, collapsible = TRUE, plotOutput("plot5", height = 400),
verbatimTextOutput("detail4")
),
)
),
# Third tab content
tabItem(tabName = "controller",
fluidRow(
box(title = "Curve_name", status = "primary", solidHeader = TRUE, collapsible = TRUE,
selectInput("reg",label = "Choose Curve name",
choices = list('ICE NYISO A Monthly Futures'=1,
'ICE NYISO C Monthly Futures'=2,
'ICE NYISO F Monthly Futures'=3,
'ICE NYISO G Monthly Futures'=4),
selected = "ICE NYISO A Monthly Futures")
),
box(title = "Peak_type", status = "primary", solidHeader = TRUE, collapsible = TRUE,
selectInput("reg",label = "Choose Peak Type",
choices = list("PEAK"=1,
"OFF_PEAK"=2),
selected = "PEAK")
),
box(title = "Delivery", status = "primary", solidHeader = TRUE, collapsible = TRUE,
selectInput("reg",label = "Choose Delivery Period",
choices = list("2023-01"=1,"2023-02"=2,"2023-03"=3, "2023-04"=4,"2023-05"=5, "2023-06"=6,
"2023-07"=7,"2023-08"=8, "2023-09"=9,"2023-10"=10,"2023-11"=11, "2023-12"=12,
"2024-01"=13,
"2024-02"=14,
"2024-03"=15,
"2024-04"=16,
"2024-05"=17,
"2024-06"=18,
"2024-07"=19,
"2024-08"=20,
"2024-09"=21,
"2024-10"=22,
"2024-11"=23,
"2024-12"=24
),
selected = "2024-02")
)
)
)
)
),
#Integrate Dashboard
dashboardPage(
header,
sidebar,
body
)
)
#Our Server to get IO from User
#
data=read.csv("ICE data.csv", h=T)
library(dplyr)
#data=dplyr::filter(data,peak_type==c("PEAK" ,"OFF_PEAK"))
data <- data[order(data$last_updated_date,decreasing=F),]
data=data.frame(date=as.Date(data$last_updated_date, origin = "1900-01-01"),
curve=data$ICE.Curve.Name, delivery=data$delivery, period=data$period, peak=data$peak_type, price=data$ICE.price)
server <- function(input, output) {
# server logic based on user input
observeEvent(c(input$Curve_name,input$Peak_type,input$Delivery), {
data <- data %>%
filter(curve %in% input$Curve_name)
if (input$Delivery == 1) {
data <- data %>%
filter(delivery=="2023-01") }
if (input$Delivery == 2) {
data <- data %>%
filter(delivery=="2023-02") }
if (input$Delivery == 3) {
data <- data %>%
filter(delivery=="2023-03") }
if (input$Delivery == 4) {
data <- data %>%
filter(delivery=="2023-04") }
if (input$Delivery == 5) {
data <- data %>%
filter(delivery=="2023-05") }
if (input$Delivery == 6) {
data <- data %>%
filter(delivery=="2023-06") }
if (input$Delivery == 7) {
data <- data %>%
filter(delivery=="2023-07") }
if (input$Delivery == 8) {
data <- data %>%
filter(delivery=="2023-08") }
if (input$Delivery == 9) {
data <- data %>%
filter(delivery=="2023-09") }
if (input$Delivery == 10) {
data <- data %>%
filter(delivery=="2023-10") }
if (input$Delivery == 11) {
data <- data %>%
filter(delivery=="2023-11") }
if (input$Delivery == 12) {
data <- data %>%
filter(delivery=="2023-12") }
if (input$Delivery == 13) {
data <- data %>%
filter(delivery=="2024-01") }
if (input$Delivery == 14) {
data <- data %>%
filter(delivery=="2024-02") }
if (input$Delivery == 15) {
data <- data %>%
filter(delivery=="2024-03") }
if (input$Delivery == 16) {
data <- data %>%
filter(delivery=="2024-04") }
if (input$Delivery == 17) {
data <- data %>%
filter(delivery=="2024-05") }
if (input$Delivery == 18) {
data <- data %>%
filter(delivery=="2024-06") }
if (input$Delivery == 19) {
data <- data %>%
filter(delivery=="2024-07") }
if (input$Delivery == 20) {
data <- data %>%
filter(delivery=="2024-08") }
if (input$Delivery == 21) {
data <- data %>%
filter(delivery=="2024-09") }
if (input$Delivery == 22) {
data <- data %>%
filter(delivery=="2024-10") }
if (input$Delivery == 23) {
data <- data %>%
filter(delivery=="2024-11") }
if (input$Delivery == 24) {
data <- data %>%
filter(delivery=="2024-12") }
if (input$Peak_type == 1) {
data <- data %>%
filter(peak=="PEAK") }
if (input$Peak_type == 2) {
data <- data %>%
filter(peak=="OFF_PEAK") }
#model
m1 <- auto.arima(data$price)
f1 <- forecast(m1, h = 30)
plot(f1)
detail1 <- accuracy(f1)
m2 <- auto.arima(data$price)
f2 <- forecast(m2, h = 20)
plot(f2)
detail2 <- accuracy(f2)
m3 <- auto.arima(diff(log(data$price), lag=1))
f3 <- forecast(m3, h = 30)
plot(f3)
detail3 <- accuracy(f3)
m4 <- auto.arima(diff(log(data$price), lag=1))
f4 <- forecast(m4, h = 20)
plot(f4)
detail4 <- accuracy(f4)
output$detail1 <- renderText({ detail1[,"MAPE"] })
output$detail2 <- renderText({ detail2[,"MAPE"] })
output$detail3 <- renderText({ detail3[,"MAPE"] })
output$detail4 <- renderText({ detail4[,"MAPE"] })
# Create plot
output$plot1 <- renderPlot({
plot(f1)
})
output$plot2 <- renderPlot({
plot(f2)
})
output$plot3 <- renderPlot({
plot(f3)
})
output$plot4 <- renderPlot({
plot(f4)
})
})
}
shinyApp(ui, server)
I am expecting to have plot for ARIMA forecasting for each curve, delivery and peak type

Answer 1

Don't nest all of your output$.. <- calls within an observeEvent: they are defined once, at which point none of them react to changing data.
input$Delivery is never defined, that should be input$reg (the box title does nothing for input$-based variables).
I suggest a mydata <- reactive(..) model that works on filtering the data based on inputs, and then model/forecast/plot that.
We can do some significant reduction of code, all 24 of the if (input$Delivery == 21) {...} can be simplified into 1 expression. Change your box(title="Delivery" to:
box(title = "Delivery", status = "primary", solidHeader = TRUE, collapsible = TRUE,
selectInput("reg",label = "Choose Delivery Period",
choices =
c("2023-01", "2023-02", "2023-03", "2023-04", "2023-05", "2023-06",
"2023-07", "2023-08", "2023-09", "2023-10", "2023-11", "2023-12",
"2024-01", "2024-02", "2024-03", "2024-04", "2024-05", "2024-06",
"2024-07", "2024-08", "2024-09", "2024-10", "2024-11", "2024-12"),
selected = "2024-02")
)
Similarly, change the Peak type choices to choices = c("PEAK", "OFF_PEAK"). Note that if the choices= vector/list is named, then it shows the names and returns the value; if it is not named, it shows and returns the values.
Try this (untested):
server <- function(input, output) {
# data <- read.csv(...)
mydata <- eventReactive(input$reg, {
req(input$reg)
data %>%
filter(delivery == input$reg, peak = input$Peak_type)
})
mdl1 <- eventReactive(mydata(), {
req(mydata())
mdl <- auto.arima(mydata()$price)
fcst <- forecast(mdl, h = 30)
detail <- accuracy(fcst)
list(mdl = mdl, fcst = fcst, detail = detail)
})
mdl2 <- eventReactive(mydata(), {
req(mydata())
mdl <- auto.arima(mydata()$price)
fcst <- forecast(mdl, h = 20)
detail <- accuracy(fcst)
list(mdl = mdl, fcst = fcst, detail = detail)
})
mdl3 <- eventReactive(mydata(), {
req(mydata())
mdl <- auto.arima(diff(log(mydata()$price), lag = 1))
fcst <- forecast(mdl, h = 30)
detail <- accuracy(fcst)
list(mdl = mdl, fcst = fcst, detail = detail)
})
mdl4 <- eventReactive(mydata(), {
req(mydata())
mdl <- auto.arima(diff(log(mydata()$price), lag = 1))
fcst <- forecast(mdl, h = 20)
detail <- accuracy(fcst)
list(mdl = mdl, fcst = fcst, detail = detail)
})
output$detail1 <- renderText({ req(mdl1()); mdl1()$detail[,"MAPE"] })
output$detail2 <- renderText({ req(mdl2()); mdl2()$detail[,"MAPE"] })
output$detail3 <- renderText({ req(mdl3()); mdl3()$detail[,"MAPE"] })
output$detail4 <- renderText({ req(mdl4()); mdl4()$detail[,"MAPE"] })
output$plot1 <- renderPlot({ req(mdl1()); plot(mdl1()$fcst); })
output$plot2 <- renderPlot({ req(mdl2()); plot(mdl2()$fcst); })
output$plot3 <- renderPlot({ req(mdl3()); plot(mdl3()$fcst); })
output$plot4 <- renderPlot({ req(mdl4()); plot(mdl4()$fcst); })
}