# Server file for Shiny App
# supporting files for the app
# source('global.R')
# source('R/rawdata_plotting.R')
# source('R/mapping.R')
# source('R/main_plotting.R') # plots for the first "main plots" subtab
# source('R/gof_plotting.R') # GOF plots
# source('R/rperiods_plotting.R') # Plots that are a function of return periods (return levels, QS, BS, NT)
# source('ui.R') # User inferface function
# good debuggin tool that stops the browser and lets explore which call cause an error
# options(shiny.error = browser)
# shinyApp(ui, server) # to run the app
server <- function(session,input, output) {
# To be able to select stations directly on the map (for the first tab)
observeEvent(input$map_marker_click, { # update the map markers and view on map clicks
p <- input$map_marker_click
leafletProxy("map")
updateSelectInput(session, inputId='station', selected = p$id,
label = "Pick a station", choices = station$number)
})
# change the station selection on the first tab when a new station is selected in the rlevels tab
observeEvent(input$station4rlevels, {
updateSelectInput(session, inputId='station', selected = input$station4rlevels,
label = "Pick a station", choices = station$number)
})
# and accordingly change the station selection in the rlevels tab when a new station is selected in the main tab
observeEvent(input$station, {
updateSelectInput(session, inputId='station4rlevels', selected = input$station,
label = "Pick a station", choices = station$number)
})
# Same thing for BS
observeEvent(input$station4bs, {
updateSelectInput(session, inputId='station', selected = input$station4bs,
label = "Pick a station", choices = station$number)
})
observeEvent(input$station, {
updateSelectInput(session, inputId='station4bs', selected = input$station,
label = "Pick a station", choices = station$number)
})
# Same thing for QS
observeEvent(input$station4qs, {
updateSelectInput(session, inputId='station', selected = input$station4qs,
label = "Pick a station", choices = station$number)
})
observeEvent(input$station, {
updateSelectInput(session, inputId='station4qs', selected = input$station,
label = "Pick a station", choices = station$number)
})
# Same thing for NT
observeEvent(input$station4nt, {
updateSelectInput(session, inputId='station', selected = input$station4nt,
label = "Pick a station", choices = station$number)
})
observeEvent(input$station, {
updateSelectInput(session, inputId='station4nt', selected = input$station,
label = "Pick a station", choices = station$number)
})
# Same thing for CV
observeEvent(input$station4cv, {
updateSelectInput(session, inputId='station', selected = input$station4cv,
label = "Pick a station", choices = station$number)
})
observeEvent(input$station, {
updateSelectInput(session, inputId='station4cv', selected = input$station,
label = "Pick a station", choices = station$number)
})
# Same thing for KS
observeEvent(input$station4ks, {
updateSelectInput(session, inputId='station', selected = input$station4ks,
label = "Pick a station", choices = station$number)
})
observeEvent(input$station, {
updateSelectInput(session, inputId='station4ks', selected = input$station,
label = "Pick a station", choices = station$number)
})
# Same thing for AD
observeEvent(input$station4ad, {
updateSelectInput(session, inputId='station', selected = input$station4ad,
label = "Pick a station", choices = station$number)
})
observeEvent(input$station, {
updateSelectInput(session, inputId='station4ad', selected = input$station,
label = "Pick a station", choices = station$number)
})
# Same thing for CS
observeEvent(input$station4cs, {
updateSelectInput(session, inputId='station', selected = input$station4cs,
label = "Pick a station", choices = station$number)
})
observeEvent(input$station, {
updateSelectInput(session, inputId='station4cs', selected = input$station,
label = "Pick a station", choices = station$number)
})
# This conditional use of "observe" updates the random runs selection when the "FULL RECORD" is selected
observe({
if(input$length == "FULL RECORD") {
output$random.panel <- renderUI({ selectInput(inputId='random', selected = 1,
label = "There are no subsamples", choices = 1)
})
# cat(file="output/app_output.txt", "full record has been selected for station", input$station, "\n") # test of debugging functionality
} else {
output$random.panel <- renderUI({ sliderInput("random",
"Browse the random runs",
value = 25,
min = 1,
max = 50)
})
}
})
## Conditional use of observe for the special return periods of BS and NT
observe({
if(input$coeffvar2plot_ave == "BS" || input$coeffvar2plot_ave == "QS") {
output$r.period4coefvar_ave <- renderUI({ selectInput(inputId='r.period4coefvar_ave', selected = 10,
label = "Which return period to plot?", choices = rperiods.bs)
})
} else {
output$r.period4coefvar_ave <- renderUI({ selectInput('r.period4coefvar_ave', selected = 100, label='Which return period to plot?',
choices = return.periods)
})
}
})
## Same thing for BS only in the single station CV
observe({
if(input$coeffvar2plot == "BS") {
output$r.period4coefvar <- renderUI({ selectInput(inputId='r.period4coefvar', selected = 10,
label = "Which return period to plot?", choices = rperiods.bs)
})
} else {
output$r.period4coefvar <- renderUI({ selectInput('r.period4coefvar', selected = 100, label='Which return period to plot?',
choices = return.periods)
})
}
})
## Same thing for BS in the main subtab selection for the table
observe({
if(input$gof2table2 == "BS" || input$gof2table2 == "QS") {
output$r.period4table <- renderUI({ selectInput(inputId='r.period4table', selected = 10,
label = "Choose a return period for the table", choices = rperiods.bs)
})
} else {
output$r.period4table <- renderUI({ selectInput('r.period4table', selected = 100, label='Choose a return period for the table',
choices = return.periods)
})
}
})
## Below are reactive variables based on inputs selected in the UI ------------------
# old_station.index <- reactive({ station$index[which(station$number == input$station)] # OLD CODE COMMENTED: NEED TO TIDY UP
old_station.index <- reactive({ which(station$number == input$station)
# station$index is called in order to go back
# to the original indexes of the nc file
})
new_station.index <- reactive({ which(station$number == input$station)
})
station2rawplot.index <- reactive({ which(station$number == input$station2rawplot)
})
distr.index <- reactive({ which(distr.name == input$distr)
})
method.index <- reactive({ which(method.name == input$method)
})
random.index <- reactive({ as.numeric(input$random)
})
length.index <- reactive({ which(sampling_years_full_record == input$length)
})
distr2plot <- reactive({ which(distr.name == input$distr2plot)
})
method2plot <- reactive({ which(method.name == input$method2plot)
})
param.estimate <- reactive({ var.get.nc(nc, "param.estimate",
start = c(old_station.index(), distr.index(), method.index(), 1, length.index(), random.index()),
count = c(1, 1, 1, 3, 1, 1))
})
## Rendering plots of the first tab
output$qdata_boxplot <- renderPlotly({
qdata_boxplot(station2rawplot.index())
})
output$qdata_barplot <- renderPlotly({
qdata_barplot(station2rawplot.index())
})
## Rendering of the goodness of fit plots for the related GOF tabs -------------------
output$plot.ks <- renderPlot({
plot4server_gof(old_station.index(), "KS")
})
output$plot.ad <- renderPlot({
plot4server_gof(old_station.index(), "AD")
})
output$plot.cs <- renderPlot({
plot4server_gof(old_station.index(), "CS")
})
output$plot.rlevels <- renderPlot({
plot4server_gof.rlevels(old_station.index(), "r.levels", input$r.period, as.numeric(input$quantile))
})
output$plot.qs <- renderPlot({
plot4server_gof.rlevels(old_station.index(), "QS", input$r.period4qs, as.numeric(input$quantile4qs))
})
output$plot.bs <- renderPlot({
plot4server_gof.rlevels(old_station.index(), "BS", input$r.period4bs, as.numeric(input$quantile4bs))
})
output$plot.nt <- renderPlot({
plot4server_nt(old_station.index(), "NT", input$r.period4nt)
})
output$plot.rlevels_coeff <- renderPlot({
plot4server_rlevels_coeffvar(old_station.index(), input$coeffvar2plot, input$r.period4coefvar)
})
output$plot.gof_averaged <- renderPlot({
plot4server_gof_averaged(input$gof4ave, as.numeric(input$min_years4ave), as.numeric(input$max_years4ave))
})
output$plot.rlevels_coeff_averaged <- renderPlot({
plot4server_rlevels_coeffvar_ave(input$coeffvar2plot_ave, as.numeric(input$r.period4coefvar_ave),
as.numeric(input$min_years4coeff_ave), as.numeric(input$max_years4coeff_ave))
})
## Main plots for the first tab ---------------
output$main.plot <- renderPlot({
plot4server(na.omit(Q[old_station.index(), ]),
param.estimate(),
distr = distr.index())
})
output$rlevels.plot <- renderPlot({
plot4server_rlevel(na.omit(Q[old_station.index(), ]),
param.estimate(),
distr = distr.index())
})
output$cdf.plot <- renderPlot({
plot4server_cdf(na.omit(Q[old_station.index(), ]),
param.estimate(),
distr = distr.index())
})
output$qq.plot <- renderPlot({
plot4server_qq(na.omit(Q[old_station.index(), ]),
param.estimate(),
distr = distr.index())
})
output$map <- renderLeaflet({
norway_map4server(input$station)
})
# Formattable tables, early experiments, the 2 visualizations could be switched with a button
output$gof.table <- renderFormattable({
temp.list <- gof_summary(input$gof2table, old_station.index())
# print(temp.list$max_gof)
# print(temp.list$min_gof)
formattable(temp.list$gof_table, list(
# Strangely, the condition didn't work with x == temp.list...
# gum = formatter("span", style = x ~ ifelse(abs(x - temp.list$min_gof) < 0.00001, style(color = "green", font.weight = "bold"),
# ifelse(abs(x - temp.list$max_gof) < 0.00001, style(color = "red", font.weight = "bold"), NA))),
#
# gam = formatter("span", style = x ~ ifelse(abs(x - temp.list$min_gof) < 0.00001, style(color = "green", font.weight = "bold"),
# ifelse(abs(x - temp.list$max_gof) < 0.00001, style(color = "red", font.weight = "bold"), NA))),
#
# gev = formatter("span", style = x ~ ifelse(abs(x - temp.list$min_gof) < 0.00001, style(color = "green", font.weight = "bold"),
# ifelse(abs(x - temp.list$max_gof) < 0.00001, style(color = "red", font.weight = "bold"), NA))),
#
# glo = formatter("span", style = x ~ ifelse(abs(x - temp.list$min_gof) < 0.00001, style(color = "green", font.weight = "bold"),
# ifelse(abs(x - temp.list$max_gof) < 0.00001, style(color = "red", font.weight = "bold"), NA))),
#
# pe3 = formatter("span", style = x ~ ifelse(abs(x - temp.list$min_gof) < 0.00001, style(color = "green", font.weight = "bold"),
# ifelse(abs(x - temp.list$max_gof) < 0.00001, style(color = "red", font.weight = "bold"), NA)))
gum = formatter("span", style = x ~ ifelse(x == temp.list$min_gof, style(color = "green", font.weight = "bold"),
ifelse(x == temp.list$max_gof, style(color = "red", font.weight = "bold"), NA))),
gam = formatter("span", style = x ~ ifelse(x == temp.list$min_gof, style(color = "green", font.weight = "bold"),
ifelse(x == temp.list$max_gof, style(color = "red", font.weight = "bold"), NA))),
gev = formatter("span", style = x ~ ifelse(x == temp.list$min_gof, style(color = "green", font.weight = "bold"),
ifelse(x == temp.list$max_gof, style(color = "red", font.weight = "bold"), NA))),
glo = formatter("span", style = x ~ ifelse(x == temp.list$min_gof, style(color = "green", font.weight = "bold"),
ifelse(x == temp.list$max_gof, style(color = "red", font.weight = "bold"), NA))),
pe3 = formatter("span", style = x ~ ifelse(x == temp.list$min_gof, style(color = "green", font.weight = "bold"),
ifelse(x == temp.list$max_gof, style(color = "red", font.weight = "bold"), NA)))
))
})
output$gof.table2 <- renderFormattable({
# This is probably not the most helpful way to format this table.
formattable(gof_summary_rperiods(input$gof2table2, old_station.index(), as.numeric(input$r.period4table)), list(
gum = color_tile("white", "pink"),
gam = color_tile("white", "pink"),
gev = color_tile("white", "pink"),
glo = color_tile("white", "pink"),
pe3 = color_tile("white", "pink")
))
})
# Output DT tables to have some excel feature tables at the end of the app
output$test.table <- DT::renderDataTable({
datatable(stations.summary.df,
# extensions = 'Scroller',
filter = 'top',
options = list(
# dom = 'Bfrtip', buttons = c('copy', 'csv', 'excel', 'pdf', 'print'), # this was for extensions = 'Buttons' which didn't work
# deferRender = TRUE,
# scrollY = 200,
# scroller = TRUE,
pageLength = 20, autoWidth = TRUE,
order = list(list(2, 'asc'))
)
)
# %>% formatStyle(
# 'Station.name',
# backgroundColor = styleInterval(3.4, c('white', 'grey'))
# ) # Can be used for additional styling
})
# Computing a reactive group of stations based on best gof performance
st_group.indexes <- reactive({ station_group_indexes(input$gof4st_groups, input$distr4st_groups, input$method4st_groups, input$minmax)
})
# Computing a reactive group of stations based on slection in first tab
st_group_first_tab.indexes <- reactive({ station_group_indexes_first_tab(as.numeric(input$min_years), as.numeric(input$max_years),
as.numeric(input$min_height), as.numeric(input$max_height))
})
# Mapping the groups of stations that have same best method and distr
output$map.groups_from_gof <- renderLeaflet({
norway_map4groups(st_group.indexes())
})
# Mapping the values of a specific parameter for a specific set of distr/method
output$map.param_values <- renderLeaflet({
norway_map4param_values(input$dist4param_maps, input$method4param_maps, input$param4param_maps)
})
# Plotting the histogram of the paramter values (goes along the map above)
output$param.histo <- renderPlot({
histo4param_values(input$dist4param_maps, input$method4param_maps, input$param4param_maps)
})
# Mapping common stations for the first tab
output$map.groups_first.tab <- renderLeaflet({
norway_map4groups_tab1(st_group_first_tab.indexes())
})
# Table for the mapped stations
output$group.table <- DT::renderDataTable({
datatable(group.dfmaker(st_group.indexes()),
# extensions = 'Scroller',
filter = 'top',
options = list(
pageLength = 20, autoWidth = TRUE,
order = list(list(2, 'asc'))
)
)
})
} # end of server function
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.