+ Shiny app with slider map and init ts plot

app/functions.R

@@ -0,0 +1,80 @@
+get_prism_r <- function(dates, var){  # dates = dates_then
+  d <- d_prism_r |>
+    filter(
+      date     %in% !!dates,
+      variable  ==  !!var) |>
+    select(path_tif, lyr)
+
+  rast(unique(d$path_tif)) |>
+    subset(d$lyr) |>
+    mean() |>
+    project(leaflet:::epsg3857)
+}
+
+get_sst_r <- function(dates){  # dates = dates_then
+  lyrs <- d_sst_r |>
+    filter(
+      date %in% !!dates) |>
+    pull(lyr)
+
+  r_sst |>
+    subset(lyrs) |>
+    mean() |>
+    project(leaflet:::epsg3857)
+}
+
+map_then_now <- function(
+    r_then,
+    r_now,
+    tiles = providers$CartoDB.DarkMatter,
+    lgnd_then,
+    lgnd_now,
+    var_lbl,
+    palette     = "Spectral",
+    palette_rev = TRUE){
+
+  vals <- c(values(r_now, na.rm=T), values(r_then, na.rm=T))
+  pal  <- colorNumeric(
+    palette, vals, reverse = palette_rev, na.color = "transparent")
+
+  leaflet() |>
+    addMapPane("left",  zIndex = 0) |>
+    addMapPane("right", zIndex = 0) |>
+    addProviderTiles(
+      tiles,
+      options = pathOptions(pane = "left"),
+      group   = "base",
+      layerId = "base_l") |>
+    addProviderTiles(
+      tiles,
+      options = pathOptions(pane = "right"),
+      group   = "base",
+      layerId = "base_r") |>
+    addRasterImage(
+      r_then, colors = pal, opacity = 0.8, project = F,
+      options = leafletOptions(pane = "left"),
+      group = "r_then") |>
+    addRasterImage(
+      r_now, colors = pal, opacity = 0.8, project = F,
+      options = leafletOptions(pane = "right"),
+      group = "r_now") |>
+    addLayersControl(overlayGroups = c("r_then", "r_now")) |>
+    addSidebyside(
+      layerId = "sidecontrols",
+      leftId  = "base_l",
+      rightId = "base_r") |>
+    addControl(
+      HTML(lgnd_then),
+      position = "topleft") |>
+    addControl(
+      HTML(lgnd_now),
+      position = "topright") |>
+    addPolygons(
+      data = tbeptools::tbsegshed,
+      # label = ~long_name,
+      color="white", weight = 2, fillOpacity=0) |>
+    addLegend(
+      pal    = pal,
+      values = vals,
+      title  = var_lbl)
+}

app/global.R

@@ -0,0 +1,45 @@
+# TODO:
+# - [ ] style ggplotly https://rstudio.github.io/thematic/#shiny
+# - [ ] show sources for prism, sst, etc with About and links per card
+# - [ ] convert prism units: ºC -> ºF, mm -> in
+# - [ ] sel_t_var implement in map_prism_temp w/ avg
+# - [ ] swiper maps: precipitation, ocean temperature
+# - [ ] temp: heat index using dewpoint (`tdmean` -> humidity)
+# - [ ] prism: show `version`, `date_updated`
+# - [ ] swiper maps: leaflet-proxy-map updates to layers so can zoom / pan without refresh
+# - [ ] time series cards / panels
+
+# devtools::install_local(here("../tbeptools"), force = T)
+# devtools::load_all(here::here("../tbeptools"))
+librarian::shelf(
+  bsicons, bslib, dplyr, glue, here, leaflet, leaflet.extras2, lubridate, plotly,
+  readr, scales, shiny, slider,
+  tbep-tech/tbeptools,
+  terra, thematic, tidyr)
+source(here("app/functions.R"))
+options(readr.show_col_types = F)
+
+light <- bs_theme(preset = "flatly")
+dark  <- bs_theme(preset = "darkly")
+
+dir_prism <- here("data/prism")
+prism_csv <- here("data/prism.csv")
+sst_tif   <- here("data/sst/tb_sst.tif")
+sst_csv   <- here("data/sst/tb_sst.csv")
+
+d_prism_r <- read_prism_rasters(dir_prism)
+yrs_prism <- range(year(d_prism_r$date))
+now_prism <- max(d_prism_r$date)
+d_prism_z <- read_csv(prism_csv)
+
+r_sst <- rast(sst_tif)
+d_sst_r <- tibble(
+  lyr = names(r_sst)) |>
+  separate(lyr, c("var", "date"), sep = "\\|", remove = F) |>
+  mutate(
+    date = as.Date(date))
+yrs_sst <- range(year(d_sst_r$date))
+now_sst <- max(d_sst_r$date)
+d_sst_z <- read_csv(sst_csv) |>
+  mutate(
+    date = as.Date(time))

