hurricane_normalization_app/app/server.R

server <- function(input, output, session) {
  output$base_leaflet <- renderLeaflet({
    leaflet() %>%
      addProviderTiles("Stadia.AlidadeSmooth")
  })

  storm_coverage <- get_storm_data_coverage() %>%
    select(-storm_basin) %>%
    {
      col_names <- names(.)
      mutate(
        .,
        data = trimws(paste(
          "<span class=\"badge bg-primary\">HURDAT2</span>",
          ifelse(
            as.logical(.data[[col_names[3]]]),
            "<span class=\"badge bg-danger\">Fatality</span>",
            ""
          ),
          ifelse(
            as.logical(.data[[col_names[4]]]),
            "<span class=\"badge bg-success\">Cost</span>",
            ""
          )
        ))
      ) %>%
        select(1, 2, data)
    }

  output$storm_coverage_table <- renderDT({
    datatable(
      storm_coverage,
      fillContainer = TRUE,
      rownames = F,
      escape = F,
      colnames = c("Year", "Name", "Data"),
      selection = "single",
      options = list(
        pageLength = 1000,
        order = list(0, 'desc'),
        searching = F,
        paging = F,
        info = F,
        lengthChange = F
      )
    )
  })

  dt_storm_selected <- reactive({
    req(input$storm_coverage_table_rows_selected)
    storm_coverage[input$storm_coverage_table_rows_selected, ]
  })

  output$dt_storm_name_year <- renderText({
    paste0(
      dt_storm_selected()$storm_name,
      " (",
      dt_storm_selected()$storm_year,
      ")"
    )
  })

  output$selected_storm_name_year <- renderText({
    if (is.null(storm_selection$storm_name)) {
      "Select a storm"
    } else {
      paste0(
        storm_selection$storm_name,
        " (",
        storm_selection$storm_year,
        ")"
      )
    }
  })

  observe({
    req(
      storm_selection$storm_basin,
      storm_selection$storm_year,
      storm_selection$storm_name
    )

    unique_lfs <- get_unique_lf_ids(storm_selection)

    updateVirtualSelect(
      session = session,
      "storm_overview_cost_index_lf_select",
      choices = prepare_choices(unique_lfs, full_lf_id, full_lf_id, lf_type),
      selected = unique_lfs$full_lf_id[1]
    )

    updateSelectInput(
      session,
      "growth_trend_lf_select",
      choices = unique_lfs$full_lf_id,
      selected = unique_lfs$full_lf_id[1]
    )
  })

  observeEvent(input$load_storm, {
    storm_selection$storm_basin <- "AL"
    storm_selection$storm_year <- dt_storm_selected()$storm_year
    storm_selection$storm_name <- dt_storm_selected()$storm_name

    hurdatid <- get_hurdat_id(storm_selection)
    storm_selection$hurdatid = hurdatid$hurdatid

    selected_storm <-
      paste0(
        dt_storm_selected()$storm_name,
        " (",
        dt_storm_selected()$storm_year,
        ")"
      )

    nav_select("main_navbar", "Storm Explorer")
  })

  output$all_storms_map <- renderLeaflet({
    leaflet() %>%
      addProviderTiles("Stadia.AlidadeSmooth") %>%
      addCircleMarkers(
        data = all_conus_landfalls,
        lng = ~lon,
        lat = ~lat,
        radius = 2,
        popup = ~ paste0(storm_name, " ", storm_year),
        weight = 0,
        color = "blue",
        fillColor = "blue",
        fillOpacity = 0.5
      ) %>%
      addCircles(
        data = all_conus_landfalls,
        lng = ~lon,
        lat = ~lat,
        radius = ~rmw_meters,
        popup = ~ paste0(storm_name, " ", storm_year),
        weight = 1,
        color = "blue",
        fillColor = "blue",
        fillOpacity = 0.05
      )
  })

  storm_track <- reactive({
    req(
      storm_selection$storm_basin,
      storm_selection$storm_year,
      storm_selection$storm_name
    )
    result <- get_hurdat_track(storm_selection)

    # HURDAT storm status
    # TD – Tropical cyclone of tropical depression intensity (< 34 knots)
    # TS – Tropical cyclone of tropical storm intensity (34-63 knots)
    # HU – Tropical cyclone of hurricane intensity (> 64 knots)
    # EX – Extratropical cyclone (of any intensity)
    # SD – Subtropical cyclone of subtropical depression intensity (< 34 knots)
    # SS – Subtropical cyclone of subtropical storm intensity (> 34 knots)
    # LO – A low that is neither a tropical cyclone, a subtropical cyclone, nor an extratropical cyclone (of any intensity)
    # WV – Tropical Wave (of any intensity)
    # DB – Disturbance (of any intensity)

    # Line Color          Storm Type                Status    Pressure (mb) Wind (mph)  Wind (knots)
    # Blue	              Subtropical Depression	  SD        --	          <=38 	      <=33
    # Light Blue	        Subtropical Storm	        SS        --	          39-73	      34-63
    # Green	              Tropical Depression (TD)	TD        --	          <=38	      <=33
    # Yellow	            Tropical Storm (TS)	      TS        980+	        39-73	      34-63
    # Red	                Hurricane (Cat 1)	        HU        <=980	        74-95	      64-82
    # Pink	              Hurricane (Cat 2)	        HU        965-980	      96-110	    83-95
    # Magenta	            Major Hurricane (Cat 3)	  HU        945-965	      111-129	    96-112
    # Purple	            Major Hurricane (Cat 4)	  HU        920-945	      130-156	    113-136
    # White	              Major Hurricane (Cat 5)	  HU        <=920	        157+	      137+
    # Green dashed (- -)  Wave/Low/Disturbance	    WV/LO/DB  --	          --	        --
    # Black hatched (++)  Extratropical Cyclone	    EX        --	          --	        --

    # Category  Sustained Windspeed (knots)
    # 1         64-82
    # 2         83-95
    # 3         96-112
    # 4         113-136
    # 5         137+

    # Preprocess the track data with colors
    result <- result %>%
      mutate(
        hurricane_category = case_when(
          # Hurricane Cat 1
          storm_status == "HU" & windspeed >= 64 & windspeed <= 82 ~ 1,

          # Hurricane Cat 2
          storm_status == "HU" & windspeed >= 83 & windspeed <= 95 ~ 2,

          # Hurricane Cat 3
          storm_status == "HU" & windspeed >= 96 & windspeed <= 112 ~ 3,

          # Hurricane Cat 4
          storm_status == "HU" & windspeed >= 113 & windspeed <= 136 ~ 4,

          # Hurricane Cate 5
          storm_status == "HU" & windspeed >= 137 ~ 5,
        ),
        line_color = case_when(
          # Tropical Depression - Green
          storm_status == "TD" ~ "#2AFF00",

          # Tropical Storm - Yellow
          storm_status == "TS" ~ "#FFD020",

          # Hurricane Cat 1 - Red
          hurricane_category == 1 ~ "#FF4343",

          # Hurricane Cat 2 - Pink
          hurricane_category == 2 ~ "#FF6FFF",

          # Hurricane Cat 3 - Magenta
          hurricane_category == 3 ~ "#FF23D3",

          # Hurricane Cat 4 - Purple
          hurricane_category == 4 ~ "#C916FF",

          # Hurricane Cate 5 - White
          hurricane_category == 5 ~ "#FFFFFF",

          # Extratropical Cyclone
          storm_status == "EX" ~ "#202020",

          # Subtropical Depression
          storm_status == "SD" ~ "#0055FF",

          # Subtropical Storm
          storm_status == "SS" ~ "#6CE2FF",

          # Low
          storm_status == "LO" ~ "#A1A1A1",

          # Wave
          storm_status == "WV" ~ "#A1A1A1",

          # Disturbance
          storm_status == "DB" ~ "#A1A1A1",

          # Missing
          TRUE ~ "#FF5C00"
        ),
        popup_category = case_when(
          storm_status == "TD" ~ "TD",
          storm_status == "TS" ~ "TS",
          hurricane_category == 1 ~ "H1",
          hurricane_category == 2 ~ "H2",
          hurricane_category == 3 ~ "H3",
          hurricane_category == 4 ~ "H4",
          hurricane_category == 5 ~ "H5",
          storm_status == "EX" ~ "EX",
          storm_status == "SD" ~ "SD",
          storm_status == "SS" ~ "SS",
          storm_status == "LO" ~ "LO",
          storm_status == "WV" ~ "WV",
          storm_status == "DB" ~ "DB",
          TRUE ~ "NA"
        )
      ) %>%
      arrange(datetime)

    return(result)
  }) %>%
    bindCache(
      storm_selection$storm_year,
      storm_selection$storm_name,
      storm_selection$storm_basin
    )

  output$track_map <- renderLeaflet({
    track_data <- storm_track()

    map <- leaflet() %>%
      addProviderTiles("Stadia.AlidadeSmooth") %>%
      fitBounds(
        lng1 = min(track_data$lon),
        lng2 = max(track_data$lon),
        lat1 = min(track_data$lat),
        lat2 = max(track_data$lat)
      )

    map <- map %>%
      leaflet::addLegend(
        position = "bottomleft",
        colors = c(
          "#2AFF00", # TD
          "#FFD020", # TS
          "#FF4343", # Cat 1
          "#FF6FFF", # Cat 2
          "#FF23D3", # Cat 3
          "#C916FF", # Cat 4
          "#FFFFFF", # Cat 5
          "#202020", # EX
          "#0055FF", # SD
          "#6CE2FF", # SS
          "#A1A1A1", # LO/WV/DB
          "#FF5C00" # Missing
        ),
        labels = c(
          "Tropical Depression (TD)",
          "Tropical Storm (TS)",
          "Hurricane Category 1",
          "Hurricane Category 2",
          "Hurricane Category 3",
          "Hurricane Category 4",
          "Hurricane Category 5",
          "Extratropical Cyclone (EX)",
          "Subtropical Depression (SD)",
          "Subtropical Storm (SS)",
          "Low/Wave/Disturbance (LO/WV/DB)",
          "Missing Data"
        ),
        opacity = 1,
        title = "Track Legend"
      )

    if (nrow(track_data) >= 2) {
      for (i in 1:(nrow(track_data) - 1)) {
        segment_data <- track_data[i:(i + 1), ]

        map <- map %>%
          addPolylines(
            data = segment_data,
            lng = ~lon,
            lat = ~lat,
            weight = 2,
            color = track_data$line_color[i],
            opacity = 1
          )
      }
    }

    map <- map %>%
      addCircleMarkers(
        data = track_data,
        lng = ~lon,
        lat = ~lat,
        radius = 2,
        color = ~line_color,
        fillOpacity = 1,
        popup = ~ paste0(
          "<b>DATE</b>",
          "<br>",
          datetime,
          "<br>",
          "<b>CATEGORY</b>",
          "<br>",
          popup_category,
          "<br>",
          "<b>WINDSPEED</b>",
          "<br>",
          windspeed,
          "kt",
          "<br>",
          "<b>PRESSURE</b>",
          "<br>",
          pressure,
          "mb"
        )
      )

    landfall_data <- track_data %>%
      filter(record_identifier == "L")

    if (nrow(landfall_data) > 0) {
      map <- map %>%
        addCircleMarkers(
          data = landfall_data,
          lng = ~lon,
          lat = ~lat,
          radius = 5,
          weight = 0,
          color = ~line_color,
          fillColor = ~line_color,
          fillOpacity = 1,
          popup = ~ paste0(
            "<b>LANDFALL</b>",
            "<br>",
            "<b>DATE</b>",
            "<br>",
            datetime,
            "<br>",
            "<b>CATEGORY</b>",
            "<br>",
            popup_category,
            "<br>",
            "<b>WINDSPEED</b>",
            "<br>",
            windspeed,
            "kt",
            "<br>",
            "<b>PRESSURE</b>",
            "<br>",
            pressure,
            "mb",
            "<br>",
            "<b>RMW</b>",
            "<br>",
            rmw,
            "nm"
          )
        ) %>%
        addCircles(
          data = landfall_data,
          lng = ~lon,
          lat = ~lat,
          radius = ~rmw_meters,
          weight = 2,
          color = ~line_color,
          fillColor = ~line_color,
          fillOpacity = 0.3,
          popup = ~ paste0(
            "<b>LANDFALL</b>",
            "<br>",
            "<b>DATE</b>",
            "<br>",
            datetime,
            "<br>",
            "<b>CATEGORY</b>",
            "<br>",
            popup_category,
            "<br>",
            "<b>WINDSPEED</b>",
            "<br>",
            windspeed,
            "kt",
            "<br>",
            "<b>PRESSURE</b>",
            "<br>",
            pressure,
            "mb",
            "<br>",
            "<b>RMW</b>",
            "<br>",
            rmw,
            "nm"
          )
        )
    }

    return(map)
  })

  output$track_data <- renderDT({
    datatable(
      fillContainer = TRUE,
      storm_track() %>%
        select(
          formatted_datetime,
          storm_status,
          lon,
          lat,
          rmw,
          pressure,
          windspeed
        ),
      rownames = F,
      colnames = c(
        "Date",
        "Status",
        "Lon",
        "Lat",
        "RMW",
        "Pressure",
        "Windspeed"
      ),
      selection = "none",
      options = list(
        pageLength = 1000,
        order = list(0, 'asc'),
        searching = F,
        paging = F,
        info = F,
        lengthChange = F,
        server = T
      )
    )
  })

  storm_yearly_normalization <- reactive({
    req(
      storm_selection$storm_basin,
      storm_selection$storm_year,
      storm_selection$storm_name
    )

    result <- get_all_normalized_cost_index(storm_selection)

    return(result)
  }) %>%
    bindCache(
      storm_selection$storm_year,
      storm_selection$storm_name,
      storm_selection$storm_basin
    )

  output$cost_index_chart <- renderDygraph({
    req(
      storm_yearly_normalization(),
      input$storm_overview_cost_index_lf_select,
      input$storm_overview_cost_index_mmh_mmp,
      input$storm_overview_cost_index_scale,
      input$storm_overview_cost_index_y_scale
    )

    if (input$storm_overview_cost_index_y_scale == "Log") {
      is_y_log <- T
    } else {
      is_y_log <- F
    }

    normalized_data <- storm_yearly_normalization() %>%
      rename(
        "MMH Index" = mmh_index,
        "MMH Loss" = mmh_loss,
        "MMP Index" = mmp_index,
        "MMP Loss" = mmp_loss
      )

    selected_lf <- input$storm_overview_cost_index_lf_select
    selected_normalization <- input$storm_overview_cost_index_mmh_mmp
    selected_scale <- input$storm_overview_cost_index_scale

    method_map <- c("MMH", "MMP")
    selected_methods <- method_map[method_map %in% selected_normalization]

    if (selected_scale == "Index") {
      value_columns <- paste0(selected_methods, " Index")

      y_label <- "Cost Index"
    } else if (selected_scale == "Loss") {
      value_columns <- paste0(selected_methods, " Loss")

      y_label <- "Normalized Loss"
    }

    normalization_index <- normalized_data %>%
      filter(
        full_lf_id %in% selected_lf
      ) %>%
      mutate(
        normalization_year = as.Date(paste0(normalization_year, "-01-01"))
      ) %>%
      select(
        normalization_year,
        full_lf_id,
        all_of(value_columns)
      ) %>%
      pivot_wider(
        names_from = full_lf_id,
        values_from = all_of(value_columns),
        names_glue = "{full_lf_id} {.value}"
      )

    normalization_index_ts <- normalization_index %>%
      select(-normalization_year) %>%
      xts(order.by = normalization_index$normalization_year)

    dygraph(normalization_index_ts, ylab = y_label) %>%
      dyOptions(
        colors = paletteer_d(
          "ggthemes::Classic_Purple_Gray_12",
          ncol(normalization_index - 1)
        ),
        fillGraph = T,
        fillAlpha = .2,
        labelsKMB = T,
        logscale = is_y_log
      ) %>%
      dyAxis("x", drawGrid = F) %>%
      dyLegend(show = "always", width = 400, hideOnMouseOut = FALSE) %>%
      dyRangeSelector()
  }) %>%
    bindCache(
      storm_selection$storm_year,
      storm_selection$storm_name,
      storm_selection$storm_basin,
      input$storm_overview_cost_index_lf_select,
      input$storm_overview_cost_index_mmh_mmp,
      input$storm_overview_cost_index_scale,
      input$storm_overview_cost_index_y_scale
    )

  observe({
    req(
      storm_selection$storm_basin,
      storm_selection$storm_year,
      storm_selection$storm_name
    )

    updateSliderInput(
      session,
      "growth_trend_map_slider",
      min = storm_selection$storm_year,
      value = storm_selection$storm_year
    )
  })

  growth_counties <- reactive({
    req(
      storm_selection$storm_basin,
      storm_selection$storm_year,
      storm_selection$storm_name,
      input$growth_trend_lf_select
    )

    selected_lf <- input$growth_trend_lf_select

    counties <- get_normalized_metric_growth(storm_selection, selected_lf)

    result <- counties %>%
      #filter(year == 2024) %>%
      mutate(
        population_opacity = rescale(
          normalized_population,
          to = c(0.2, 0.8),
          from = range(normalized_population, na.rm = T)
        ),
        housing_opacity = rescale(
          normalized_housing,
          to = c(0.2, 0.8),
          from = range(normalized_housing, na.rm = T)
        )
      ) %>%
      st_as_sf(wkt = "geom_wkt")

    return(result)
  }) %>%
    bindCache(
      storm_selection$storm_year,
      storm_selection$storm_name,
      storm_selection$storm_basin,
      input$growth_trend_lf_select
    )

  output$growth_map <- renderLeaflet({
    leaflet() %>%
      addProviderTiles("Stadia.AlidadeSmooth")
  })

  observe({
    req(growth_counties())

    counties_data <- growth_counties()
    combined_geom <- st_union(counties_data)
    growth_bbox <- st_bbox(combined_geom)

    leafletProxy("growth_map") %>%
      fitBounds(
        lng1 = growth_bbox[["xmin"]],
        lng2 = growth_bbox[["xmax"]],
        lat1 = growth_bbox[["ymin"]],
        lat2 = growth_bbox[["ymax"]]
      )
  })

  observe({
    req(
      growth_counties(),
      input$growth_trend_map_slider,
      input$growth_map_metric
    )

    growth_year <- input$growth_trend_map_slider

    growth_county_year <- growth_counties() %>%
      filter(
        year == growth_year
      )

    if (input$growth_map_metric == "Population") {
      leafletProxy("growth_map", data = growth_county_year) %>%
        clearGroup("counties") %>%
        addPolygons(
          group = "counties",
          fillColor = "red",
          color = "red",
          fillOpacity = ~population_opacity,
          weight = 1,
          popup = ~name
        )
    } else {
      leafletProxy("growth_map", data = growth_county_year) %>%
        clearGroup("counties") %>%
        addPolygons(
          group = "counties",
          fillColor = "blue",
          color = "blue",
          fillOpacity = ~housing_opacity,
          weight = 1,
          popup = ~name
        )
    }
  })
}