Time series forecasting in Shiny in R; Shiny displays unix epoch time

user_10221597 0
Viewed 331

Part of the shiny app I am developing involves time series forecasting. It includes a forecast plot and some tabular information showing the forecasted values over N days. Here is some mock data and a minimal example of the shiny code:-

#mock data
library(dplyr)
library(tsibble)
library(fable)
library(fabletools)
library(imputeTS)
library(ggplot2)
library(tidyquant)
library(ids)


randomid<-random_id(333)
Dates<-structure(c(18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 18262, 
                   18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 
                   18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 
                   18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 
                   18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 
                   18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 18263, 
                   18263, 18263, 18263, 18263, 18264, 18264, 18264, 18264, 18264, 
                   18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 
                   18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 
                   18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 
                   18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 
                   18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 18264, 
                   18264, 18264, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 
                   18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 
                   18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 
                   18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 
                   18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 
                   18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 
                   18265, 18265, 18265, 18265, 18265, 18265, 18265, 18265, 18266, 
                   18266, 18266, 18266, 18266, 18266, 18266, 18266, 18266, 18266, 
                   18266, 18266, 18266, 18266, 18266, 18266, 18266, 18266, 18266, 
                   18266, 18266, 18266, 18266, 18266, 18266, 18266, 18266, 18266, 
                   18266, 18266, 18266, 18266, 18266, 18266, 18266, 18266, 18266, 
                   18266, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 
                   18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 
                   18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 
                   18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 
                   18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 18267, 
                   18267, 18267, 18267, 18267, 18267, 18268, 18268, 18268, 18268, 
                   18268, 18268, 18268, 18268, 18268, 18268, 18268, 18268, 18268, 
                   18268, 18268, 18268, 18268, 18268, 18268, 18268, 18268, 18268, 
                   18268, 18268, 18268, 18268, 18268, 18268, 18268, 18268, 18268, 
                   18268, 18268, 18268, 18268, 18268, 18268, 18268, 18268, 18268, 
                   18268, 18268, 18268, 18268, 18268, 18268, 18269, 18269, 18269, 
                   18269, 18269, 18269, 18269, 18269, 18269, 18269, 18269, 18269, 
                   18269, 18269, 18269, 18269, 18269, 18269, 18269, 18269, 18269, 
                   18269, 18269, 18269, 18269, 18269, 18269, 18269, 18269, 18269, 
                   18269, 18269, 18269, 18269, 18269, 18269, 18270, 18270, 18270, 
                   18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 
                   18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 
                   18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 
                   18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 
                   18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 18270, 
                   18270, 18270, 18270, 18270, 18271, 18271, 18271, 18271, 18271, 
                   18271, 18271, 18271, 18271, 18271, 18271, 18271, 18271, 18271, 
                   18271, 18271, 18271, 18271, 18271, 18271, 18271, 18271, 18271, 
                   18271, 18271, 18271, 18271, 18271, 18271, 18271, 18271, 18271, 
                   18271, 18271, 18271, 18271, 18271, 18271, 18271, 18271, 18271, 
                   18271, 18271, 18271, 18272, 18272, 18272, 18272, 18272, 18272, 
                   18272, 18272, 18272, 18272, 18272, 18272, 18272, 18272, 18272, 
                   18272, 18272, 18272, 18272, 18272, 18272, 18272, 18272, 18272, 
                   18272, 18272, 18272, 18272, 18272, 18272, 18272, 18272, 18272, 
                   18272, 18272, 18272, 18272, 18272, 18273, 18273, 18273, 18273, 
                   18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 
                   18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 
                   18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 
                   18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 
                   18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 18273, 
                   18273, 18273, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 
                   18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 
                   18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 
                   18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 
                   18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 
                   18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 18274, 
                   18274, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 
                   18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 
                   18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 
                   18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 
                   18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 18275, 
                   18276, 18276, 18276, 18276, 18276, 18276, 18276, 18276, 18276, 
                   18276, 18276, 18276, 18276, 18276, 18276, 18276, 18276, 18276, 
                   18276, 18276, 18276, 18276, 18276, 18276, 18276, 18276, 18276, 
                   18276, 18276, 18276, 18276, 18276, 18276, 18276, 18276, 18276, 
                   18276, 18277, 18277, 18277, 18277, 18277, 18277, 18277, 18277, 
                   18277, 18277, 18277, 18277, 18277, 18277, 18277, 18277, 18277, 
                   18277, 18277, 18277, 18277, 18277, 18277, 18277, 18277, 18277, 
                   18277, 18277, 18277, 18277, 18277, 18277, 18277, 18277, 18277, 
                   18277, 18277, 18277, 18277, 18277, 18277, 18278, 18278, 18278, 
                   18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 
                   18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 
                   18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 
                   18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 
                   18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 18278, 
                   18279, 18279, 18279, 18279, 18279, 18279, 18279, 18279, 18279, 
                   18279, 18279, 18279, 18279, 18279, 18279, 18279, 18279, 18279, 
                   18279, 18279, 18279, 18279, 18279, 18279, 18279, 18279, 18279, 
                   18279, 18279, 18279, 18279, 18279, 18279, 18280, 18280, 18280, 
                   18280, 18280, 18280, 18280, 18280, 18280, 18280, 18280, 18280, 
                   18280, 18280, 18280, 18280, 18280, 18280, 18280, 18280, 18280, 
                   18280, 18280, 18280, 18280, 18280, 18280, 18280, 18280, 18280, 
                   18280, 18280, 18280, 18280, 18280, 18281, 18281, 18281, 18281, 
                   18281, 18281, 18281, 18281, 18281, 18281, 18281, 18281, 18281, 
                   18281, 18281, 18281, 18281, 18281, 18281, 18281, 18281, 18281, 
                   18281, 18281, 18281, 18281, 18281, 18281, 18281, 18281, 18281, 
                   18281, 18281, 18281, 18281, 18281, 18281, 18281, 18281), class = "Date")
