Commit 0ec29fe7 authored by unknown's avatar unknown
Browse files

v0.1.6.15 disable and enable buttons in ShinyGR interface (using the shinyjs package)

parent cbbc83d7
Package: airGRteaching Package: airGRteaching
Type: Package Type: Package
Title: Tools to Simplify the Use of the airGR Hydrological Package for Education (Including a Shiny Interface) Title: Tools to Simplify the Use of the airGR Hydrological Package for Education (Including a Shiny Interface)
Version: 0.1.6.14 Version: 0.1.6.15
Date: 2017-09-28 Date: 2017-09-29
Authors@R: c(person("Olivier", "Delaigue", role = c("aut", "cre"), email = "airGR@irstea.fr"), person("Laurent", "Coron", role = c("aut")), person("Pierre", "Brigode", role = c("aut")), person("Guillaume", "Thirel", role = c("ctb"))) Authors@R: c(person("Olivier", "Delaigue", role = c("aut", "cre"), email = "airGR@irstea.fr"), person("Laurent", "Coron", role = c("aut")), person("Pierre", "Brigode", role = c("aut")), person("Guillaume", "Thirel", role = c("ctb")))
Depends: airGR (>= 1.0.9.43) Depends: airGR (>= 1.0.9.43)
Imports: xts, dygraphs (>= 1.1.1.4), shiny, plotrix, markdown Imports: xts, dygraphs (>= 1.1.1.4), shiny, shinyjs, plotrix, markdown
Description: Add-on package to the airGR package that simplifies its use and is aimed at being used for teaching hydrology. The package provides 1) three functions that allow to complete very simply a hydrological modelling exercise 2) plotting functions to help students to explore observed data and to interpret the results of calibration and simulation of the GR models 3) a shiny graphical interface that allows for displaying the impact of model parameters on hydrographs and models internal variables. Description: Add-on package to the airGR package that simplifies its use and is aimed at being used for teaching hydrology. The package provides 1) three functions that allow to complete very simply a hydrological modelling exercise 2) plotting functions to help students to explore observed data and to interpret the results of calibration and simulation of the GR models 3) a shiny graphical interface that allows for displaying the impact of model parameters on hydrographs and models internal variables.
License: GPL-2 License: GPL-2
NeedsCompilation: no NeedsCompilation: no
......
...@@ -3,6 +3,18 @@ ...@@ -3,6 +3,18 @@
shinyServer(function(input, output, session) { shinyServer(function(input, output, session) {
## --------------- List of input names
getInputs <- reactive({
inputList <- sort(names(reactiveValuesToList(input)))
inputList <- inputList[!grepl("^dy", inputList)]
inputList <- inputList[!grepl("^CalButton", inputList)]
inputList <- c(inputList, "DownloadTab", "DownloadPlot")
return(inputList)
})
## --------------- Data preparation ## --------------- Data preparation
getPrep <- reactive({ getPrep <- reactive({
...@@ -26,6 +38,13 @@ shinyServer(function(input, output, session) { ...@@ -26,6 +38,13 @@ shinyServer(function(input, output, session) {
WUPPER[2] <- WUPPER[1] WUPPER[2] <- WUPPER[1]
} }
## Enable or disable automatic calibration (if there is Qobs or not)
isQobs <- !all(is.na(OBS$Qobs[OBS$InputsModel$Dates >= input$Period[1] & OBS$InputsModel$Dates <= input$Period[2]]))
if (isQobs) {
shinyjs::enable("CalButton")
} else {
shinyjs::disable("CalButton")
}
return(list(TMGR = TMGR, OBS = OBS, WUPPER = WUPPER)) return(list(TMGR = TMGR, OBS = OBS, WUPPER = WUPPER))
}) })
...@@ -40,7 +59,12 @@ shinyServer(function(input, output, session) { ...@@ -40,7 +59,12 @@ shinyServer(function(input, output, session) {
## Automatic calibration ## Automatic calibration
observeEvent(input$CalButton, { observeEvent(input$CalButton, {
## Desable all inputs during automatic calibration
lapply(getInputs(), shinyjs::disable)
shinyjs::disable("CalButton")
## Model calibration
CAL_opt <- list(Crit = gsub(" .*", "", input$TypeCrit), CAL_opt <- list(Crit = gsub(" .*", "", input$TypeCrit),
Transfo = gsub("(\\D{3} \\[)(\\w{0,4})(\\W*Q\\W*\\])", "\\2", input$TypeCrit)) Transfo = gsub("(\\D{3} \\[)(\\w{0,4})(\\W*Q\\W*\\])", "\\2", input$TypeCrit))
...@@ -48,7 +72,7 @@ shinyServer(function(input, output, session) { ...@@ -48,7 +72,7 @@ shinyServer(function(input, output, session) {
WupPer = substr(getPrep()$WUPPER, 1, 10), WupPer = substr(getPrep()$WUPPER, 1, 10),
CalPer = substr(c(input$Period[1], input$Period[2]), 1, 10), verbose = FALSE) CalPer = substr(c(input$Period[1], input$Period[2]), 1, 10), verbose = FALSE)
PARAM <- CAL$OutputsCalib$ParamFinalR PARAM <- CAL$OutputsCalib$ParamFinalR
updateSliderInput(session, inputId = "X1", value = PARAM[1L]) updateSliderInput(session, inputId = "X1", value = PARAM[1L])
updateSliderInput(session, inputId = "X2", value = PARAM[2L]) updateSliderInput(session, inputId = "X2", value = PARAM[2L])
updateSliderInput(session, inputId = "X3", value = PARAM[3L]) updateSliderInput(session, inputId = "X3", value = PARAM[3L])
...@@ -65,20 +89,24 @@ shinyServer(function(input, output, session) { ...@@ -65,20 +89,24 @@ shinyServer(function(input, output, session) {
} }
updateActionButton(session, inputId = "CalButton", label = "Model calibrated", icon = icon("check")) updateActionButton(session, inputId = "CalButton", label = "Model calibrated", icon = icon("check"))
CAL_click$valueButton <- 1 CAL_click$valueButton <- 1
})
## Enable caliration
shinyjs::enable("CalButton")
}, priority = +20)
## Manual calibration ## Manual calibration
observeEvent({input$Dataset ; input$HydroModel ; input$SnowModel ; observeEvent({input$Dataset ; input$HydroModel ; input$SnowModel ;
input$X1 ; input$X2 ; input$X3 ; input$X4 ; input$X5 ; input$X6 ; input$X1 ; input$X2 ; input$X3 ; input$X4 ; input$X5 ; input$X6 ;
input$TypeCrit ; input$Period}, { input$TypeCrit ; input$Period}, {
CAL_click$valueButton <- CAL_click$valueButton - 1 CAL_click$valueButton <- CAL_click$valueButton - 1
CAL_click$valueButton <- ifelse(CAL_click$valueButton < -1, -1, CAL_click$valueButton) CAL_click$valueButton <- ifelse(CAL_click$valueButton < -1, -1, CAL_click$valueButton)
if (CAL_click$valueButton < 0) { if (CAL_click$valueButton < 0) {
updateActionButton(session, inputId = "CalButton", label = "Run", icon = icon("refresh")) updateActionButton(session, inputId = "CalButton", label = "Run", icon = icon("refresh"))
} }
## Enable all inputs except automatic calibration
lapply(getInputs(), shinyjs::enable)
}) })
...@@ -86,7 +114,6 @@ shinyServer(function(input, output, session) { ...@@ -86,7 +114,6 @@ shinyServer(function(input, output, session) {
## --------------- Simulation ## --------------- Simulation
getRES <- reactive({ getRES <- reactive({
PARAM <- c(input$X1, input$X2, input$X3, input$X4, input$X5, input$X6)[seq_len(getPrep()$TMGR$NbParam)] PARAM <- c(input$X1, input$X2, input$X3, input$X4, input$X5, input$X6)[seq_len(getPrep()$TMGR$NbParam)]
if (input$SnowModel == "CemaNeige") { if (input$SnowModel == "CemaNeige") {
PARAM <- c(PARAM, input$C1, input$C2) PARAM <- c(PARAM, input$C1, input$C2)
...@@ -110,7 +137,7 @@ shinyServer(function(input, output, session) { ...@@ -110,7 +137,7 @@ shinyServer(function(input, output, session) {
return(SIM_transfo) return(SIM_transfo)
}) })
names(SIM) <- SIM_opt$Crit names(SIM) <- SIM_opt$Crit
## Criteria computation ## Criteria computation
CRIT <- lapply(SIM, function(iCRIT) { CRIT <- lapply(SIM, function(iCRIT) {
lapply(SIM_opt$Transfo, function(iTRSF) { lapply(SIM_opt$Transfo, function(iTRSF) {
...@@ -126,9 +153,8 @@ shinyServer(function(input, output, session) { ...@@ -126,9 +153,8 @@ shinyServer(function(input, output, session) {
.GlobalEnv$.ShinyGR.hist[[length(.GlobalEnv$.ShinyGR.hist)+1]] <- list(Qsim = SIM$ErrorCrit_KGE$NO$SIM$OutputsModel$Qsim, .GlobalEnv$.ShinyGR.hist[[length(.GlobalEnv$.ShinyGR.hist)+1]] <- list(Qsim = SIM$ErrorCrit_KGE$NO$SIM$OutputsModel$Qsim,
Param = PARAM, Param = PARAM,
TypeModel = SIM$ErrorCrit_KGE$NO$SIM$TypeModel) TypeModel = SIM$ErrorCrit_KGE$NO$SIM$TypeModel)
.GlobalEnv$.ShinyGR.hist <- .GlobalEnv$.ShinyGR.hist[!(duplicated(sapply(.GlobalEnv$.ShinyGR.hist, function(x) sum(x$Param)), fromLast = TRUE) & .GlobalEnv$.ShinyGR.hist <- .GlobalEnv$.ShinyGR.hist[!(duplicated(sapply(.GlobalEnv$.ShinyGR.hist, function(x) sum(x$Param)), fromLast = TRUE) &
duplicated(sapply(.GlobalEnv$.ShinyGR.hist, function(x) x$TypeModel ), fromLast = TRUE))] duplicated(sapply(.GlobalEnv$.ShinyGR.hist, function(x) x$TypeModel ), fromLast = TRUE))]
.GlobalEnv$.ShinyGR.hist <- tail(.GlobalEnv$.ShinyGR.hist, n = 2) .GlobalEnv$.ShinyGR.hist <- tail(.GlobalEnv$.ShinyGR.hist, n = 2)
if (length(.GlobalEnv$.ShinyGR.hist) == 2 & is.null(names(.GlobalEnv$.ShinyGR.hist[[1]]))) { if (length(.GlobalEnv$.ShinyGR.hist) == 2 & is.null(names(.GlobalEnv$.ShinyGR.hist[[1]]))) {
.GlobalEnv$.ShinyGR.hist[[1]] <- NULL .GlobalEnv$.ShinyGR.hist[[1]] <- NULL
...@@ -139,13 +165,12 @@ shinyServer(function(input, output, session) { ...@@ -139,13 +165,12 @@ shinyServer(function(input, output, session) {
OBSold$TypeModel <- .GlobalEnv$.ShinyGR.hist[[1]]$TypeModel OBSold$TypeModel <- .GlobalEnv$.ShinyGR.hist[[1]]$TypeModel
if (.TypeModelGR(OBSold)$CemaNeige & !.TypeModelGR(getPrep()$OBS)$CemaNeige) { # present: No CemaNeige ; old: CemaNeige if (.TypeModelGR(OBSold)$CemaNeige & !.TypeModelGR(getPrep()$OBS)$CemaNeige) { # present: No CemaNeige ; old: CemaNeige
OBSold <- ObsGR(ObsBV = get(input$Dataset), HydroModel = .TypeModelGR(OBSold)$NameModel, OBSold <- ObsGR(ObsBV = get(input$Dataset), HydroModel = .TypeModelGR(OBSold)$NameModel,
CemaNeige = .TypeModelGR(OBSold)$CemaNeige, CemaNeige = .TypeModelGR(OBSold)$CemaNeige,
Precip = .ShinyGR.args$Precip, PotEvap = .ShinyGR.args$PotEvap, Precip = .ShinyGR.args$Precip, PotEvap = .ShinyGR.args$PotEvap,
Qobs = get(input$Dataset), TempMean = .ShinyGR.args$TempMean, Qobs = get(input$Dataset), TempMean = .ShinyGR.args$TempMean,
ZInputs = .ShinyGR.args$ZInputs, HypsoData = .ShinyGR.args$HypsoData, ZInputs = .ShinyGR.args$ZInputs, HypsoData = .ShinyGR.args$HypsoData,
NLayers = .ShinyGR.args$NLayers) NLayers = .ShinyGR.args$NLayers)
} }
SIMold <- SimGR(ObsGR = OBSold, SIMold <- SimGR(ObsGR = OBSold,
Param = .GlobalEnv$.ShinyGR.hist[[1]]$Param, Param = .GlobalEnv$.ShinyGR.hist[[1]]$Param,
WupPer = substr(getPrep()$WUPPER, 1, 10), WupPer = substr(getPrep()$WUPPER, 1, 10),
...@@ -175,10 +200,10 @@ shinyServer(function(input, output, session) { ...@@ -175,10 +200,10 @@ shinyServer(function(input, output, session) {
## Models available considering the plot type ## Models available considering the plot type
observe({ observe({
if (getPlotType() == 4) { if (getPlotType() == 4) {
updateSelectInput(session, inputId = "HydroModel", choice = c("GR4J", "GR5J"), selected = input$HydroModel) updateSelectInput(session, inputId = "HydroModel", choice = c("GR4J", "GR5J"), selected = input$HydroModel)
updateSelectInput(session, inputId = "SnowModel" , choice = c("None")) updateSelectInput(session, inputId = "SnowModel" , choice = c("None"))
} else { } else {
updateSelectInput(session, inputId = "HydroModel", choice = c("GR4J", "GR5J", "GR6J"), selected = input$HydroModel) updateSelectInput(session, inputId = "HydroModel", choice = c("GR4J", "GR5J", "GR6J"), selected = input$HydroModel)
updateSelectInput(session, inputId = "SnowModel" , choice = c("None", "CemaNeige") , selected = input$SnowModel) updateSelectInput(session, inputId = "SnowModel" , choice = c("None", "CemaNeige") , selected = input$SnowModel)
} }
...@@ -249,7 +274,7 @@ shinyServer(function(input, output, session) { ...@@ -249,7 +274,7 @@ shinyServer(function(input, output, session) {
updateSliderInput(session, inputId = "Event", updateSliderInput(session, inputId = "Event",
min = input$Period[1L] + .TypeModelGR(input$HydroModel)$TimeLag, min = input$Period[1L] + .TypeModelGR(input$HydroModel)$TimeLag,
max = input$Period[2L]) max = input$Period[2L])
}) })
## Graphical parameters ## Graphical parameters
...@@ -269,7 +294,7 @@ shinyServer(function(input, output, session) { ...@@ -269,7 +294,7 @@ shinyServer(function(input, output, session) {
} }
return(list(col_bg = col_bg, col_fg = col_fg, par = par(no.readonly = TRUE))) return(list(col_bg = col_bg, col_fg = col_fg, par = par(no.readonly = TRUE)))
}) })
## Plot model performance ## Plot model performance
output$stPlotMP <- renderPlot({ output$stPlotMP <- renderPlot({
...@@ -324,7 +349,7 @@ shinyServer(function(input, output, session) { ...@@ -324,7 +349,7 @@ shinyServer(function(input, output, session) {
IndPlot <- which(OutputsModel$DatesR >= input$Period[1L] & OutputsModel$DatesR <= input$Period[2L]) IndPlot <- which(OutputsModel$DatesR >= input$Period[1L] & OutputsModel$DatesR <= input$Period[2L])
OutputsModel2 <- sapply(OutputsModel[seq_len(which(names(OutputsModel) == "Qsim"))], function(x) x[IndPlot]) OutputsModel2 <- sapply(OutputsModel[seq_len(which(names(OutputsModel) == "Qsim"))], function(x) x[IndPlot])
OutputsModel2 <- c(OutputsModel2, Qobs = list(getRES()$SIM$Qobs[IndPlot])) OutputsModel2 <- c(OutputsModel2, Qobs = list(getRES()$SIM$Qobs[IndPlot]))
data <- data.frame(DatesR = OutputsModel2$DatesR, data <- data.frame(DatesR = OutputsModel2$DatesR,
Qr = OutputsModel2$QR, Qr = OutputsModel2$QR,
Qd = OutputsModel2$QD, Qd = OutputsModel2$QD,
...@@ -400,7 +425,7 @@ shinyServer(function(input, output, session) { ...@@ -400,7 +425,7 @@ shinyServer(function(input, output, session) {
OutputsModel2 <- c(OutputsModel2, Qobs = list(getRES()$SIM$Qobs[IndPlot])) OutputsModel2 <- c(OutputsModel2, Qobs = list(getRES()$SIM$Qobs[IndPlot]))
OutputsModel2$Qsim <- ifelse(format(OutputsModel2$DatesR, "%Y%m%d") > format(input$Event, "%Y%m%d"), NA, OutputsModel2$Qsim) OutputsModel2$Qsim <- ifelse(format(OutputsModel2$DatesR, "%Y%m%d") > format(input$Event, "%Y%m%d"), NA, OutputsModel2$Qsim)
OutputsModel2$Qold <- ifelse(format(OutputsModel2$DatesR, "%Y%m%d") > format(input$Event, "%Y%m%d"), NA, QsimOld[IndPlot]) OutputsModel2$Qold <- ifelse(format(OutputsModel2$DatesR, "%Y%m%d") > format(input$Event, "%Y%m%d"), NA, QsimOld[IndPlot])
data <- data.frame(DatesR = OutputsModel2$DatesR, data <- data.frame(DatesR = OutputsModel2$DatesR,
Qobs = OutputsModel2$Qobs, Qobs = OutputsModel2$Qobs,
Qsim = OutputsModel2$Qsim, Qsim = OutputsModel2$Qsim,
...@@ -426,7 +451,7 @@ shinyServer(function(input, output, session) { ...@@ -426,7 +451,7 @@ shinyServer(function(input, output, session) {
IndPlot <- which(OutputsModel$DatesR >= input$Period[1L] & OutputsModel$DatesR <= input$Period[2L]) IndPlot <- which(OutputsModel$DatesR >= input$Period[1L] & OutputsModel$DatesR <= input$Period[2L])
OutputsModel2 <- sapply(OutputsModel[seq_len(which(names(OutputsModel) == "Qsim"))], function(x) x[IndPlot]) OutputsModel2 <- sapply(OutputsModel[seq_len(which(names(OutputsModel) == "Qsim"))], function(x) x[IndPlot])
OutputsModel2 <- c(OutputsModel2, Qobs = list(getRES()$SIM$Qobs[IndPlot])) OutputsModel2 <- c(OutputsModel2, Qobs = list(getRES()$SIM$Qobs[IndPlot]))
par(getPlotPar()$par) par(getPlotPar()$par)
airGRteaching:::DiagramGR(OutputsModel = OutputsModel2, Param = getRES()$PARAM, airGRteaching:::DiagramGR(OutputsModel = OutputsModel2, Param = getRES()$PARAM,
SimPer = input$Period, EventDate = input$Event, SimPer = input$Period, EventDate = input$Event,
...@@ -438,7 +463,6 @@ shinyServer(function(input, output, session) { ...@@ -438,7 +463,6 @@ shinyServer(function(input, output, session) {
## --------------- Criteria table ## --------------- Criteria table
output$Criteria <- renderTable({ output$Criteria <- renderTable({
## Table created in order to choose order the criteria in the table output ## Table created in order to choose order the criteria in the table output
tabCrit_gauge <- data.frame(Criterion = c("NSE [Q]", "NSE [sqrt(Q)]", "NSE [log(Q)]", tabCrit_gauge <- data.frame(Criterion = c("NSE [Q]", "NSE [sqrt(Q)]", "NSE [log(Q)]",
"KGE [Q]", "KGE [sqrt(Q)]", "KGE [log(Q)]"), "KGE [Q]", "KGE [sqrt(Q)]", "KGE [log(Q)]"),
...@@ -507,10 +531,10 @@ shinyServer(function(input, output, session) { ...@@ -507,10 +531,10 @@ shinyServer(function(input, output, session) {
output$DownloadPlot <- downloadHandler( output$DownloadPlot <- downloadHandler(
filename = function() { filename = function() {
filename <- switch(input$PlotType, filename <- switch(input$PlotType,
"Model performance" = "PlotModelPerf", "Model performance" = "PlotModelPerf",
"Flow time series" = "PlotFlowTimeSeries", "Flow time series" = "PlotFlowTimeSeries",
"State variables" = "PlotStateVar", "State variables" = "PlotStateVar",
"Model diagram" = "PlotModelDiag") "Model diagram" = "PlotModelDiag")
filename <- sprintf("airGR_%s_%s.png", filename, gsub("(.*)( )(\\d{2})(:)(\\d{2})(:)(\\d{2})", "\\1_\\3h\\5m\\7s", Sys.time())) filename <- sprintf("airGR_%s_%s.png", filename, gsub("(.*)( )(\\d{2})(:)(\\d{2})(:)(\\d{2})", "\\1_\\3h\\5m\\7s", Sys.time()))
}, },
content = function(file) { content = function(file) {
......
...@@ -22,6 +22,7 @@ navbarPage(title = div("airGRteaching", ...@@ -22,6 +22,7 @@ navbarPage(title = div("airGRteaching",
tabPanel(title = "Interface", tabPanel(title = "Interface",
icon = icon("bar-chart"), icon = icon("bar-chart"),
shinyjs::useShinyjs(), # set up shinyjs
sidebarLayout(position = "left", sidebarLayout(position = "left",
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment