Commit 67ff09e0 authored by unknown's avatar unknown
Browse files

v0.1.4.0 ShinyGR now use dygraph devices (except for model perf.)

parent d882c27b
Package: airGRteaching
Type: Package
Title: Tools to Simplify the Use of the airGR Hydrological Package for Education (Including a Shiny Application)
Version: 0.1.3.10
Version: 0.1.4.0
Date: 2017-07-13
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.8.0)
......
......@@ -174,25 +174,25 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, TypeModel) {
# PARTITIONNEMENT FENETRE GRAPHIQUE
# --------------------------------------------------------------------------------
layout(matrix(c(1:4, 4, 4), nrow = 3, ncol = 2, byrow = FALSE), widths = c(1.0, 0.6))
# layout(matrix(c(1:4, 4, 4), nrow = 3, ncol = 2, byrow = FALSE), widths = c(1.0, 0.6))
# --------------------------------------------------------------------------------
# PLUIE ET ETP
# --------------------------------------------------------------------------------
# P
par(mar = c(2, 4, 1, 1), mgp = mgp)
plot(OutputsModel$Dates, OutputsModel$Precip, type = "h", col = col_P, ylim = rev(range(OutputsModel$Precip)), xaxt = "n", ylab = "precip. [mm/d]")
rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
box()
# par(mar = c(2, 4, 1, 1), mgp = mgp)
# plot(OutputsModel$Dates, OutputsModel$Precip, type = "h", col = col_P, ylim = rev(range(OutputsModel$Precip)), xaxt = "n", ylab = "precip. [mm/d]")
# rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
# abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
# box()
# ETP
par(mar = c(2, 4, 1, 1), mgp = mgp)
plot(OutputsModel$Dates, OutputsModel$PotEvap, pch = 19, col = col_E, xaxt = "n", ylab = "evapo. [mm/d]")
rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
box()
# par(mar = c(2, 4, 1, 1), mgp = mgp)
# plot(OutputsModel$Dates, OutputsModel$PotEvap, pch = 19, col = col_E, xaxt = "n", ylab = "evapo. [mm/d]")
# rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
# abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
# box()
# --------------------------------------------------------------------------------
......@@ -200,12 +200,12 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, TypeModel) {
# --------------------------------------------------------------------------------
# Q
par(mar = c(2, 4, 1, 1), mgp = mgp)
plot(OutputsModel$Dates, OutputsModel$Qobs, type = "l", ylab = "flow [mm/d]")
lines(OutputsModel$Dates[1:i_pdt], OutputsModel$Qsim[1:i_pdt], type = "l", col = "orangered")
rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
box()
# par(mar = c(2, 4, 1, 1), mgp = mgp)
# plot(OutputsModel$Dates, OutputsModel$Qobs, type = "l", ylab = "flow [mm/d]")
# lines(OutputsModel$Dates[1:i_pdt], OutputsModel$Qsim[1:i_pdt], type = "l", col = "orangered")
# rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
# abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
# box()
# --------------------------------------------------------------------------------
......
......@@ -31,7 +31,7 @@ shinyServer(function(input, output, session) {
##
CAL_click <- reactiveValues(valueButton = 0)
## Automatic calibration
observeEvent(input$CalButton, {
......@@ -65,19 +65,19 @@ shinyServer(function(input, output, session) {
## Manual calibration
observeEvent({input$Dataset ; input$TypeModel ; input$CemaNeige ;
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"))
}
})
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"))
}
})
## --------------- Simulation
getRES <- reactive({
......@@ -134,31 +134,31 @@ shinyServer(function(input, output, session) {
"Model diagram" = 4)
})
## Plotting
# Plotting
output$myPlot <- renderPlot({
OutputsModel <- getRES()$SIM$OutputsModel
RunOptions <- getRES()$SIM$OptionsSimul
if (.GlobalEnv$.ShinyGR.args$theme == "Cyborg") {
par(bg = "black" , fg = "white", col.axis = "white", col.lab = "white")
}
if (.GlobalEnv$.ShinyGR.args$theme == "Flatly") {
par(fg = "#2C3E50", col.axis = "#2C3E50", col.lab = "#2C3E50")
}
## Target date slider
observe({
updateSliderInput(session, inputId = "Event",
min = input$Period[1L]+.TypeModelGR(input$TypeModel)$TimeLag,
max = input$Period[2L])
})
## Add Qobs to outputs model
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]))
## Models available considering the plot type
if (getPlotType() == 4) {
observe({
......@@ -171,45 +171,163 @@ shinyServer(function(input, output, session) {
updateSelectInput(session, inputId = "CemaNeige", choice = c("None", "CemaNeige") , selected = input$CemaNeige)
})
}
## Flow time series
if (getPlotType() == 2) {
par(mfrow = c(1, 1), par(oma = c(7, 2, 3, 0)))
plot(OutputsModel, Qobs = getRES()$SIM$Qobs, IndPeriod_Plot = IndPlot, which = "Flows", cex.lab = 1.4, cex.axis = 1.5, cex.leg = 1.5)
}
# Flow time series
# if (getPlotType() == 2) {
# par(mfrow = c(1, 1), par(oma = c(7, 2, 3, 0)))
# plot(OutputsModel, Qobs = getRES()$SIM$Qobs, IndPeriod_Plot = IndPlot, which = "Flows", cex.lab = 1.4, cex.axis = 1.5, cex.leg = 1.5)
# }
## Model performance
if (getPlotType() == 1) {
par(cex.axis = 1.2)
plot(OutputsModel, Qobs = getRES()$SIM$Qobs, IndPeriod_Plot = IndPlot, cex.lab = 1.2, cex.axis = 1.4, cex.leg = 1.4)
}
## Model diagram
if (getPlotType() == 4) {
airGRteaching:::DiagramGR(OutputsModel = OutputsModel2, Param = getRES()$PARAM,
SimPer = input$Period, EventDate = input$Event,
TypeModel = input$TypeModel)
# # P
# par(mar = c(2, 4, 1, 1), mgp = mgp)
# plot(OutputsModel$Dates, OutputsModel$Precip, type = "h", col = col_P, ylim = rev(range(OutputsModel$Precip)), xaxt = "n", ylab = "precip. [mm/d]")
# rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
# abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
# box()
#
# # ETP
# par(mar = c(2, 4, 1, 1), mgp = mgp)
# plot(OutputsModel$Dates, OutputsModel$PotEvap, pch = 19, col = col_E, xaxt = "n", ylab = "evapo. [mm/d]")
# rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
# abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
# box()
#
# # Q
# par(mar = c(2, 4, 1, 1), mgp = mgp)
# plot(OutputsModel$Dates, OutputsModel$Qobs, type = "l", ylab = "flow [mm/d]")
# lines(OutputsModel$Dates[1:i_pdt], OutputsModel$Qsim[1:i_pdt], type = "l", col = "orangered")
# rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor(par("bg"), alpha.f = 0.75), border = NA)
# abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
# box()
#
# airGRteaching:::DiagramGR(OutputsModel = OutputsModel2, Param = getRES()$PARAM,
# SimPer = input$Period, EventDate = input$Event,
# TypeModel = input$TypeModel)
}
## State variables
# if (getPlotType() == 3) {
# par(mfrow = c(2, 1), cex.axis = 1.2, cex.lab = 1.1, cex.lab = 1.1)
# par(mar = c(2.5, 4.0, 2.5, 2.0), xaxt = "n")
# plot(range(OutputsModel2$Dates), range(OutputsModel2$Prod, OutputsModel2$Rout), type = "n", xlab = "", ylab = "store [mm]")
# polygon(c(OutputsModel2$Dates, rev(range(OutputsModel2$Dates))), c(OutputsModel2$Prod, rep(min(OutputsModel2$Prod, OutputsModel2$Rout), 2)), border = "darkblue", col = adjustcolor("darkblue", alpha.f = 0.30))
# polygon(c(OutputsModel2$Dates, rev(range(OutputsModel2$Dates))), c(OutputsModel2$Rout, rep(min(OutputsModel2$Prod, OutputsModel2$Rout), 2)), border = "cyan4" , col = adjustcolor("cyan4" , alpha.f = 0.30))
# legend("topright", bty = "n", legend = c("prod.", "rout."), fill = adjustcolor(c("darkblue", "cyan4"), alpha.f = 0.30))
# par(mar = c(5.0, 4.0, 0.0, 2.0), xaxt = "s")
# plot(OutputsModel2$DatesR, OutputsModel2$Qobs, type = "n", xlab = "", ylab = "flow [mm/d]")
# polygon(c(OutputsModel2$Dates, rev(range(OutputsModel2$Dates))), c(OutputsModel2$QR+OutputsModel2$QD, rep(0, 2)), col = adjustcolor("orange2", alpha.f = 0.75), border = NA)
# polygon(c(OutputsModel2$Dates, rev(range(OutputsModel2$Dates))), c(OutputsModel2$QR , rep(0, 2)), col = adjustcolor("gold" , alpha.f = 0.70), border = NA)
# lines(OutputsModel2$DatesR, OutputsModel2$Qsim, lwd = 1, col = "orangered")
# lines(OutputsModel2$DatesR, OutputsModel2$Qobs, type = "l", lwd = 1, col = par("fg"))
# legend("topright", bty = "n", legend = c("obs.", "sim.", "Qd", "Qr"), col = c(par("fg"), "orangered", "orange2", "gold"), lwd = c(2, 2, NA, NA), pch = c(NA, NA, 15, 15))
# }
})
output$myDyPlot1 <- renderDygraph({
if (getPlotType() == 2) {
dyplot(getRES()$SIM, RangeSelector = FALSE)
}
})
output$myDyPlot2 <- renderDygraph({
if (getPlotType() == 3) {
par(mfrow = c(2, 1), cex.axis = 1.2, cex.lab = 1.1, cex.lab = 1.1)
par(mar = c(2.5, 4.0, 2.5, 2.0), xaxt = "n")
plot(range(OutputsModel2$Dates), range(OutputsModel2$Prod, OutputsModel2$Rout), type = "n", xlab = "", ylab = "store [mm]")
polygon(c(OutputsModel2$Dates, rev(range(OutputsModel2$Dates))), c(OutputsModel2$Prod, rep(min(OutputsModel2$Prod, OutputsModel2$Rout), 2)), border = "darkblue", col = adjustcolor("darkblue", alpha.f = 0.30))
polygon(c(OutputsModel2$Dates, rev(range(OutputsModel2$Dates))), c(OutputsModel2$Rout, rep(min(OutputsModel2$Prod, OutputsModel2$Rout), 2)), border = "cyan4" , col = adjustcolor("cyan4" , alpha.f = 0.30))
legend("topright", bty = "n", legend = c("prod.", "rout."), fill = adjustcolor(c("darkblue", "cyan4"), alpha.f = 0.30))
par(mar = c(5.0, 4.0, 0.0, 2.0), xaxt = "s")
plot(OutputsModel2$DatesR, OutputsModel2$Qobs, type = "n", xlab = "", ylab = "flow [mm/d]")
polygon(c(OutputsModel2$Dates, rev(range(OutputsModel2$Dates))), c(OutputsModel2$QR+OutputsModel2$QD, rep(0, 2)), col = adjustcolor("orange2", alpha.f = 0.75), border = NA)
polygon(c(OutputsModel2$Dates, rev(range(OutputsModel2$Dates))), c(OutputsModel2$QR , rep(0, 2)), col = adjustcolor("gold" , alpha.f = 0.70), border = NA)
lines(OutputsModel2$DatesR, OutputsModel2$Qsim, lwd = 1, col = "orangered")
lines(OutputsModel2$DatesR, OutputsModel2$Qobs, type = "l", lwd = 1, col = par("fg"))
legend("topright", bty = "n", legend = c("obs.", "sim.", "Qd", "Qr"), col = c(par("fg"), "orangered", "orange2", "gold"), lwd = c(2, 2, NA, NA), pch = c(NA, NA, 15, 15))
OutputsModel <- getRES()$SIM$OutputsModel
data <- data.frame(DatesR = OutputsModel$DatesR,
prod. = OutputsModel$Prod,
rout. = OutputsModel$Rout)
data.xts <- xts(data[, -1L], order.by = data$DatesR)
graphOut <- dygraph(data.xts, group = "state_var", ylab = "store [mm]")
graphOut <- dyOptions(dygraph = graphOut, fillGraph = TRUE, colors = c("#00008B", "#008B8B"), fillAlpha = 0.3)
graphOut <- dyLegend(dygraph = graphOut, width = 400)
}
})
output$myDyPlot3 <- renderDygraph({
if (getPlotType() == 3) {
OutputsModel <- getRES()$SIM$OutputsModel
## Add Qobs to outputs model
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$QR + OutputsModel2$QD,
sim. = OutputsModel2$Qsim,
obs. = OutputsModel2$Qobs)
data.xts <- xts(data[, -1L], order.by = data$DatesR)
graphOut <- dygraph(data.xts, group = "state_var", ylab = "flow [mm/d]")
graphOut <- dyOptions(graphOut, fillGraph = TRUE, colors = c("#FFD700", "#EE6300", "black", "orangered"), fillAlpha = 0.5)
graphOut <- dySeries(graphOut, name = "obs.", fillGraph = FALSE, drawPoints = TRUE)
graphOut <- dySeries(graphOut, name = "sim.", fillGraph = FALSE)
graphOut <- dyLegend(dygraph = graphOut, width = 400)
}
})
output$myDyPlot4 <- renderDygraph({
if (getPlotType() == 4) {
OutputsModel <- getRES()$SIM$OutputsModel
data <- data.frame(DatesR = OutputsModel$DatesR,
Precip = OutputsModel$Precip)
data.xts <- xts(data[, -1L, drop = FALSE], order.by = data$DatesR)
graphOut <- dygraph(data.xts, group = "mod_diag", ylab = "precip. [mm/d]")
graphOut <- dyOptions(graphOut, colors = "#428BCA", stepPlot = TRUE, fillGraph = TRUE)
graphOut <- dyAxis(graphOut, name = "y", valueRange = rev(range(data.xts[, "Precip"], na.rm = TRUE)))
graphOut <- dyEvent(graphOut, input$Event)
}
})
output$myDyPlot5 <- renderDygraph({
if (getPlotType() == 4) {
OutputsModel <- getRES()$SIM$OutputsModel
data <- data.frame(DatesR = OutputsModel$DatesR,
PotEvap = OutputsModel$PotEvap)
data.xts <- xts(data[, -1L, drop = FALSE], order.by = data$DatesR)
graphOut <- dygraph(data.xts, group = "mod_diag", ylab = "evapo. [mm/d]")
graphOut <- dyOptions(graphOut, colors = "#A4C400", strokeWidth = 0, drawPoints = TRUE, pointSize = 2)
graphOut <- dyEvent(graphOut, input$Event)
}
})
output$myDyPlot6 <- renderDygraph({
if (getPlotType() == 4) {
OutputsModel <- getRES()$SIM$OutputsModel
## Add Qobs to outputs model
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,
obs. = OutputsModel2$Qobs,
sim. = OutputsModel2$Qsim)
data.xts <- xts(data[, -1L, drop = FALSE], order.by = data$DatesR)
graphOut <- dygraph(data.xts, group = "mod_diag", ylab = "flow [mm/d]")
graphOut <- dyOptions(graphOut, colors = c("black", "orangered"), drawPoints = TRUE)
graphOut <- dySeries(graphOut, name = "sim.", drawPoints = FALSE)
graphOut <- dyEvent(graphOut, input$Event)
}
})
output$myPlot2 <- renderPlot({
if (getPlotType() == 4) {
OutputsModel <- getRES()$SIM$OutputsModel
## Add Qobs to outputs model
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]))
airGRteaching:::DiagramGR(OutputsModel = OutputsModel2, Param = getRES()$PARAM,
SimPer = input$Period, EventDate = input$Event,
TypeModel = input$TypeModel)
}
})
## --------------- Criteria table
......
......@@ -114,7 +114,7 @@ navbarPage(title = div("airGRteaching",
fluidRow(
column(2,
selectInput("PlotType", label = "Choose a plot:",
choices = c("Model performance", "Flow time series", "State variables", "Model diagram"))#, "user-defined"))
choices = c("Flow time series", "Model performance", "State variables", "Model diagram"))#, "user-defined"))
),
column(4, offset = 1,
sliderInput("Period", label = "Select the time window:",
......@@ -125,7 +125,7 @@ navbarPage(title = div("airGRteaching",
timezone = "+0000",
animate = FALSE)
),
conditionalPanel(condition = "input.PlotType == 'Model diagram' & (input.TypeModel =='GR4J' || input.TypeModel =='GR5J' || input.TypeModel =='GR6J')",
conditionalPanel(condition = "input.PlotType == 'Model diagram' & (input.TypeModel == 'GR4J' || input.TypeModel == 'GR5J' || input.TypeModel == 'GR6J')",
column(4, offset = 0,
sliderInput("Event", label = "Select the target date:",
min = as.POSIXct(.ShinyGR.args$SimPer[1L], tz = "UTC"),
......@@ -141,7 +141,18 @@ navbarPage(title = div("airGRteaching",
),
fluidRow(column(10, plotOutput("myPlot", width = "100%", height = "665px") ),
fluidRow(conditionalPanel(condition = "input.PlotType == 'Model performance'",
column(10, plotOutput("myPlot", width = "100%", height = "665px"))),
conditionalPanel(condition = "input.PlotType == 'Flow time series'",
column(10, dygraphOutput("myDyPlot1", width = "100%", height = "400px"))),
conditionalPanel(condition = "input.PlotType == 'State variables'",
column(10, dygraphOutput("myDyPlot2", width = "100%", height = "320px"),
dygraphOutput("myDyPlot3", width = "100%", height = "320px"))),
conditionalPanel(condition = "input.PlotType == 'Model diagram'",
column(06, dygraphOutput("myDyPlot4", width = "100%", height = "210px"),
dygraphOutput("myDyPlot5", width = "100%", height = "210px"),
dygraphOutput("myDyPlot6", width = "100%", height = "210px")),
column(04, plotOutput("myPlot2", width = "100%", height = "665px"))),
column(02, tableOutput("Criteria"))
)
......
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