inst/visualize_map_output/server.R

In HYPEtools: Tools for Processing and Analyzing Files from the Hydrological Catchment Model HYPE

#' Shiny app server function
#' 
#' @param input provided by shiny
#' @param output provided by shiny
#' @param session provided by shiny

# Import required dependencies
require(dplyr)

# Get values passed to app
results.dir <- shiny::getShinyOption("results.dir")
file.pattern <- shiny::getShinyOption("file.pattern")
map <- shiny::getShinyOption("map")
map.subid.column <- shiny::getShinyOption("map.subid.column")
output.dir <- shiny::getShinyOption("output.dir")

# Define server logic
shinyAppServer <- function(input, output, session) {
  
  # _____________________________________________________________________________________________________________________________________
  # Help Buttons #####
  # _____________________________________________________________________________________________________________________________________
  
  # Help message for selecting GIS File
  shiny::observeEvent(input$help_gis, {
    shinyalert::shinyalert(
      title = "Select GIS File:",
      type = "info",
      text = 'Use the button to select a GIS file (.shp or .gpkg) containing the polygon geometry of the model subbasins. Then, use the dropdown menu to select the name of the column containing the subbasin SUBIDs.
      
      If "Join Status: CHECK" is displayed, then the MapOutput file was joined to the GIS data, but there may be duplicate SUBIDS in the selected SUBID column or other potential problems that require checking. Ensure that the correct SUBID column is selected.
      
      If Join Status: FAIL" is displayed, then the MapOutput file could not be joined to the GIS data using the selected SUBID column, and a different column should be selected.'
    )
  })
  
  # Help message for selecting mapoutput files
  shiny::observeEvent(input$help_result, {
    shinyalert::shinyalert(
      title = "Select MapOutput Files:",
      type = "info",
      text = 'Use the button to select the HYPE MapOutput files (.txt or .csv) that should be imported. Multiple files may be selected at one time. Use the dropdown menu to select the name of file that should be visualized.'
    )
  })
  
  # Help message for selecting time period
  shiny::observeEvent(input$help_slider, {
    shinyalert::shinyalert(
      title = "Select Time Period:",
      type = "info",
      text = 'Use the slider to select the time period in the MapOutput file that should be visualized. The "play" button can be used to animate the visualizations by stepping through the time periods automatically.'
    )
  })
  
  # Help message for output directory
  shiny::observeEvent(input$help_options, {
    shinyalert::shinyalert(
      title = "Options:",
      type = "info",
      text = 'Use the button to select the output directory for saved map images.'
    )
  })
  
  # Help message for GIS data table
  shiny::observeEvent(input$help_gis_df, {
    shinyalert::shinyalert(
      title = "GIS Data:",
      type = "info",
      text = 'This table displays the attribute table for the selected GIS file. Columns can be sorted and filtered. If the GIS data has been successfully joined to the MapOutput data (Join Status: CHECK or PASS), then filters applied to this table will also filter the data displayed in the "MapOutput Data" table and the boxplot.'
    )
  })
  
  # Help message for MapOutput data table
  shiny::observeEvent(input$help_data_df, {
    shinyalert::shinyalert(
      title = "MapOutput Data:",
      type = "info",
      text = 'This table displays the data for the selected MapOutput file. Columns can be sorted and filtered. Filters applied to this table do not affect the other outputs. However, if the MapOutput data has been successfully joined to the GIS data (Join Status: CHECK or PASS), then filters applied to the "GIS Data" table will also filter the data displayed in this table. If the GIS Data table filters are set such that all SUBIDs are excluded, then the table will reset to show all available MapOutput data.'
    )
  })
  
  # _____________________________________________________________________________________________________________________________________
  # File Management #####
  # _____________________________________________________________________________________________________________________________________
  
  # Get Available File Volumes
  volumes <- c("HYPEtools Demo Model" = system.file("demo_model", package = "HYPEtools"), Home = fs::path_home(), shinyFiles::getVolumes()())
  
  # Add Directories specified with shiny arguments
  if(!is.null(results.dir)){
    volumes <- c("Results Directory" = results.dir, volumes)
  }
  if(!is.null(map)){
    volumes <- c("GIS Directory" = dirname(map), volumes)
  }
  
  # Get Path to GIS Files
  gis_file <- shiny::reactive({
    shinyFiles::shinyFileChoose(input, "button_gis", roots = volumes, session = session)

    # If button hasn't been used to select files, then return default value/provided with shiny arguments
    if (!typeof(input$button_gis) == "list"){
      if(is.null(map)){
        files <- data.frame("Files" = character())
      } else{
        files <- data.frame("Files" = map)
      }
    } else{
      files <- data.frame("Files" = shinyFiles::parseFilePaths(volumes, input$button_gis)$datapath)
    }
  })

  # Get Paths to Results Files
  results_files <- shiny::reactive({
    shinyFiles::shinyFileChoose(input, "button_results", roots = volumes, session = session)

    # If button hasn't been used to select files, then return default value/provided with shiny arguments
    if (!typeof(input$button_results) == "list"){
      if(is.null(results.dir)){
        files <- data.frame("Files" = character())
      } else{
        files <- data.frame("Files" = list.files(results.dir, full.names = TRUE, pattern = file.pattern))
      }
    } else{
      files <- data.frame("Files" = shinyFiles::parseFilePaths(volumes, input$button_results)$datapath)
    }
  })
  
  # Input to select result file
  output$input_result <- shiny::renderUI({shiny::selectInput("result", "Select Result File To Display", choices = basename(results_files()$Files))})
  
  # Get selected result file
  result_file <- shiny::reactive({
    which(basename(results_files()$Files) == input$result)
  })
  
  # Create outputs for selected file
  output$gis_file <- shiny::renderText(gis_file()$Files[1])
  output$result_file <- shiny::renderText(dirname(results_files()$Files[result_file()]))
  
  # _____________________________________________________________________________________________________________________________________
  # Process GIS Data #####
  # _____________________________________________________________________________________________________________________________________
  
  # Read GIS Data
  gis <- shiny::reactive({
    shiny::req(!all(is.na(gis_file()$Files)))
    gis <- sf::st_read(gis_file()$Files[1])
    geo_type <- sf::st_geometry_type(gis, by_geometry = FALSE) # Get geometry type
    
    # Send warning if GIS file is not polygon type
    if(!geo_type %in% c("POLYGON", "MULTIPOLYGON")){
      shinyalert::shinyalert(title = "Select GIS File", text = "Selected GIS file does not have POLYGON geometry.", type = "error")
    }
    req(geo_type %in% c("POLYGON", "MULTIPOLYGON"))
    return(gis)
  })
  
  # Get column index of SUBID column in GIS file
  gis.subid <- shiny::reactive({which(colnames(gis()) == input$column)})
  
  # Output table for GIS
  output$gis <- DT::renderDataTable(
    gis() %>%
      sf::st_drop_geometry() %>%
      # Convert strings columns to factors if there are any duplicated values
      mutate(across(where(is.character), function(X) {
        if (any(duplicated(X))) {
          as.factor(X)
        }
      })),
    rownames = FALSE, filter = "top", options = list(scrollX = TRUE, lengthMenu = c(5, 10, 25, 50, 100))
  )
  # output$gis <- DT::renderDataTable(datatable(gis() %>% sf::st_drop_geometry(), rownames = FALSE, options = list(scrollX = TRUE)) %>% formatRound(unlist(lapply(gis() %>% sf::st_drop_geometry, is.numeric), use.names = FALSE), 3)) # Use this to round numeric columns, but then this affects columns like SUBID
  
  # GIS Data filtered by data table
  gis_filtered <- shiny::reactive({
    gis()[input$gis_rows_all,]
  })
  
  # Get filtered GIS subids
  gis_filtered_subids <- shiny::reactive({
    get_subids <- purrr::possibly(~{
      gis()[input$gis_rows_all,gis.subid()] %>%
        sf::st_drop_geometry() %>%
        unlist()
    }, otherwise = c())
    get_subids()
  })
  
  # Input to select SUBID column in GIS file
  output$input_column <- shiny::renderUI({shiny::selectInput("column", "Select SUBID Column", choices = colnames(gis())[which(!colnames(gis()) %in% attr(gis(), "sf_column"))], selected = colnames(gis())[map.subid.column])})
  
  # Download Data
  output$download_gis <- shiny::downloadHandler(
    filename = "gis_data.csv",
    content = function(file){
      write.csv(gis_filtered() %>% sf::st_drop_geometry(), file, row.names = FALSE)
    }
  )
  
  # _____________________________________________________________________________________________________________________________________
  # Process MapOutput Data #####
  # _____________________________________________________________________________________________________________________________________
  
  # Read Data
  data_in <- shiny::reactive({
    shiny::req(!all(is.na(results_files()$Files)), result_file())
    
    # Safely read file and return NA if any error - leave col.prefix because without the prefix the SliderText Input changes the choices for e.g. "1988.10" to "1988.1" and then it doesn't work
    read_data <- purrr::possibly(~ReadMapOutput(results_files()$Files[result_file()], col.prefix = "X"), otherwise = NA)
    read_data()
  })
  
  # Update time period slider based on input data
  shiny::observe({
    shiny::req(data_in())
    if(ncol(data_in()) > 2){ # If more than 1 time period
      shinyWidgets::updateSliderTextInput(session, "slider", choices = colnames(data_in()[2:ncol(data_in())]))
    } else{ # If only one time period
      shinyWidgets::updateSliderTextInput(session, "slider", choices = rep(colnames(data_in()[2:ncol(data_in())]), 2))
    }
  })
  
  # Check if time period slider has loaded
  slider_loaded <- shiny::reactiveVal(FALSE)
  
  shiny::observe({
    if(!input$slider == "NA"){
      slider_loaded(TRUE)
    }
  })

  # Data used for app
  data <- shiny::reactive({
    shiny::req(!is.na(data_in()), slider_loaded() == TRUE, input$slider %in% colnames(data_in()))
    filtered_data <- data_in()[, c(1, which(colnames(data_in()) == input$slider))]
  })
  
  # Data displayed in table
  data_out <- shiny::reactive({
    
    # Get data
    df <- data()
    
    # Check if GIS data available
    check <- purrr::possibly(~leaf_check(), otherwise = FALSE)
    subids <- purrr::possibly(~gis_filtered_subids(), otherwise = c())
    
    # Filter data to GIS
    if(check() == TRUE & length(subids()) > 0){
      df <- df[which(df[,1] %in% subids()),]
    }
    
    # Format table
    df %>%
      arrange(desc(.[[2]])) # Arrange column
  })
  
  # Render Data Table
  output$table <- DT::renderDataTable(data_out() %>% rename_with(~gsub("^X", "", .), .cols = 2), rownames = FALSE, filter = "top", options = list(scrollX = TRUE, lengthMenu = c(5, 10, 25, 50, 100)))
  
  # Download Data
  output$download_data <- shiny::downloadHandler(
    filename = "result_data.csv",
    content = function(file){
      write.csv(data_out(), file, row.names = FALSE)
    }
  )
  
  # _____________________________________________________________________________________________________________________________________
  # Create Plotly BoxPlot #####
  # _____________________________________________________________________________________________________________________________________
  
  # Reactive value to generate boxplot
  boxplot_load <- shiny::reactiveVal(0)
  
  # Update reactive value when new data is available
  shiny::observeEvent(c(data_in(), slider_loaded(), gis_filtered_subids()),{
    shiny::req(slider_loaded() == TRUE)
    i = boxplot_load() + 1
    boxplot_load(i)
  })
  
  # Generate Boxplot
  boxplot <- shiny::eventReactive(boxplot_load(),{
    
    shiny::req(boxplot_load() > 0)
    
    # Get plot data
    plot_data <- data_out() %>% na.omit()
    
    # Create template plot if all data is NA
    if(nrow(plot_data) == 0){
      plot <- plotly::ggplotly(
        ggplot2::ggplot() +
          ggplot2::geom_boxplot(ggplot2::aes(y = NA))
      )
    # Create plot with available data
    } else{
      plot <- plotly::ggplotly(
        ggplot2::ggplot(data = plot_data) +
          ggplot2::geom_boxplot(ggplot2::aes(y = .data[[input$slider]]))
      )
    }

    # Update plot with plotly
    plot <- plot %>%
      plotly::add_trace(y = plot_data[[input$slider]], type = "box", name = "log", visible = FALSE, marker = list(color = "black"), line = list(color = "black"), fillcolor = "white", hoverinfo = "y") %>% # Trace for log y-axis
      plotly::layout(
        xaxis = list(autorange = TRUE, ticks = "", title = list(text = paste0("<b>", gsub("^X", "", colnames(plot_data)[2]), "</b>"), font = list(size = 14)), showticklabels = FALSE),
        yaxis = list(autorange = TRUE, tickmode = "auto", title = list(text = paste0("<b>", gsub("map", "", tools::file_path_sans_ext(input$result)), "</b>"), font = list(size = 16)), type = "linear", showticklabels = ifelse(nrow(plot_data) == 0, FALSE, TRUE)), # Show tick labels only if data isn't all NA
        updatemenus = list(list(
          active = 0,
          buttons = list(
            list(
              label = "Linear",
              method = "update",
              args = list(list(visible = c(TRUE, FALSE)), list(yaxis = list(title = list(text = paste0("<b>", gsub("map", "", tools::file_path_sans_ext(input$result)), "</b>"), font = list(size = 16)), type = "linear", showticklabels = ifelse(nrow(plot_data) == 0, FALSE, TRUE))))
            ),
            list(
              label = "Log",
              method = "update",
              args = list(list(visible = c(FALSE, TRUE)), list(yaxis = list(title = list(text = paste0("<b>", gsub("map", "", tools::file_path_sans_ext(input$result)), "</b>"), font = list(size = 16)), type = "log", showticklabels = ifelse(nrow(plot_data) == 0, FALSE, TRUE))))
            )
          )
        ))
      )
    
    # Return plot
    return(plot)
  })
  
  # Update Boxplot
  shiny::observe({
    
    # Get Data
    data <- data_out()
    
    # Duplicate data if there is only data for one point so that the boxplot can get generated
    if (nrow(data) == 1) {data <- rbind(data, data)}
    
    plotly::plotlyProxy("plot", session) %>%
      plotly::plotlyProxyInvoke("deleteTraces", list(as.integer(0), as.integer(1))) %>%
      plotly::plotlyProxyInvoke("relayout", list(xaxis = list(autorange = TRUE, ticks = "", title = list(text = paste0("<b>", gsub("^X", "", colnames(data)[2]), "</b>"), font = list(size = 14)), showticklabels = FALSE))) %>%
      plotly::plotlyProxyInvoke("addTraces", list(x = 0, y = data[[input$slider]], type = "box", name = "linear", marker = list(color = "black"), line = list(color = "black"), fillcolor = "white", hoverinfo = "y")) %>%
      plotly::plotlyProxyInvoke("addTraces", list(x = 0, y = data[[input$slider]], type = "box", name = "log", visible = FALSE, marker = list(color = "black"), line = list(color = "black"), fillcolor = "white", hoverinfo = "y"))
  })
  
  # Render Plot
  output$plot <- plotly::renderPlotly({boxplot()})
  
  # _____________________________________________________________________________________________________________________________________
  # Create Leaflet Map #####
  # _____________________________________________________________________________________________________________________________________

  # Check that data can be joined
  leaf_check <- shiny::reactive({
    
    # Requirements
    shiny::req(gis_filtered(), gis.subid(), data())

    # Test join data
    check <- right_join(gis_filtered()[, gis.subid()]%>%mutate(across(1,~as.character(.x))), data()%>%mutate(across(1,~as.character(.x))), by = setNames(nm = colnames(gis_filtered())[gis.subid()], colnames(data())[1]))
    
    return(!all(sf::st_is_empty(check[[attr(check, "sf_column")]])))
  })
  
  # Output for leaf_check
  output$join_status <- shiny::renderUI({
    
    if(leaf_check() == TRUE){
      if(nrow(gis_filtered()) == nrow(data_out())){
        shiny::div(style = "display: inline-block; font-weight: bold; color: limegreen", "PASS")
      } else{
        shiny::div(style = "display: inline-block; font-weight: bold; color: orange", "CHECK")
      }
    } else{
      shiny::div(style = "display: inline-block; font-weight: bold; color: red","FAIL")
    }
  })
  
  # Reactive values to store stuff for legend
  lcol <- reactiveVal()
  cbrks <- reactiveVal()

  # Create basemap
  leaf <- shiny::eventReactive(c(gis_filtered(), gis.subid(), result_file(), slider_loaded()),{

    # Require valid data
    shiny::req(leaf_check() == TRUE, slider_loaded() == TRUE)
    
    # Parse full mapoutput file
    mapdata <- data_in() %>%
      tidyr::pivot_longer(cols = 2:ncol(.)) %>%
      select(1, "value")
    
    # Require data
    shiny::req(!all(is.na(mapdata$value)))
    
    # Create basemap and get data
    data <- PlotMapOutput(
      x = mapdata,
      map = gis_filtered(),
      map.type = "leaflet",
      map.subid.column = gis.subid(),
      plot.searchbar = TRUE,
      legend.pos = "bottomleft",
      var.name = gsub("map", "", tools::file_path_sans_ext(input$result)),
      legend.signif = 2, # Specify number of significant digits to include in map legend
      na.color = "#808080", # Specify color for NA values
      shiny.data = TRUE
    ) %>% 
      suppressMessages() %>%
      suppressWarnings()
    
    # Save function and breaks used to create legend
    lcol(data$lcol)
    cbrks(data$cbrks)
    
    # Parse Data and add button to save map
    leaf <- data$basemap %>%
      leaflet::addEasyButton(leaflet::easyButton(states = list(
        leaflet::easyButtonState(
          stateName = "onestate",
          icon = "fa-camera", title = "Save Map",
          onClick = leaflet::JS(" function(btn, map) {Shiny.onInputChange('leaf_save_button', 'save'); Shiny.onInputChange('leaf_save_button', 'reset')}") # The "reset" state is so that the input resets after it's clicked so you can click the button again
        )
      )))
    
    return(leaf)
  })
  
  # Render Map
  output$map <- leaflet::renderLeaflet({leaf()})
  
  # Update map when data changes
  shiny::observe({
    
    # Require valid data
    shiny::req(leaf_check() == TRUE, lcol(), cbrks(), !all(is.na(data()[2])))
    
    # Get Data
    data <- PlotMapOutput(
      x = data(),
      map = gis_filtered(),
      map.type = "leaflet",
      map.subid.column = gis.subid(),
      var.name = gsub("map", "", tools::file_path_sans_ext(input$result)),
      col = if(length(lcol())<length(cbrks())){c(lcol(),"black")}else{lcol()}, # Add extra color if color breaks longer than colors (this color should get ignored by PlotMapOutput)
      col.breaks = cbrks(),
      shiny.data = TRUE
    ) %>%
      suppressMessages() %>%
      suppressWarnings()

    # Parse Data
    x <- data$x

    # Update Map
    proxy <- leaflet::leafletProxy("map", data = x) %>%
      leaflet::clearGroup("Subbasins") %>%
      leaflet::addPolygons(
        group = "Subbasins",
        data = x,
        color = "black",
        weight = 0.15,
        opacity = 0.75,
        fillColor = ~color,
        fillOpacity = 0.5,
        label = ~label
      )
  })

  # Emulated map for downloading
  leaf_save <- shiny::reactive({
    
    # Get Data
    data <- PlotMapOutput(
      x = data(),
      map = gis_filtered(),
      map.type = "leaflet",
      map.subid.column = gis.subid(),
      var.name = gsub("map", "", tools::file_path_sans_ext(input$result)),
      col = if(length(lcol())<length(cbrks())){c(lcol(),"black")}else{lcol()}, # Add extra color if color breaks longer than colors (this color will get removed by PlotMapOutput)
      col.breaks = cbrks(),
      shiny.data = TRUE
    ) %>%
      suppressMessages() %>%
      suppressWarnings()
    
    # Parse Data
    x <- data$x
    
    # Recreate map
    map <- leaf() %>%
      leaflet::clearGroup("Subbasins") %>%
      leaflet::addPolygons(
        group = "Subbasins",
        data = x,
        color = "black",
        weight = 0.15,
        opacity = 0.75,
        fillColor = ~color,
        fillOpacity = 0.5,
        label = ~label
      ) %>%
      leaflet::setView(lng = input$map_center$lng, lat = input$map_center$lat, zoom = input$map_zoom)
  })
  
  # Get Paths to output directory
  output_dir <- shiny::reactive({
  
    shinyFiles::shinyDirChoose(input, "button_save", roots = volumes, session = session)

    # If button hasn't been used to select files, then return default value/provided with shiny arguments
    if (!typeof(input$button_save) == "list"){
      if(is.null(output.dir)){
        dir <- NULL
      } else{
        dir <- output.dir
      }
    } else{
      dir <- shinyFiles::parseDirPath(volumes, input$button_save)
    }
  })
  
  # Text output for output directory
  output$output_dir <- shiny::renderText(output_dir())
  
  # Save map when button clicked
  shiny::observeEvent(input$leaf_save_button,{
    
    # Send warning if no output directory selected
    if(is.null(output_dir())){
      shinyalert::shinyalert(
        title = "Save Map:",
        type = "error",
        text = 'No output directory specified. Please click the "Select Output Directory" button and specify a directory.'
      )
    
    # Save map
    } else{
      # Get filename
      file <- file.path(output_dir(), paste0(tools::file_path_sans_ext(input$result), "_", gsub("^X", "", input$slider), ".png"))
      
      # Save Image
      shiny::withProgress(value = 0, message = "Saving Map",{
        mapview::mapshot(leaf_save(), file = file, remove_controls = c("zoomControl", "layersControl", "homeButton", "drawToolbar", "easyButton"), selfcontained = FALSE)
        shiny::incProgress(1)
      })
      
      
      # Confirm success
      if(file.exists(file)){
        shinyalert::shinyalert(
          title = "Save Map:",
          type = "success",
          text = paste0('File saved successfully as: \n', file),
          time = 5000
        )
      } else{
        shinyalert::shinyalert(
          title = "Save Map:",
          type = "error",
          text = paste0('File not saved to: \n', file)
        )
      }
    }
  })
  
}