# Load necessary libraries library(shiny) library(httr) library(shinycssloaders) invisible(lapply( list.files(path = "R", pattern = "\\.R$", full.names = TRUE), source )) locations <- get_rain_locations() secondary_metrics <- get_weather_metric_catalog(include_rain = FALSE) db_path <- default_rain_db_path() ensure_weather_db(db_path) get_window_slider_config <- function(unit = "days") { switch( unit, days = list(label = "Past days", max = 60L, value = 10L), months = list(label = "Past months", max = 24L, value = 6L), years = list(label = "Past years", max = 10L, value = 1L), list(label = "Past days", max = 60L, value = 10L) ) } last_day_of_month <- function(year, month) { next_month_year <- year + if (month == 12L) 1L else 0L next_month <- if (month == 12L) 1L else month + 1L next_month_start <- as.Date(sprintf("%04d-%02d-01", next_month_year, next_month)) as.integer(format(next_month_start - 1L, "%d")) } subtract_calendar_period <- function(date, amount, unit) { date <- as.Date(date) amount <- as.integer(amount) if (amount <= 0L) { return(date) } date_lt <- as.POSIXlt(date, tz = "UTC") year <- date_lt$year + 1900L month <- date_lt$mon + 1L day <- date_lt$mday if (identical(unit, "months")) { total_months <- year * 12L + (month - 1L) - amount target_year <- total_months %/% 12L target_month <- total_months %% 12L + 1L target_day <- min(day, last_day_of_month(target_year, target_month)) return(as.Date(sprintf("%04d-%02d-%02d", target_year, target_month, target_day))) } if (identical(unit, "years")) { target_year <- year - amount target_day <- min(day, last_day_of_month(target_year, month)) return(as.Date(sprintf("%04d-%02d-%02d", target_year, month, target_day))) } date - amount } window_start_date <- function(end_date, amount, unit) { end_date <- as.Date(end_date) amount <- max(1L, as.integer(amount)) if (identical(unit, "days")) { return(end_date - amount + 1L) } subtract_calendar_period(end_date, amount, unit) + 1L } format_window_label <- function(amount, unit) { amount <- max(1L, as.integer(amount)) unit_label <- if (amount == 1L) sub("s$", "", unit) else unit sprintf("last %s %s", amount, unit_label) } get_rain_view_choices <- function(window_unit = "days") { switch( window_unit, days = c( "6-minute rain" = "raw", "Daily total" = "daily" ), months = c( "Daily total" = "daily", "Weekly total" = "weekly" ), years = c( "Weekly total" = "weekly", "Monthly total" = "monthly" ), c( "6-minute rain" = "raw", "Daily total" = "daily" ) ) } get_metric_view_choices <- function(window_unit = "days") { switch( window_unit, days = c( "Raw observations" = "raw", "Daily aggregate" = "daily" ), months = c( "Daily aggregate" = "daily", "Weekly aggregate" = "weekly" ), years = c( "Weekly aggregate" = "weekly", "Monthly aggregate" = "monthly" ), c( "Raw observations" = "raw", "Daily aggregate" = "daily" ) ) } get_preferred_window_view <- function(window_unit = "days") { switch( window_unit, days = "raw", months = "weekly", years = "monthly", "raw" ) } ui <- fluidPage( tags$head( tags$style(HTML(" .container-fluid { max-width: 1480px; } .status-block { margin-top: 16px; padding: 12px; background: #f6f8f9; border: 1px solid #d9e1e5; border-radius: 6px; } .help-block { margin-top: 12px; } .panel-card { min-height: 100%; padding: 16px; background: #fbfcfd; border: 1px solid #d9e1e5; border-radius: 8px; } .panel-title { margin-top: 0; } ")) ), titlePanel("Beaumont Weather Cache"), sidebarLayout( sidebarPanel( width = 3, selectInput( inputId = "location_id", label = "Location", choices = stats::setNames(locations$location_id, locations$label), selected = locations$location_id[1] ), radioButtons( inputId = "window_unit", label = "Time window", choices = c( "Days" = "days", "Months" = "months", "Years" = "years" ), selected = "days", inline = TRUE ), sliderInput( inputId = "window_amount", label = "Past days", min = 1, max = 60, value = 10, step = 1 ), radioButtons( inputId = "rain_view_mode", label = "Rain display", choices = c( "6-minute rain" = "raw", "Daily total" = "daily" ), selected = "raw" ), checkboxInput( inputId = "hide_zero", label = "Hide zero rainfall", value = TRUE ), selectInput( inputId = "metric_id", label = "Second panel", choices = stats::setNames(secondary_metrics$metric_id, secondary_metrics$label), selected = "air_temperature" ), radioButtons( inputId = "metric_view_mode", label = "Second panel display", choices = c( "Raw observations" = "raw", "Daily aggregate" = "daily" ), selected = "raw" ), uiOutput("syncControls"), div( class = "status-block", verbatimTextOutput("cacheStatus") ) ), mainPanel( width = 9, fluidRow( column( width = 6, div( class = "panel-card", h3(class = "panel-title", "Rain"), withSpinner(plotOutput("rainPlot", height = "420px")) ) ), column( width = 6, div( class = "panel-card", h3(class = "panel-title", textOutput("metricTitle", container = span)), withSpinner(plotOutput("metricPlot", height = "420px")), h4("Latest values by station"), tableOutput("metricLatest") ) ) ) ) ) ) server <- function(input, output, session) { api_headers <- load_api_headers() data_version <- reactiveVal(0L) last_sync_message <- reactiveVal("") selected_location <- reactive({ get_rain_location(input$location_id, locations = locations) }) selected_metric <- reactive({ get_weather_metric(input$metric_id) }) observeEvent(input$window_unit, { settings <- get_window_slider_config(input$window_unit) preferred_view <- get_preferred_window_view(input$window_unit) rain_choices <- get_rain_view_choices(input$window_unit) metric_choices <- get_metric_view_choices(input$window_unit) current_value <- if (is.null(input$window_amount)) { settings$value } else { as.integer(input$window_amount) } current_rain_view <- if (!is.null(input$rain_view_mode) && input$rain_view_mode %in% rain_choices) { input$rain_view_mode } else { preferred_view } current_metric_view <- if (!is.null(input$metric_view_mode) && input$metric_view_mode %in% metric_choices) { input$metric_view_mode } else { preferred_view } updateSliderInput( session = session, inputId = "window_amount", label = settings$label, min = 1, max = settings$max, value = min(max(current_value, 1L), settings$max), step = 1 ) updateRadioButtons( session = session, inputId = "rain_view_mode", choices = rain_choices, selected = current_rain_view ) updateRadioButtons( session = session, inputId = "metric_view_mode", choices = metric_choices, selected = current_metric_view ) }, ignoreInit = TRUE) selected_start_date <- reactive({ window_start_date( end_date = Sys.Date(), amount = input$window_amount, unit = input$window_unit ) }) selected_window_label <- reactive({ format_window_label( amount = input$window_amount, unit = input$window_unit ) }) selected_window_days <- reactive({ as.integer(Sys.Date() - selected_start_date()) + 1L }) cached_rain <- reactive({ data_version() query_cached_rainfall( location_id = input$location_id, start_date = selected_start_date(), end_date = Sys.Date(), aggregate = input$rain_view_mode, db_path = db_path ) }) cached_metric <- reactive({ data_version() query_cached_metric( location_id = input$location_id, metric_id = input$metric_id, start_date = selected_start_date(), end_date = Sys.Date(), aggregate = input$metric_view_mode, db_path = db_path ) }) metric_latest <- reactive({ data_version() query_latest_metric_values( location_id = input$location_id, metric_id = input$metric_id, db_path = db_path ) }) output$metricTitle <- renderText({ selected_metric()$label }) output$syncControls <- renderUI({ if (is.null(api_headers)) { return( div( class = "help-block", helpText( "This app is reading the local SQLite cache only. Add token4 to data/secrets and run", "`Rscript scripts/update_rain_db.R`", "to refresh rain plus the second-panel weather metrics." ), helpText( "Rain can be backfilled. Temperature, humidity, wind and pressure come from the rolling observation feed, so sync that script daily if you want a continuous history." ) ) ) } tagList( actionButton("sync_now", "Sync location from API"), div( class = "help-block", helpText( "This refresh pulls historical rain plus the latest station observations into the same SQLite dataset." ) ) ) }) observeEvent(input$sync_now, { req(!is.null(api_headers)) location <- selected_location() result <- tryCatch( withProgress( message = sprintf("Syncing %s into SQLite", location$label[1]), value = 0.3, { sync_location_weather( location_id = input$location_id, db_path = db_path, headers = api_headers, initial_backfill_days = max(21L, selected_window_days() + 7L) ) } ), error = function(error) { last_sync_message( sprintf("Last sync failed: %s", conditionMessage(error)) ) NULL } ) if (is.null(result)) { return() } latest_observed_at <- result$latest_observed_at[1] if (is.na(latest_observed_at) || !nzchar(latest_observed_at)) { latest_observed_at <- "no data returned" } last_sync_message( sprintf( paste( "Last sync: %s rows written", "(rain %s, observations %s).", "Cache now reaches %s." ), format(result$rows_written[1], big.mark = ","), format(result$rain_rows_written[1], big.mark = ","), format(result$observation_rows_written[1], big.mark = ","), latest_observed_at ) ) data_version(data_version() + 1L) }) output$cacheStatus <- renderText({ data_version() status_text <- describe_cache_status( location_id = input$location_id, db_path = db_path, locations = locations ) if (!nzchar(last_sync_message())) { return(status_text) } paste(status_text, last_sync_message(), sep = "\n\n") }) output$rainPlot <- renderPlot({ plot_data <- cached_rain() shiny::validate( shiny::need( nrow(plot_data) > 0, "No cached rainfall for this period yet. Run the sync script or use the API sync button if credentials are configured." ) ) if (input$hide_zero) { plot_data <- plot_data[ is.na(plot_data$rain_mm) | plot_data$rain_mm > 0, , drop = FALSE ] } shiny::validate( shiny::need( nrow(plot_data) > 0, "No non-zero rainfall in this window. Untick 'Hide zero rainfall' if you want to inspect dry periods too." ) ) plot_cached_rainfall( rain_data = plot_data, view = input$rain_view_mode, hide_zero = FALSE, main = sprintf( "%s - %s", selected_location()$label[1], selected_window_label() ) ) }) output$metricPlot <- renderPlot({ plot_data <- cached_metric() metric <- selected_metric() shiny::validate( shiny::need( nrow(plot_data) > 0, sprintf( "No cached %s data for this window yet. Run the sync script more frequently if you want a continuous history for that metric.", tolower(metric$label) ) ) ) plot_cached_metric( metric_data = plot_data, metric_id = input$metric_id, view = input$metric_view_mode, main = sprintf( "%s - %s - %s", selected_location()$label[1], metric$label, selected_window_label() ) ) }) output$metricLatest <- renderTable({ latest_data <- metric_latest() if (!nrow(latest_data)) { return(NULL) } names(latest_data) <- c("Station ID", "Station", "Observed At", "Metric", "Label", "Unit", "Value") latest_data[, c("Station", "Observed At", "Value", "Unit")] }, striped = TRUE, spacing = "s", digits = 2) } shinyApp(ui = ui, server = server)