inst/visualize_map_output/server.R
In rcapell/RHYPE: 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)
)
}
}
})
}
rcapell/RHYPE documentation built on Feb. 28, 2024, 3:11 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' 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)
)
}
}
})
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.