df<-as.data.frame(cbind(randomid,Dates))
df<-as.data.frame(df)
df$Dates<-as.numeric(df$Dates)
df$Dates<-as.Date(df$Dates, origin="1970-01-01")

UI:-

ui<-fluidPage(
  tabItem("dashboard",
          
          
          fluidRow(
            
            box(
              title = "Enter Forecast Horison", width = 4, solidHeader = TRUE, status = "primary",
              h5("Please enter the number of days to forecast"),
              numericInput("forecasthorizon", "Select forecast horizon", 7),
              h5("To zoom in on the plot, specify the date range"),
              dateRangeInput("zoomdaterange","Select date range",
                             start=min(df$Dates),
                             end=max(df$Dates)),
              h5("To edit the y-axis range, input new range below"),
              numericRangeInput("yaxisrange","Select y-axis range",value = c(0,100)),
              h5("Would you like to give your plot a title?"),
              textInput("forecastplottitle","Plot title", "Forecast"),
              
              actionButton(inputId = "click", label = "Forecast")
            )
            
          ),
          fluidRow(
            
            box(
              title = "Forecast plot",
              status = "primary",
              plotOutput("forecastplot", height = 350),
              height = 400
            ),
            box(
              title = "Forecast values",
              
              width = 6,
              tableOutput("forecastvalues"),
              textOutput("winningmodel"),
              height = 380
              
            )
            
            
          )))

And server:-

#server


server<-function(input,output,session){
  
  
  
  observeEvent(input$click,{
    
    
    
    
    
    output$forecastvalues<-renderTable({
      
      #readRDS("Calls.rds")
      
      period<-as.numeric(input$forecasthorizon)
      # more compact sintax
      data_count <- count(df, Dates, name = "Count")
      
      # better specify the date variable to avoid the message
      data_count <- as_tsibble(data_count, index = Dates)
      
      #  # you need to complete missing dates, just in case
      data_count <- tsibble::fill_gaps(data_count)
      
      
      data_count <- na_mean(data_count)
      
      
      fit <- data_count %>%
        model(
          ets    = ETS(Count),
          arima  = ARIMA(Count),
          snaive = SNAIVE(Count)
        ) %>%
        mutate(mixed = (ets + arima + snaive) / 3)
      
      
      
      
      fc <- fit %>% forecast(h = period)
      
      
      res <- fc %>% 
        as_tibble() %>% 
        select(-Count) %>% 
        tidyr::pivot_wider(names_from = .model, values_from = .mean) %>% 
        #inner_join(test, by = "Date")%>%
        print(n=Inf)
      
      (res)
    })
    
    # fc_resid<- fit %>% forecast(h = period)
    
    
    output$forecastplot<-renderPlot({
      
      #req(input$zoomdaterange)
      
      eventdate <- as.Date(Sys.Date())
      
      period<-as.numeric(input$forecasthorizon)
      #   more compact sintax
      data_count <- count(df, Dates, name = "Count")
      
      # better specify the date variable to avoid the message
      data_count <- as_tsibble(data_count, index = Dates)
      
      # you need to complete missing dates, just in case
      data_count <- tsibble::fill_gaps(data_count)
      
      
      data_count <- na_mean(data_count)
      
      
      
      fit <- data_count %>%
        model(
          ets    = ETS(Count),
          arima  = ARIMA(Count),
          snaive = SNAIVE(Count)
        ) %>%
        mutate(mixed = (ets + arima + snaive) / 3)
      
      fc <- fit %>% forecast(h = period)
      
      firstzoomdate<-as.Date(input$zoomdaterange[1])
      lastzoomdate<-as.Date(input$zoomdaterange[2])
      
      minyaxis<-as.numeric(input$yaxisrange[1])
      maxyaxis<-as.numeric(input$yaxisrange[2])
      # your plot
      forecastplot <- fc %>%
        autoplot(data_count, level = NULL) + 
        ggtitle(input$forecastplottitle) +
         coord_x_date(xlim = c(firstzoomdate, lastzoomdate),
                                 ylim= c(minyaxis,maxyaxis))
      
      
      
      
      
      
      
      
      plot(forecastplot)
    })
    
    
    
    
    
  })
  
  
}

shinyApp(ui,server)

The graphs are adjustable by changing the date range and ylim values (makes it easier to interpret depending on the data being used). When you click the action button, it runs alright but it returns dates in unix variaion.

enter image description here

When it should be this:-

enter image description here

Can anyone point out how I can return the dates in the app that are in Date format and not numeric?

Thanks!

shiny time-series r date user-interface
1 Answers

In renderTable, you could just give the Dates field the format you want:

      res <- fc %>% 
        as_tibble() %>% 
        select(-Count) %>% 
        tidyr::pivot_wider(names_from = .model, values_from = .mean) %>% 
        #inner_join(test, by = "Date")%>%
        print(n=Inf)
      # Set format 
      res$Dates <- format(res$Dates,'%Y-%m-%d')
      (res)

enter image description here

user_135133280
Related