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
Type: Package
Title: Tools to Simplify the Use of the airGR Hydrological Package for Education (Including a Shiny Interface)
Version: 0.1.6.14
Date: 2017-09-28
Version: 0.1.6.15
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")))
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.
License: GPL-2
NeedsCompilation: no
......
......@@ -3,6 +3,18 @@
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
getPrep <- reactive({
......@@ -26,6 +38,13 @@ shinyServer(function(input, output, session) {
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))
})
......@@ -40,7 +59,12 @@ shinyServer(function(input, output, session) {
## Automatic calibration
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),
Transfo = gsub("(\\D{3} \\[)(\\w{0,4})(\\W*Q\\W*\\])", "\\2", input$TypeCrit))
......@@ -48,7 +72,7 @@ shinyServer(function(input, output, session) {
WupPer = substr(getPrep()$WUPPER, 1, 10),
CalPer = substr(c(input$Period[1], input$Period[2]), 1, 10), verbose = FALSE)
PARAM <- CAL$OutputsCalib$ParamFinalR
updateSliderInput(session, inputId = "X1", value = PARAM[1L])
updateSliderInput(session, inputId = "X2", value = PARAM[2L])
updateSliderInput(session, inputId = "X3", value = PARAM[3L])
......@@ -65,20 +89,24 @@ shinyServer(function(input, output, session) {
}
updateActionButton(session, inputId = "CalButton", label = "Model calibrated", icon = icon("check"))
CAL_click$valueButton <- 1
})
## Enable caliration
shinyjs::enable("CalButton")
}, priority = +20)
## Manual calibration
observeEvent({input$Dataset ; input$HydroModel ; input$SnowModel ;
input$X1 ; input$X2 ; input$X3 ; input$X4 ; input$X5 ; input$X6 ;
input$TypeCrit ; input$Period}, {
CAL_click$valueButton <- CAL_click$valueButton - 1
CAL_click$valueButton <- ifelse(CAL_click$valueButton < -1, -1, CAL_click$valueButton)
if (CAL_click$valueButton < 0) {
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) {
## --------------- Simulation
getRES <- reactive({
PARAM <- c(input$X1, input$X2, input$X3, input$X4, input$X5, input$X6)[seq_len(getPrep()$TMGR$NbParam)]
if (input$SnowModel == "CemaNeige") {
PARAM <- c(PARAM, input$C1, input$C2)
......@@ -110,7 +137,7 @@ shinyServer(function(input, output, session) {
return(SIM_transfo)
})
names(SIM) <- SIM_opt$Crit
## Criteria computation
CRIT <- lapply(SIM, function(iCRIT) {
lapply(SIM_opt$Transfo, function(iTRSF) {
......@@ -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,
Param = PARAM,
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) &
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)
if (length(.GlobalEnv$.ShinyGR.hist) == 2 & is.null(names(.GlobalEnv$.ShinyGR.hist[[1]]))) {
.GlobalEnv$.ShinyGR.hist[[1]] <- NULL
......@@ -139,13 +165,12 @@ shinyServer(function(input, output, session) {
OBSold$TypeModel <- .GlobalEnv$.ShinyGR.hist[[1]]$TypeModel
if (.TypeModelGR(OBSold)$CemaNeige & !.TypeModelGR(getPrep()$OBS)$CemaNeige) { # present: No CemaNeige ; old: CemaNeige
OBSold <- ObsGR(ObsBV = get(input$Dataset), HydroModel = .TypeModelGR(OBSold)$NameModel,
CemaNeige = .TypeModelGR(OBSold)$CemaNeige,
Precip = .ShinyGR.args$Precip, PotEvap = .ShinyGR.args$PotEvap,
Qobs = get(input$Dataset), TempMean = .ShinyGR.args$TempMean,
ZInputs = .ShinyGR.args$ZInputs, HypsoData = .ShinyGR.args$HypsoData,
NLayers = .ShinyGR.args$NLayers)
CemaNeige = .TypeModelGR(OBSold)$CemaNeige,
Precip = .ShinyGR.args$Precip, PotEvap = .ShinyGR.args$PotEvap,
Qobs = get(input$Dataset), TempMean = .ShinyGR.args$TempMean,
ZInputs = .ShinyGR.args$ZInputs, HypsoData = .ShinyGR.args$HypsoData,
NLayers = .ShinyGR.args$NLayers)
}
SIMold <- SimGR(ObsGR = OBSold,
Param = .GlobalEnv$.ShinyGR.hist[[1]]$Param,
WupPer = substr(getPrep()$WUPPER, 1, 10),
......@@ -175,10 +200,10 @@ shinyServer(function(input, output, session) {
## Models available considering the plot type
observe({
if (getPlotType() == 4) {
if (getPlotType() == 4) {
updateSelectInput(session, inputId = "HydroModel", choice = c("GR4J", "GR5J"), selected = input$HydroModel)
updateSelectInput(session, inputId = "SnowModel" , choice = c("None"))
} else {
} else {
updateSelectInput(session, inputId = "HydroModel", choice = c("GR4J", "GR5J", "GR6J"), selected = input$HydroModel)
updateSelectInput(session, inputId = "SnowModel" , choice = c("None", "CemaNeige") , selected = input$SnowModel)
}
......@@ -249,7 +274,7 @@ shinyServer(function(input, output, session) {
updateSliderInput(session, inputId = "Event",
min = input$Period[1L] + .TypeModelGR(input$HydroModel)$TimeLag,
max = input$Period[2L])
})
})
## Graphical parameters
......@@ -269,7 +294,7 @@ shinyServer(function(input, output, session) {
}
return(list(col_bg = col_bg, col_fg = col_fg, par = par(no.readonly = TRUE)))
})
## Plot model performance
output$stPlotMP <- renderPlot({
......@@ -324,7 +349,7 @@ shinyServer(function(input, output, session) {
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 <- c(OutputsModel2, Qobs = list(getRES()$SIM$Qobs[IndPlot]))
data <- data.frame(DatesR = OutputsModel2$DatesR,
Qr = OutputsModel2$QR,
Qd = OutputsModel2$QD,
......@@ -400,7 +425,7 @@ shinyServer(function(input, output, session) {
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$Qold <- ifelse(format(OutputsModel2$DatesR, "%Y%m%d") > format(input$Event, "%Y%m%d"), NA, QsimOld[IndPlot])
data <- data.frame(DatesR = OutputsModel2$DatesR,
Qobs = OutputsModel2$Qobs,
Qsim = OutputsModel2$Qsim,
......@@ -426,7 +451,7 @@ shinyServer(function(input, output, session) {
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 <- c(OutputsModel2, Qobs = list(getRES()$SIM$Qobs[IndPlot]))
par(getPlotPar()$par)
airGRteaching:::DiagramGR(OutputsModel = OutputsModel2, Param = getRES()$PARAM,
SimPer = input$Period, EventDate = input$Event,
......@@ -438,7 +463,6 @@ shinyServer(function(input, output, session) {
## --------------- Criteria table
output$Criteria <- renderTable({
## 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)]",
"KGE [Q]", "KGE [sqrt(Q)]", "KGE [log(Q)]"),
......@@ -507,10 +531,10 @@ shinyServer(function(input, output, session) {
output$DownloadPlot <- downloadHandler(
filename = function() {
filename <- switch(input$PlotType,
"Model performance" = "PlotModelPerf",
"Flow time series" = "PlotFlowTimeSeries",
"State variables" = "PlotStateVar",
"Model diagram" = "PlotModelDiag")
"Model performance" = "PlotModelPerf",
"Flow time series" = "PlotFlowTimeSeries",
"State variables" = "PlotStateVar",
"Model diagram" = "PlotModelDiag")
filename <- sprintf("airGR_%s_%s.png", filename, gsub("(.*)( )(\\d{2})(:)(\\d{2})(:)(\\d{2})", "\\1_\\3h\\5m\\7s", Sys.time()))
},
content = function(file) {
......
......@@ -22,6 +22,7 @@ navbarPage(title = div("airGRteaching",
tabPanel(title = "Interface",
icon = icon("bar-chart"),
shinyjs::useShinyjs(), # set up shinyjs
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