app/server.R

@@ -0,0 +1,230 @@
+function(input, output, session) {
+
+  # dark_mode ----
+  observe(session$setCurrentTheme(
+    if (isTRUE(input$dark_mode)) dark else light ))
+
+  # map_prism_temp ----
+  output$map_prism_temp <- renderLeaflet({
+
+    # DEBUG
+    # input <- list(
+    #   sld_md       = as.Date("2024-07-22"),
+    #   sld_yrs_now  = c(2024, 2024),
+    #   sld_yrs_then = c(1981, 2001))
+
+    var        = "tmax"
+    var_lbl    = "Temperature (°C)"
+    md         = sprintf("%02d-%02d", month(input$sld_t_md), day(input$sld_t_md))
+    yrs_now    = input$sld_t_yrs_now[1]:input$sld_t_yrs_now[2]
+    yrs_then   = input$sld_t_yrs_then[1]:input$sld_t_yrs_then[2]
+    dates_now  = as.Date(glue("{yrs_now}-{md}"))
+    dates_then = as.Date(glue("{yrs_then}-{md}"))
+
+    if (any(dates_now > now_prism))
+      dates_now[dates_now > now_prism] <- dates_now[dates_now > now_prism] - years(1)
+
+    yrs_now_rng  <- year(dates_now)
+    yrs_then_rng <- year(dates_then)
+    if (length(yrs_now_rng) > 2)
+      yrs_now_rng <- range(yrs_now_rng)
+    if (length(yrs_then_rng) > 2)
+      yrs_then_rng <- range(yrs_then_rng)
+
+    r_now  <- get_prism_r(dates_now,  var)
+    r_then <- get_prism_r(dates_then, var)
+
+    lgnd_now <- glue(
+      "<b>Now</b><br>
+          {format(input$sld_t_md, '%b %d')},
+          {paste(yrs_now_rng, collapse = ' to ')}")
+    lgnd_then <- glue(
+      "<b>Then</b><br>
+           {format(input$sld_t_md, '%b %d')},
+           {paste(yrs_then_rng, collapse = ' to ')}")
+
+    map_then_now(
+      r_then,
+      r_now,
+      tiles = ifelse(
+        isTRUE(input$dark_mode),
+        providers$CartoDB.DarkMatter,
+        providers$CartoDB.Positron),
+      lgnd_then,
+      lgnd_now,
+      var_lbl)
+
+  })
+
+  # map_prism_rain ----
+  output$map_prism_ppt <- renderLeaflet({
+
+    # DEBUG
+    # input <- list(
+    #   sld_md       = as.Date("2024-07-22"),
+    #   sld_yrs_now  = c(2024, 2024),
+    #   sld_yrs_then = c(1981, 2001))
+
+    var        = "ppt"
+    var_lbl    = "Rain (mm)"
+    md         = sprintf("%02d-%02d", month(input$sld_p_md), day(input$sld_p_md))
+    yrs_now    = input$sld_p_yrs_now[1]:input$sld_p_yrs_now[2]
+    yrs_then   = input$sld_p_yrs_then[1]:input$sld_p_yrs_then[2]
+    dates_now  = as.Date(glue("{yrs_now}-{md}"))
+    dates_then = as.Date(glue("{yrs_then}-{md}"))
+
+    if (any(dates_now > now_prism))
+      dates_now[dates_now > now_prism] <- dates_now[dates_now > now_prism] - years(1)
+
+    yrs_now_rng  <- year(dates_now)
+    yrs_then_rng <- year(dates_then)
+    if (length(yrs_now_rng) > 2)
+      yrs_now_rng <- range(yrs_now_rng)
+    if (length(yrs_then_rng) > 2)
+      yrs_then_rng <- range(yrs_then_rng)
+
+    r_now  <- get_prism_r(dates_now,  var)
+    r_then <- get_prism_r(dates_then, var)
+
+    lgnd_now <- glue(
+      "<b>Now</b><br>
+          {format(input$sld_p_md, '%b %d')},
+          {paste(yrs_now_rng, collapse = ' to ')}")
+    lgnd_then <- glue(
+      "<b>Then</b><br>
+           {format(input$sld_p_md, '%b %d')},
+           {paste(yrs_then_rng, collapse = ' to ')}")
+
+    map_then_now(
+      r_then,
+      r_now,
+      tiles = ifelse(
+        isTRUE(input$dark_mode),
+        providers$CartoDB.DarkMatter,
+        providers$CartoDB.Positron),
+      lgnd_then,
+      lgnd_now,
+      var_lbl,
+      palette     = "Blues",
+      palette_rev = F)
+
+  })
+
+  # map_sst ----
+  output$map_sst <- renderLeaflet({
+
+    # DEBUG
+    # input <- list(
+    #   sld_o_md       = as.Date("2024-07-22"),
+    #   sld_o_yrs_now  = c(2024, 2024),
+    #   sld_o_yrs_then = c(1981, 2001))
+
+    var_lbl    = "Sea Surface Temperature (°C)"
+    md         = sprintf("%02d-%02d", month(input$sld_o_md), day(input$sld_o_md))
+    yrs_now    = input$sld_o_yrs_now[1]:input$sld_o_yrs_now[2]
+    yrs_then   = input$sld_o_yrs_then[1]:input$sld_o_yrs_then[2]
+    dates_now  = as.Date(glue("{yrs_now}-{md}"))
+    dates_then = as.Date(glue("{yrs_then}-{md}"))
+
+    if (any(dates_now > now_sst))
+      dates_now[dates_now > now_sst] <- dates_now[dates_now > now_sst] - years(1)
+
+    yrs_now_rng  <- year(dates_now)
+    yrs_then_rng <- year(dates_then)
+    if (length(yrs_now_rng) > 2)
+      yrs_now_rng <- range(yrs_now_rng)
+    if (length(yrs_then_rng) > 2)
+      yrs_then_rng <- range(yrs_then_rng)
+
+    r_now  <- get_sst_r(dates_now)
+    r_then <- get_sst_r(dates_then)
+
+    lgnd_now <- glue(
+      "<b>Now</b><br>
+          {format(input$sld_o_md, '%b %d')},
+          {paste(yrs_now_rng, collapse = ' to ')}")
+    lgnd_then <- glue(
+      "<b>Then</b><br>
+           {format(input$sld_o_md, '%b %d')},
+           {paste(yrs_then_rng, collapse = ' to ')}")
+
+    map_then_now(
+      r_then,
+      r_now,
+      tiles = ifelse(
+        isTRUE(input$dark_mode),
+        providers$CartoDB.DarkMatter,
+        providers$CartoDB.Positron),
+      lgnd_then,
+      lgnd_now,
+      var_lbl)
+
+  })
+
+  # plot_sst ----
+  output$plot_sst <- plotly::renderPlotly({
+
+    bay_segment <- "BCB"
+
+    d <- d_sst_z |>
+      filter(bay_segment == !!bay_segment) |>
+      mutate(
+        year  = year(time),
+        date  = sprintf(
+          "%d-%02d-%02d",
+          year(today()), month(time), day(time) ) |>
+          as.POSIXct(),
+        color = case_when(
+          year == year(today())     ~ "red",
+          year == year(today()) - 1 ~ "orange",
+          .default = "gray") ) |>
+      select(time, year, date, color, val) |>
+      arrange(year, date, val)
+
+    yrs    <- as.character(unique(d$year))
+    colors <- setNames(rep("darkgray", length(yrs)), yrs)
+    colors[as.character(year(today()))]     <- "red"
+    colors[as.character(year(today()) - 1)] <- "orange"
+
+    d <- d |>
+      group_by(year) |>
+      mutate(
+        val_sl = slider::slide_mean(
+          val, before = 3L, after = 3L, step = 1L,
+          complete = F, na_rm = T),
+        txt_date = as.Date(time),
+        txt_val  = round(val_sl, 2) ) |>
+      select(-time) |>
+      ungroup()
+
+    # TODO: darkly theme w/ bslib
+    g <- ggplot(
+      d,
+      aes(
+        x     = date,
+        y     = val_sl,
+        group = year,
+        color = factor(year),
+        date  = txt_date,
+        value = txt_val)) +  # frame = yday
+      geom_line(
+        # aes(text  = text),
+        alpha = 0.6) +
+      scale_colour_manual(
+        values = colors) +
+      theme(legend.position = "none") +
+      scale_x_datetime(
+        labels = date_format("%b %d")) +
+      labs(
+        x = "Day of year",
+        y = "Temperature ºC")
+    g
+    # x, y, alpha, color, group, linetype, size
+
+    # add color theming
+    # https://rstudio.github.io/thematic/articles/auto.html
+
+    ggplotly(g, tooltip=c("date","value"))
+  })
+
+}