# Function to check if a package is installed, and install it if not
install_if_missing <- function(p) {
  if (!require(p, character.only = TRUE)) {
    install.packages(p, dependencies = TRUE)
    library(p, character.only = TRUE)
  }
}

# List of required packages
packages <- c("shiny", "shinycssloaders", "shinyjs", "prophet", "readr", "ggplot2", "dplyr", "plotly", "future", "bsplus", "shinythemes", "DT", "forecast")
lapply(packages, install_if_missing)

# Load the necessary libraries
library(shiny)
library(shinycssloaders)
library(shinyjs)
library(prophet)
library(readr)
library(ggplot2)
library(dplyr)
library(plotly)
library(future)
library(bsplus)
library(shinythemes)
library(DT)
library(forecast)

plan(multisession)  # Enable parallel processing

# Load default dataset
default_data <- read_csv("filtered_mortality_data_for_r.csv") %>%
  rename(ds = date, y = mortality_rate) %>%
  mutate(ds = as.Date(ds)) %>%
  distinct(ds, .keep_all = TRUE)

# Define UI
ui <- fluidPage(
  theme = shinytheme("cyborg"),
  
  # Add custom CSS for Comfortaa font and white text
  tags$head(
    tags$link(
      href = "https://fonts.googleapis.com/css2?family=Comfortaa:wght@300;400;700&display=swap", 
      rel = "stylesheet"
    ),
    tags$style(HTML("
      body {
        font-family: 'Comfortaa', sans-serif;
      
      }
      .shiny-output-error {
        color: white;
      }
      .shiny-input-container {
        color: white;
      }
      h2, h3, h4, h5, h6, p, label {
        color: white;
        font-family: 'Comfortaa', sans-serif;
      }
      .tab-pane {
        background-color: black;
        color: white;
      }
      .nav-tabs > li > a {
        color: white;
      }
      .nav-tabs > li > a:hover {
        color: white;
      }
      .nav-tabs > .active > a, .nav-tabs > .active > a:focus, .nav-tabs > .active > a:hover {
        color: white;
      }
      .slider-container {
        display: flex;
        justify-content: center;
      }
      .slider-container .shiny-input-container {
        width: 80%;
      }
      #progress {
        color: white;
        margin-top: 10px;
      }
      #update {
        background-color: #337ab7;
        color: white;
        font-weight: bold;
        font-size: 16px;
      }
.well {
  min-height: 20px;
  padding: 19px;
  margin-bottom: 20px;
  background-color: #15151500;
  border: 1px solid #030303;
  border-radius: 4px;
  -webkit-box-shadow: inset 0 1px 1px rgba(0,0,0,0.05);
  box-shadow: inset 0 1px 1px rgba(0,0,0,0.05);
  backdrop-filter: blur(3px);
}
img {
filter:invert(0);
transition:0.5s;
}
img:hover {
filter:invert(1);
transition:0.5s;
}
.shiny-notification {
    position: fixed;
    background-color: #e8e8e8;
    color: #333;
    border: 1px solid #ccc;
    border-radius: 3px;
    opacity: .85;
    padding: 10px 2rem 10px 10px;
    margin: 5px;
    top: 333px;
    left:300px;
}
body {

    background-color: #06060600;
}
.js-plotly-plot .plotly .main-svg {
    position: absolute;
    top: 0px;
    left: 0px;
    pointer-events: none;
    filter: invert(1);
    transition:0.5s;
}
.js-plotly-plot .plotly .main-svg:hover {
    position: absolute;
    top: 0px;
    left: 0px;
    pointer-events: none;
    filter: invert(0);
}
    ")),
    tags$script(src = "https://polyfill.io/v3/polyfill.min.js?features=es6"),
    tags$script(src = "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js"),
    tags$script(HTML("
      MathJax.Hub.Config({
        tex2jax: {inlineMath: [['$','$'], ['\\(','\\)']]}
      });
    "))
  ),
  
  useShinyjs(),  # Initialize shinyjs for better UI interactions
  titlePanel("Professional Prophet Forecasting"),
  
  sidebarLayout(
    sidebarPanel(
      actionButton("update", "Update Forecast", class = "btn btn-primary"),
      div(id = "progress", ""),  # Progress display here
      sliderInput("periods_slider", "Forecast Period (days):", min = 30, max = 730, value = 365) %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Number of days to forecast into the future.")
        ),
      numericInput("changepoint_prior_scale", "Changepoint Prior Scale (\\alpha)", 0.05) %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Adjust the flexibility of the trend (\\alpha). Higher values allow more changepoints.")
        ),
      numericInput("seasonality_prior_scale", "Seasonality Prior Scale (\\beta)", 10.0) %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Adjust the strength of seasonality (\\beta). Higher values allow stronger seasonal effects.")
        ),
      numericInput("holidays_prior_scale", "Holidays Prior Scale (\\gamma)", 10.0) %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Adjust the influence of holidays (\\gamma). Higher values allow holidays to have more impact.")
        ),
      numericInput("yearly_seasonality", "Yearly Seasonality", 10) %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Number of Fourier terms to capture yearly seasonality.")
        ),
      numericInput("weekly_seasonality", "Weekly Seasonality", 3) %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Number of Fourier terms to capture weekly seasonality.")
        ),
      numericInput("daily_seasonality", "Daily Seasonality", 0) %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Number of Fourier terms to capture daily seasonality.")
        ),
      checkboxInput("include_history", "Include History in Forecast", TRUE) %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Include the historical data in the forecast plot.")
        ),
      radioButtons("method", "Computation Method:",
                   choices = list("Heuristic (fast)" = "heuristic", "Analytic (exact)" = "analytic"),
                   selected = "heuristic") %>%
        shinyInput_label_embed(
          shiny_iconlink() %>%
            bs_embed_tooltip(title = "Choose between heuristic (fast) and analytic (exact) computations.")
        ),
      width = 3
    ),
    
    mainPanel(
      tabsetPanel(
        tabPanel(
          "Forecast",
          withSpinner(plotlyOutput("forecastPlot"), type = 3, color.background = "white"),
          uiOutput("currentParamsMathJax"),
          verbatimTextOutput("modelSummary"),
          verbatimTextOutput("modelParameters"),
          verbatimTextOutput("modelResults")
        ),
        tabPanel(
          "Additional Plots",
          withSpinner(plotlyOutput("residualsPlot"), type = 3, color.background = "white"),
          withSpinner(plotlyOutput("acfPlot"), type = 3, color.background = "white"),
          withSpinner(plotlyOutput("pacfPlot"), type = 3, color.background = "white"),
          withSpinner(plotlyOutput("seasonalDecomposition"), type = 3, color.background = "white"),
          withSpinner(plotlyOutput("uncertaintyIntervals"), type = 3, color.background = "white")
        ),
        tabPanel(
          "Model Performance",
          withSpinner(DTOutput("modelPerformanceMetrics"), type = 3, color.background = "white")
        ),
        tabPanel(
          "Forecast Data",
          withSpinner(DTOutput("forecastTable"), type = 3, color.background = "white")
        ),
        tabPanel(
          "Components",
          withSpinner(plotlyOutput("componentsPlot"), type = 3, color.background = "white")
        ),
        tabPanel(
          "Current Parametrisation",
          verbatimTextOutput("currentParams"),
          tags$div(
            h4("Current Model:"),
            tags$p(HTML("
              \\[
              y(t) = g(t) + s(t) + h(t) + \\epsilon_t
              \\]
              \\[
              g(t) = \\text{Trend} = \\alpha + \\beta \\cdot t
              \\]
              \\[
              s(t) = \\text{Seasonality} = \\sum_k \\gamma_k \\cdot S_k(t)
              \\]
              \\[
              h(t) = \\text{Holidays} = \\sum_l \\delta_l \\cdot H_l(t)
              \\]
            "))
          )
        )
      )
    )
  )
)

# Define server logic
server <- function(input, output, session) {
  dataInput <- reactive({
    return(default_data)
  })
  
  modelFit <- reactive({
    input$update
    isolate({
      # Create a Progress object
      progress <- shiny::Progress$new()
      # Make sure it closes when we exit this reactive, even if there's an error
      on.exit(progress$close())
      
      progress$set(message = "Fitting model", value = 0)
      
      data <- dataInput()
      progress$inc(0.2, detail = "Preparing data")
      
      m <- prophet(
        changepoint.prior.scale = input$changepoint_prior_scale,
        seasonality.prior.scale = input$seasonality_prior_scale,
        holidays.prior.scale = input$holidays_prior_scale,
        yearly.seasonality = input$yearly_seasonality,
        weekly.seasonality = input$weekly_seasonality,
        daily.seasonality = input$daily_seasonality
      )
      progress$inc(0.4, detail = "Fitting model to data")
      
      m <- fit.prophet(m, data)
      progress$inc(0.4, detail = "Model fitting complete")
      
      return(m)
    })
  })
  
  forecastData <- reactive({
    input$update
    isolate({
      # Create a Progress object
      progress <- shiny::Progress$new()
      # Make sure it closes when we exit this reactive, even if there's an error
      on.exit(progress$close())
      
      progress$set(message = "Creating forecast", value = 0)
      
      m <- modelFit()
      progress$inc(0.2, detail = "Preparing future dataframe")
      
      future <- make_future_dataframe(m, periods = input$periods_slider, include_history = input$include_history)
      progress$inc(0.4, detail = "Predicting future values")
      
      forecast <- predict(m, future)
      progress$inc(0.4, detail = "Forecasting complete")
      
      return(forecast)
    })
  })
  
  output$forecastPlot <- renderPlotly({
    forecast <- forecastData()
    m <- modelFit()
    p <- plot(m, forecast) +
      ggtitle("Prophet Forecast") +
      xlab("Time") +
      ylab("Mortality Rate")
    ggplotly(p)
  })
  
  output$componentsPlot <- renderPlotly({
    forecast <- forecastData()
    m <- modelFit()
    components <- prophet_plot_components(m, forecast)
    plots <- lapply(components, ggplotly)
    plotly::subplot(plots, nrows = length(plots), shareX = TRUE)
  })
  
  output$modelPerformanceMetrics <- renderDT({
    input$update
    isolate({
      # Create a Progress object
      progress <- shiny::Progress$new()
      # Make sure it closes when we exit this reactive, even if there's an error
      on.exit(progress$close())
      
      progress$set(message = "Performing cross-validation", value = 0)
      
      m <- modelFit()
      method <- input$method
      df_cv_future <- future({
        if (method == "heuristic") {
          cross_validation(m, initial = 365, period = 180, horizon = 90, units = "days")
        } else {
          cross_validation(m, initial = 365*2, period = 180, horizon = 180, units = "days")
        }
      })
      df_cv <- value(df_cv_future)
      progress$inc(0.5, detail = "Calculating performance metrics")
      
      df_p <- performance_metrics(df_cv)
      progress$inc(0.5, detail = "Cross-validation complete")
      
      datatable(df_p, options = list(pageLength = 10, autoWidth = TRUE, scrollX = TRUE))
    })
  })
  
  output$modelParameters <- renderPrint({
    input$update
    isolate({
      m <- modelFit()
      print(m)
    })
  })
  
  output$modelResults <- renderPrint({
    input$update
    isolate({
      forecast <- forecastData()
      print(head(forecast, 10))
    })
  })
  
  output$modelSummary <- renderPrint({
    input$update
    isolate({
      m <- modelFit()
      summary <- capture.output(summary(m))
      cat(paste(summary, collapse = "\n"))
    })
  })
  
  output$forecastTable <- renderDT({
    forecast <- forecastData()
    datatable(forecast, options = list(pageLength = 10, autoWidth = TRUE, scrollX = TRUE))
  })
  
  output$seasonalDecomposition <- renderPlotly({
    forecast <- forecastData()
    if (nrow(forecast) > 1 && !is.null(forecast$yhat)) {
      ts_data <- ts(forecast$yhat, frequency = 12)
      components <- decompose(ts_data)
      p <- autoplot(components) + ggtitle("Seasonal Decomposition")
      ggplotly(p)
    }
  })
  
  output$uncertaintyIntervals <- renderPlotly({
    forecast <- forecastData()
    if (nrow(forecast) > 0) {
      p <- ggplot(forecast, aes(x = ds)) +
        geom_line(aes(y = yhat), color = 'blue') +
        geom_ribbon(aes(ymin = yhat_lower, ymax = yhat_upper), alpha = 0.2) +
        ggtitle("Forecast with Uncertainty Intervals") +
        xlab("Date") +
        ylab("Forecasted Value")
      ggplotly(p)
    }
  })
  
  output$currentParams <- renderPrint({
    input$update
    isolate({
      params <- list(
        periods_slider = input$periods_slider,
        changepoint_prior_scale = input$changepoint_prior_scale,
        seasonality_prior_scale = input$seasonality_prior_scale,
        holidays_prior_scale = input$holidays_prior_scale,
        yearly_seasonality = input$yearly_seasonality,
        weekly_seasonality = input$weekly_seasonality,
        daily_seasonality = input$daily_seasonality,
        include_history = input$include_history,
        method = input$method
      )
      print(params)
    })
  })
  
  output$currentParamsMathJax <- renderUI({
    input$update
    isolate({
      params <- list(
        periods_slider = input$periods_slider,
        changepoint_prior_scale = input$changepoint_prior_scale,
        seasonality_prior_scale = input$seasonality_prior_scale,
        holidays_prior_scale = input$holidays_prior_scale,
        yearly_seasonality = input$yearly_seasonality,
        weekly_seasonality = input$weekly_seasonality,
        daily_seasonality = input$daily_seasonality,
        include_history = input$include_history,
        method = input$method
      )
      HTML(paste0(
        "<script type='math/tex; mode=display'>
        \\text{Current Parameters:} \\\\
        \\text{Forecast Period (days): ", params$periods_slider, "} \\\\
        \\alpha: ", params$changepoint_prior_scale, " \\\\
        \\beta: ", params$seasonality_prior_scale, " \\\\
        \\gamma: ", params$holidays_prior_scale, " \\\\
        \\text{Yearly Seasonality: ", params$yearly_seasonality, "} \\\\
        \\text{Weekly Seasonality: ", params$weekly_seasonality, "} \\\\
        \\text{Daily Seasonality: ", params$daily_seasonality, "} \\\\
        \\text{Include History: ", ifelse(params$include_history, "Yes", "No"), "} \\\\
        \\text{Method: ", params$method, "}
        </script>"
      ))
    })
  })
  
  updateProgress <- function(session, percent, message) {
    session$sendCustomMessage(type = 'update-progress', message = list(percent = percent, message = message))
  }
  
  observeEvent(input$update, {
    updateProgress(0, "Starting update...")
  })
  
  # Custom handler for progress updates
  session$onFlushed(function() {
    session$sendCustomMessage(type = 'update-progress', message = list(percent = 0, message = "Initializing..."))
  }, once = TRUE)
}

# JavaScript code to handle progress updates
js <- "
Shiny.addCustomMessageHandler('update-progress', function(message) {
  $('#progress').text('Progress: ' + message.percent + '% - ' + message.message);
});
"

# Run the application 
shinyApp(ui = ui, server = server)

 

Top Skip to content