Commit 23f65fef authored by Delaigue Olivier's avatar Delaigue Olivier
Browse files

Merge branch 'shinyErrorPlot' into 'master'

Shiny error plot

See merge request !2
parents 0687c3da 53cfaf19
Package: airGRteaching
Type: Package
Title: Teaching Hydrological Modelling with the GR Rainfall-Runoff Models ('Shiny' Interface Included)
Version: 0.2.8.21
Date: 2020-02-11
Version: 0.2.8.64
Date: 2020-02-27
Authors@R: c(
person("Olivier", "Delaigue", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7668-8468"), email = "airGR@inrae.fr"),
person("Laurent", "Coron", role = c("aut"), comment = c(ORCID = "0000-0002-1503-6204")),
......
......@@ -34,6 +34,8 @@ export(ShinyGR)
export(as.data.frame.airGRt)
exportPattern(".DiagramGR")
exportPattern(".TypeModelGR")
exportPattern(".StartStop")
exportPattern(".DyShadingMulti")
......
......@@ -4,19 +4,21 @@
### 0.2.8.21 Release Notes (2020-02-11)
### 0.2.8.64 Release Notes (2020-02-26)
#### New features
- added <code>as.data.frame.airGRt()</code> method in order to create a <code>data.frame</code> from outputs of <code>PrepGR()</code>, <code>CalGR()</code> and <code>SimGR()</code> functions. This <code>data.frame</code> always presents the same structure and contains (observed flow, simulated flow, simulated solid precipitation fraction, etc.). Wwhen it doesn't make sense a columns contains <code>NA</code> values (e.g. Qims with the <code>PrepGR()</code> function)
- added <code>as.data.frame.airGRt()</code> method in order to create a <code>data.frame</code> from outputs of <code>PrepGR()</code>, <code>CalGR()</code> and <code>SimGR()</code> functions. This <code>data.frame</code> always presents the same structure and contains observed flow, simulated flow, simulated solid precipitation fraction, etc. When it does not make sense, the concerned column is assigned with <code>NA</code> values (e.g. Qsim with the <code>PrepGR()</code> function)
- a digital object identifier (DOI) now allows to identify the manual of the airGRteaching package. When you use airGRteaching in your work, please always cite both the article and the manual. The last one allows to know the version of the package that is used in order to enhance reproducible research. The references can be displayed with the <code>citation("airGRteaching")</code> command
- two themes of alternative stylesheet are available (<code>"Inrae"</code> and <code>"Saclay"</code>)
#### Deprecated and defunct
- The <code>CalGR</code> argument is now deprecated in the <code>SimGR()</code> function. It has been replaced by the use of the <code>param</code> argument which can be set by an object of the calss <code>CalGR</code> or vector of parameters
- The <code>CalGR</code> argument is now deprecated in the <code>SimGR()</code> function. It has been replaced by the use of the <code>Param</code> argument which can be set by an object of the class <code>CalGR</code> or by a vector of parameters
#### Bug fixes
......@@ -26,17 +28,19 @@
#### User-visible changes
- it is now possible to use the GR4H and GR5H hourly models with or whithout CemaNeige. For that, in the <code>PrepGR()</code>, the <code>HydroModel</code> argument could be set to <code>"GR4H"</code> or <code>"GR5H"</code>. In the GUI, launched by <code>ShinyGR()</code> function, nothing changed, only the daily models are available. So, now airGRteachinf depends on the version of airGR >= 1.4.3.52)
- it is now possible to use the GR4H and GR5H hourly models with or without CemaNeige. For that, in the <code>PrepGR()</code>, the <code>HydroModel</code> argument could be set to <code>"GR4H"</code> or <code>"GR5H"</code>. In the GUI, launched by <code>ShinyGR()</code> function, nothing changed, only the daily models are available. So, now airGRteaching depends on the version of airGR >= 1.4.3.52)
- it is now possible to run the <code>PrepGR()</code> function when discharge is not provided in <code>Qobs</code>. If it is the case, the <code>CalGR()</code> function will return an error message because it is not possible to calibrate the model. The <code>SimGR()</code> function will return a warning message because it is not possible to compute any efficiency criterion
- it is now possible to run the <code>PrepGR()</code> function when discharge is not provided in <code>Qobs</code>. If it is the case, the <code>CalGR()</code> function will return an error message because it is not possible to calibrate the model. The <code>SimGR()</code> function will return a warning message message beacause it is not possible to compute any efficiency criterion
- it is now possible to run the <code>ShinyGR()</code> function when discharge is not provided in <code>Qobs</code>
- it is now possible to run the <code>ShinyGRGR()</code> function when discharge is not provided in <code>Qobs</code>
- when observed discharge is provided in <code>ShinyGR()</code>, the first plotting panel now draws the flow error time series
- the <code>plot()</code> function is now exported
- the <code>dyplot.PrepGR()</code>, <code>dyplot.CalGR()</code> and <code>dyplot.SimGR()</code> functions are no longer exported
- the is now only one help page for all <code>plot.&#42;()</code> functions (use <code>?plot</code> to call it)
- there is now only one help page for all <code>plot.&#42;()</code> functions (use <code>?plot</code> to call it)
#### CRAN-compatibility updates
......
......@@ -19,6 +19,10 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
ObsDF <- list(ObsDF)
}
if (!is.list(HypsoData)) {
HypsoData <- list(HypsoData)
}
if (!is.list(SimPer)) {
SimPer <- list(SimPer)
}
......@@ -138,7 +142,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
}
names(SimPer) <- NamesObsBV
.GlobalEnv$.ShinyGR.hist <- list(list())#list(Param = list(), TypeModel = lsit(), Crit = list(), Qsim = list())
.GlobalEnv$.ShinyGR.args <- list(ObsDF = ObsDF, NamesObsBV = NamesObsBV,
DatesR = DatesR, Precip = Precip, PotEvap = PotEvap, Qobs = Qobs, TempMean = TempMean,
......
......@@ -8,6 +8,9 @@
}
}
## =================================================================================
## commands to avoid warnings during package checking when global variables are used
## =================================================================================
......@@ -22,6 +25,38 @@ if (getRversion() >= "2.15.1") {
## =================================================================================
## function to compute the start and stop id of equal values in a vector
## =================================================================================
.StartStop <- function(x, FUN) {
naQ_rle <- rle(FUN(x))
naQ_ide <- cumsum(naQ_rle$lengths)[naQ_rle$values] + 1
naQ_ids <- naQ_ide - naQ_rle$lengths[naQ_rle$values] - 1
idNA <- data.frame(start = naQ_ids, stop = naQ_ide)
idNA$start <- ifelse(idNA$start < 1 , 1 , idNA$start)
idNA$stop <- ifelse(idNA$stop > length(x), length(x), idNA$stop )
idNA
}
## =================================================================================
## function for drawing several shadows of dygraphic regions simultaneously
## =================================================================================
.DyShadingMulti <- function(dygraph, ts, idStart, IdStop, ...) {
for (i in seq_along(idStart)) {
dygraph <- dygraphs::dyShading(dygraph = dygraph,
from = as.character(ts)[idStart[i]],
to = as.character(ts)[IdStop[i]],
...)
}
dygraph
}
## =================================================================================
## function to manage the model units
## =================================================================================
......@@ -134,7 +169,6 @@ if (getRversion() >= "2.15.1") {
i_pdt <- which(format(OutputsModel$DatesR, "%Y%m%d") == format(EventDate, "%Y%m%d"))
# --------------------------------------------------------------------------------
# UH 1 & 2
# --------------------------------------------------------------------------------
......@@ -255,6 +289,7 @@ if (getRversion() >= "2.15.1") {
# Parametres
tmp_decal <- 20
# --------------------------------------------------------------------------------
# NEUTRALISATION DE P
# --------------------------------------------------------------------------------
......@@ -413,6 +448,7 @@ if (getRversion() >= "2.15.1") {
cex = cex_tri(OutputsModel$PR[i_pdt], fact = fact_triangle, max = cex_max_poly))
}
# --------------------------------------------------------------------------------
# HYDROGRAMME UNITAIRE 1
# --------------------------------------------------------------------------------
......@@ -432,6 +468,7 @@ if (getRversion() >= "2.15.1") {
ncol = PR_mat_UH1_lg+1)[, -1L]
PR_mat_UH1[lower.tri(PR_mat_UH1)] <- 0
# --------------------------------------------------------------------------------
# HYDROGRAMME UNITAIRE 2
# --------------------------------------------------------------------------------
......@@ -618,7 +655,6 @@ if (getRversion() >= "2.15.1") {
}
}
# --------------------------------------------------------------------------------
# RESERVOIR EXPONENTIEL
......
......@@ -7,7 +7,6 @@ as.data.frame.airGRt <- function(x, row.names = NULL, ...) {
TMGR <- .TypeModelGR(x)
myGR <- list()
myGR$PrecipSim <- NA
myGR$FracSolid <- NA
myGR$TempMean <- NA
......@@ -17,7 +16,6 @@ as.data.frame.airGRt <- function(x, row.names = NULL, ...) {
PrecipSim <- rowMeans(as.data.frame(x$InputsModel$LayerPrecip), na.rm = TRUE)
FracSolid <- PrecipSol / PrecipSim
FracSolid <- ifelse(is.na(FracSolid) & PrecipSol == 0 & PrecipSim == 0, 0, FracSolid)
myGR$PrecipSim <- PrecipSim
myGR$FracSolid <- FracSolid
TempMean <- rowMeans(as.data.frame(x$InputsModel$LayerTempMean), na.rm = TRUE)
myGR$TempMean <- TempMean
......@@ -34,7 +32,6 @@ as.data.frame.airGRt <- function(x, row.names = NULL, ...) {
PrecipSim <- rowMeans(sapply(x$OutputsModel$CemaNeigeLayers, "[[", "Pliq"), na.rm = TRUE) + PrecipSol
FracSolid <- PrecipSol / PrecipSim
FracSolid <- ifelse(is.na(FracSolid) & PrecipSol == 0 & PrecipSim == 0, 0, FracSolid)
myGR$PrecipSim <- PrecipSim
myGR$FracSolid <- FracSolid
TempMean <- rowMeans(sapply(x$OutputsModel$CemaNeigeLayers, "[[", "Temp"), na.rm = TRUE)
myGR$TempMean <- TempMean
......@@ -48,7 +45,6 @@ as.data.frame.airGRt <- function(x, row.names = NULL, ...) {
TabSim <- data.frame(Dates = myGR$DatesR,
PotEvap = myGR$PotEvap,
PrecipObs = myGR$Precip,
PrecipSim_CemaNeige = myGR$PrecipSim,
PrecipFracSolid_CemaNeige = myGR$FracSolid,
TempMeanSim_CemaNeige = myGR$TempMean,
Qobs = myGR$Qobs,
......
......@@ -82,10 +82,10 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
}
dg <- dygraphs::dygraph(data.xts, main = main)
dg <- dygraphs::dySeries(dygraph = dg, name = "Qobs", axis = 'y' , color = col.Q[1L], drawPoints = TRUE)
dg <- dygraphs::dySeries(dygraph = dg, name = "Qsim", axis = 'y' , color = col.Q[2L])
dg <- dygraphs::dySeries(dygraph = dg, name = "Qsup", axis = 'y' , color = col.Q[3L], label = Qsup.name, strokePattern = "dashed")
dg <- dygraphs::dygraph(data.xts, main = main, ...)
dg <- dygraphs::dySeries(dygraph = dg, name = "Qobs", axis = "y", color = col.Q[1L], drawPoints = TRUE)
dg <- dygraphs::dySeries(dygraph = dg, name = "Qsim", axis = "y", color = col.Q[2L])
dg <- dygraphs::dySeries(dygraph = dg, name = "Qsup", axis = "y", color = col.Q[3L], label = Qsup.name, strokePattern = "dashed")
dg <- dygraphs::dyStackedBarGroup(dygraph = dg, name = rev(grep("^P", colnames(data.xts), value = TRUE)), axis = "y2", color = (col.Precip))
dg <- dygraphs::dyAxis(dygraph = dg, name = "y" , label = ylab[1L],
valueRange = range(data.xts[, grep("^Q", colnames(data.xts))], na.rm = TRUE) * c(0.01, 1.59))
......@@ -95,18 +95,9 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
dg <- dygraphs::dyRangeSelector(dygraph = dg, height = 15)
}
if (plot.na) {
naQ_rle <- rle(is.na(data$Qobs))
naQ_ide <- cumsum(naQ_rle$lengths)[naQ_rle$values] + 1
naQ_ids <- naQ_ide - naQ_rle$lengths[naQ_rle$values] - 1
IDna <- data.frame(start = naQ_ids, end = naQ_ide)
IDna$start <- ifelse(IDna$start < 1 , 1 , IDna$start)
IDna$end <- ifelse(IDna$end > nrow(data), nrow(data), IDna$end )
for (i in seq_len(nrow(IDna))) {
dg <- dygraphs::dyShading(dygraph = dg,
from = as.character(data$DatesR)[IDna[i, "start"]],
to = as.character(data$DatesR)[IDna[i, "end" ]],
color = col.na)
}
idNA <- .StartStop(data$Qobs, FUN = is.na)
dg <- .DyShadingMulti(dygraph = dg, color = col.na,
ts = data$DatesR, idStart = idNA$start, IdStop = idNA$stop)
}
if (Roller) {
dg <- dygraphs::dyRoller(dygraph = dg, rollPeriod = 5)
......
......@@ -32,10 +32,10 @@ shinyServer(function(input, output, session) {
# ObsDF <- get(input$Dataset)
ObsDF <- .ShinyGR.args$ObsDF[[input$Dataset]]
}
if (all(is.na(ObsDF[[4]]))) {
isUngauged <- TRUE
} else {
if (!all(is.na(ObsDF[[4]])) | !all(is.na(.ShinyGR.args$Qobs))) {
isUngauged <- FALSE
} else {
isUngauged <- TRUE
}
PREP <- PrepGR(ObsDF = ObsDF,
DatesR = .ShinyGR.args$DatesR,
......@@ -65,6 +65,7 @@ shinyServer(function(input, output, session) {
if (!isQobs | input$Period[1L] == input$Period[2L]) {
shinyjs::disable("CalButton")
}
return(list(TMGR = TMGR, PREP = PREP, WUPPER = WUPPER, isUngauged = isUngauged))
})
......@@ -139,6 +140,17 @@ shinyServer(function(input, output, session) {
shinyjs::disable("TypeCrit")
}
}
## Disable the use of CemaNeige is there is no temperature
if (!is.null(.ShinyGR.args$ObsDF[[input$Dataset]])) {
if (ncol(.ShinyGR.args$ObsDF[[input$Dataset]]) < 5) {
shinyjs::disable("SnowModel")
}
} else {
if (is.null(.ShinyGR.args$TempMean)) {
shinyjs::disable("SnowModel")
}
}
})
......@@ -218,14 +230,14 @@ shinyServer(function(input, output, session) {
ObsDF <- .ShinyGR.args$ObsDF[[input$Dataset]]
}
OBSold <- PrepGR(ObsDF = ObsDF,
DatesR = .ShinyGR.args$DatesR,
Precip = .ShinyGR.args$Precip, PotEvap = .ShinyGR.args$PotEvap,
Qobs = .ShinyGR.args$Qobs, TempMean = .ShinyGR.args$TempMean,
ZInputs = .ShinyGR.args$ZInputs[[input$Dataset]],
HypsoData = .ShinyGR.args$HypsoData[[input$Dataset]],
NLayers = .ShinyGR.args$NLayers[[input$Dataset]],
HydroModel = input$HydroModel,
CemaNeige = input$SnowModel == "CemaNeige")
DatesR = .ShinyGR.args$DatesR,
Precip = .ShinyGR.args$Precip, PotEvap = .ShinyGR.args$PotEvap,
Qobs = .ShinyGR.args$Qobs, TempMean = .ShinyGR.args$TempMean,
ZInputs = .ShinyGR.args$ZInputs[[input$Dataset]],
HypsoData = .ShinyGR.args$HypsoData[[input$Dataset]],
NLayers = .ShinyGR.args$NLayers[[input$Dataset]],
HydroModel = input$HydroModel,
CemaNeige = input$SnowModel == "CemaNeige")
}
SIMold <- SimGR(PrepGR = OBSold,
Param = .GlobalEnv$.ShinyGR.hist[[1]]$Param,
......@@ -338,9 +350,9 @@ shinyServer(function(input, output, session) {
## Period slider responds to changes in the selected/zoomed dateWindow
observeEvent({input$dyPlotTS_date_window ; input$dyPlotSVs_date_window ; input$dyPlotMDp_date_window}, {
if (!is.null(input$dyPlotTS_date_window) && getPlotType() == 2) {
dateWindow <- as.POSIXct(strftime(input$dyPlotTS_date_window , "%Y-%m-%d %H:%M:%S"), tz = "UTC")
observeEvent({input$dyPlotTSq_date_window ; input$dyPlotSVq_date_window ; input$dyPlotMDp_date_window}, {
if (!is.null(input$dyPlotTSq_date_window) && getPlotType() == 2) {
dateWindow <- as.POSIXct(strftime(input$dyPlotTSq_date_window , "%Y-%m-%d %H:%M:%S"), tz = "UTC")
}
if (!is.null(input$dyPlotSVq_date_window) && getPlotType() == 3) {
dateWindow <- as.POSIXct(strftime(input$dyPlotSVq_date_window, "%Y-%m-%d %H:%M:%S"), tz = "UTC")
......@@ -392,11 +404,16 @@ shinyServer(function(input, output, session) {
## Reset period slider responds to dygraphs to mouse clicks
observeEvent({input$dyPlotTS_click}, {
observeEvent({input$dyPlotTSq_click}, {
updateSliderInput(session, inputId = "Period",
value = as.POSIXct(.ShinyGR.args$SimPer[[input$Dataset]], tz = "UTC"),
timeFormat = "%F", timezone = "+0000")
}, priority = +10)
observeEvent({input$dyPlotTSe_click}, {
updateSliderInput(session, inputId = "Period",
value = as.POSIXct(.ShinyGR.args$SimPer[[input$Dataset]], tz = "UTC"),
timeFormat = "%F", timezone = "+0000")
}, priority = +10)
observeEvent({input$dyPlotSVs_click}, {
updateSliderInput(session, inputId = "Period",
value = as.POSIXct(.ShinyGR.args$SimPer[[input$Dataset]], tz = "UTC"),
......@@ -486,7 +503,7 @@ shinyServer(function(input, output, session) {
## Plot flow time series
output$dyPlotTS <- dygraphs::renderDygraph({
output$dyPlotTSq <- dygraphs::renderDygraph({
if (length(getSim()$SIM$OutputsModel$DatesR) < 2) {
return(NULL)
}
......@@ -496,11 +513,52 @@ shinyServer(function(input, output, session) {
QsimOld <- NULL
}
op <- getPlotPar()$par
dg1 <- dyplot(getSim()$SIM, Qsup = QsimOld, Qsup.name = "Qold", RangeSelector = FALSE, LegendShow = "auto",
col.Q = c(op$fg, "orangered", "grey"), col.Precip = c("#428BCA", "lightblue"))
dg1 <- dygraphs::dyOptions(dg1, axisLineColor = op$fg, axisLabelColor = op$fg,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dg1 <- dygraphs::dyLegend(dg1, show = "follow", width = 325)
dgTSq <- dyplot(getSim()$SIM, Qsup = QsimOld, Qsup.name = "Qold",
RangeSelector = FALSE, LegendShow = "auto",
col.Q = c(op$fg, "orangered", "grey"),
col.Precip = c("#428BCA", "lightblue"),
col.na = rgb(0.5, 0.5, 0.5, alpha = 0.4),
group = "ts")
dgTSq <- dygraphs::dyOptions(dgTSq, axisLineColor = op$fg, axisLabelColor = op$fg,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dgTSq <- dygraphs::dyLegend(dgTSq, show = "follow", width = 325)
dgTSq <- dygraphs::dyCrosshair(dgTSq, direction = "vertical")
})
output$dyPlotTSe <- dygraphs::renderDygraph({
if (length(getSim()$SIM$OutputsModel$DatesR) < 2) {
return(NULL)
}
if (getPrep()$isUngauged) {
return(NULL)
}
if (length(getSim()$SIMold) == 2 & input$ShowOldQsim == "Yes") {
ErrorOld <- getSim()$SIMold[[1]]$Qsim - getSim()$SIM$Qobs
} else {
ErrorOld <- NA
}
data <- data.frame(DatesR = getSim()$SIM$OutputsModel$DatesR,
Error = getSim()$SIM$OutputsModel$Qsim - getSim()$SIM$Qobs,
ErrorOld = ErrorOld,
naCol = NA)
data.xts <- xts::xts(data[, -1L, drop = FALSE], order.by = data$DatesR, tz = "UTC")
op <- getPlotPar()$par
dgTSe <- dygraphs::dygraph(data.xts, group = "ts", ylab = "flow error [mm/d]", main = " ")
dgTSe <- dygraphs::dySeries(dgTSe, "Error" , axis = "y" , color = "orangered")
dgTSe <- dygraphs::dySeries(dgTSe, "ErrorOld", axis = "y" , color = "grey", strokePattern = "dashed")
dgTSe <- dygraphs::dySeries(dgTSe, "naCol", axis = "y2", color = NA)
dgTSe <- dygraphs::dyAxis(dgTSe, name = "y", axisLabelWidth = 60)
dgTSe <- dygraphs::dyAxis(dgTSe, name = "y2", drawGrid = FALSE,
axisLabelFormatter = "function(d) {return d.toString().replace(/./g,'');}",
axisLabelWidth = 60)
dgTSe <- dygraphs::dyOptions(dgTSe, titleHeight = 50,
axisLineColor = op$fg, axisLabelColor = op$fg,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dgTSe <- dygraphs::dyLegend(dgTSe, show = "onmouseover", width = 225)
dgTSe <- dygraphs::dyCrosshair(dgTSe, direction = "vertical")
dgTSe <- dygraphs::dyLimit(dgTSe, limit = 0, color = "blue")
idNA <- .StartStop(data$Error, FUN = is.na)
dgTSe <- .DyShadingMulti(dygraph = dgTSe, color = rgb(0.5, 0.5, 0.5, alpha = 0.4),
ts = data$DatesR, idStart = idNA$start, IdStop = idNA$stop)
})
......@@ -521,15 +579,15 @@ shinyServer(function(input, output, session) {
} else {
colors = c("#00008B", "#008B8B")
}
op <- getPlotPar()$par
dg2 <- dygraphs::dygraph(data.xts, group = "state_var", ylab = "store [mm]")
dg2 <- dygraphs::dyOptions(dg2, colors = colors,
fillGraph = TRUE, fillAlpha = 0.3,
drawXAxis = FALSE, axisLineColor = op$fg, axisLabelColor = op$fg,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dg2 <- dygraphs::dyLegend(dg2, show = "always", width = 325)
dg2 <- dygraphs::dyCrosshair(dg2, direction = "vertical")
dgSVs <- dygraphs::dygraph(data.xts, group = "state_var", ylab = "store [mm]")
dgSVs <- dygraphs::dyOptions(dgSVs, colors = colors,
fillGraph = TRUE, fillAlpha = 0.3,
drawXAxis = FALSE, axisLineColor = op$fg, axisLabelColor = op$fg,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dgSVs <- dygraphs::dyLegend(dgSVs, show = "always", width = 325)
dgSVs <- dygraphs::dyCrosshair(dgSVs, direction = "vertical")
})
......@@ -569,21 +627,24 @@ shinyServer(function(input, output, session) {
names <- c("Qd", "Qr")
colors <- c("#FFD700", "#EE6300")
}
op <- getPlotPar()$par
dg3 <- dygraphs::dygraph(data.xts, group = "state_var", ylab = paste0("flow [mm/", getPrep()$TMGR$TimeUnit, "]"), main = " ")
dg3 <- dygraphs::dyOptions(dg3, fillAlpha = 1.0,
axisLineColor = op$fg, axisLabelColor = op$fg, titleHeight = 10,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dg3 <- dygraphs::dyStackedRibbonGroup(dg3, name = names,
color = colors, strokeBorderColor = "black")
dg3 <- dygraphs::dySeries(dg3, name = "Qobs", fillGraph = FALSE, drawPoints = TRUE, color = op$fg)
dg3 <- dygraphs::dySeries(dg3, name = "Qsim", fillGraph = FALSE, color = "orangered")
dgSVq <- dygraphs::dygraph(data.xts, group = "state_var", ylab = paste0("flow [mm/", getPrep()$TMGR$TimeUnit, "]"), main = " ")
dgSVq <- dygraphs::dyOptions(dgSVq, fillAlpha = 1.0,
axisLineColor = op$fg, axisLabelColor = op$fg, titleHeight = 10,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dgSVq <- dygraphs::dyStackedRibbonGroup(dgSVq, name = names,
color = colors, strokeBorderColor = "black")
dgSVq <- dygraphs::dySeries(dgSVq, name = "Qobs", fillGraph = FALSE, drawPoints = TRUE, color = op$fg)
dgSVq <- dygraphs::dySeries(dgSVq, name = "Qsim", fillGraph = FALSE, color = "orangered")
if (length(getSim()$SIMold) == 2 & input$ShowOldQsim == "Yes") {
dg3 <- dygraphs::dySeries(dg3, name = "QsimOld", label = "Qold", fillGraph = FALSE, color = "grey", strokePattern = "dashed")
dgSVq <- dygraphs::dySeries(dgSVq, name = "QsimOld", label = "Qold", fillGraph = FALSE, color = "grey", strokePattern = "dashed")
}
dg3 <- dygraphs::dyCrosshair(dg3, direction = "vertical")
dg3 <- dygraphs::dyLegend(dg3, show = "always", width = 325)
dgSVq <- dygraphs::dyCrosshair(dgSVq, direction = "vertical")
dgSVq <- dygraphs::dyLegend(dgSVq, show = "always", width = 325)
idNA <- .StartStop(getData()$Tab$Qobs, FUN = is.na)
dgSVq <- .DyShadingMulti(dygraph = dgSVq, color = rgb(0.5, 0.5, 0.5, alpha = 0.4),
ts = data$DatesR, idStart = idNA$start, IdStop = idNA$stop)
})
......@@ -597,14 +658,14 @@ shinyServer(function(input, output, session) {
# data <- getData()$Tab[, c("DatesR", "precip.")]
data.xts <- xts::xts(data[, -1L, drop = FALSE], order.by = data$DatesR, tzone = "UTC")
dg4 <- dygraphs::dygraph(data.xts, group = "mod_diag", ylab = paste0("precip. [mm/", getPrep()$TMGR$TimeUnit, "]"))
dg4 <- dygraphs::dyOptions(dg4, colors = "#428BCA", drawXAxis = FALSE,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dg4 <- dygraphs::dyBarSeries(dg4, name = "precip.")
dg4 <- dygraphs::dyAxis(dg4, name = "y", valueRange = c(max(data.xts[, "precip."], na.rm = TRUE), -1e-3))
dg4 <- dygraphs::dyEvent(dg4, input$Event, color = "orangered")
dg4 <- dygraphs::dyLegend(dg4, show = "onmouseover", width = 225)
dg4 <- dygraphs::dyCrosshair(dg4, direction = "vertical")
dgMDp <- dygraphs::dygraph(data.xts, group = "mod_diag", ylab = paste0("precip. [mm/", getPrep()$TMGR$TimeUnit, "]"))
dgMDp <- dygraphs::dyOptions(dgMDp, colors = "#428BCA", drawXAxis = FALSE,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dgMDp <- dygraphs::dyBarSeries(dgMDp, name = "precip.")
dgMDp <- dygraphs::dyAxis(dgMDp, name = "y", valueRange = c(max(data.xts[, "precip."], na.rm = TRUE), -1e-3))
dgMDp <- dygraphs::dyEvent(dgMDp, input$Event, color = "orangered")
dgMDp <- dygraphs::dyLegend(dgMDp, show = "onmouseover", width = 225)
dgMDp <- dygraphs::dyCrosshair(dgMDp, direction = "vertical")
})
......@@ -619,14 +680,14 @@ shinyServer(function(input, output, session) {
data.xts <- xts::xts(data[, -1L, drop = FALSE], order.by = data$DatesR, tzone = "UTC")
op <- getPlotPar()$par
dg5 <- dygraphs::dygraph(data.xts, group = "mod_diag", ylab = paste0("PET [mm/", getPrep()$TMGR$TimeUnit, "]"), main = " ")
dg5 <- dygraphs::dyOptions(dg5, colors = "#A4C400", drawPoints = TRUE,
strokeWidth = 0, pointSize = 2, drawXAxis = FALSE,
axisLineColor = op$fg, axisLabelColor = op$fg, titleHeight = 10,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dg5 <- dygraphs::dyEvent(dg5, input$Event, color = "orangered")
dg5 <- dygraphs::dyLegend(dg5, show = "onmouseover", width = 225)
dg5 <- dygraphs::dyCrosshair(dg5, direction = "vertical")
dgMDe <- dygraphs::dygraph(data.xts, group = "mod_diag", ylab = paste0("PET [mm/", getPrep()$TMGR$TimeUnit, "]"), main = " ")
dgMDe <- dygraphs::dyOptions(dgMDe, colors = "#A4C400", drawPoints = TRUE,
strokeWidth = 0, pointSize = 2, drawXAxis = FALSE,
axisLineColor = op$fg, axisLabelColor = op$fg, titleHeight = 10,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dgMDe <- dygraphs::dyEvent(dgMDe, input$Event, color = "orangered")
dgMDe <- dygraphs::dyLegend(dgMDe, show = "onmouseover", width = 225)
dgMDe <- dygraphs::dyCrosshair(dgMDe, direction = "vertical")
})
......@@ -657,15 +718,18 @@ shinyServer(function(input, output, session) {
data.xts <- xts::xts(data[, -1L, drop = FALSE], order.by = data$DatesR, tzone = "UTC")
op <- getPlotPar()$par
dg6 <- dygraphs::dygraph(data.xts, group = "mod_diag", ylab = paste0("flow [mm/", getPrep()$TMGR$TimeUnit, "]"), main = " ")
dg6 <- dygraphs::dyOptions(dg6, colors = c(op$fg, "orangered", "grey"), drawPoints = TRUE,
axisLineColor = op$fg, axisLabelColor = op$fg, titleHeight = 10,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dg6 <- dygraphs::dySeries(dg6, name = "Qsim" , drawPoints = FALSE)
dg6 <- dygraphs::dyEvent(dg6, input$Event, color = "orangered")
dg6 <- dygraphs::dySeries(dg6, name = "QsimOld", label = "Qold", drawPoints = FALSE, strokePattern = "dashed")
dg6 <- dygraphs::dyLegend(dg6, show = "onmouseover", width = 225)
dg6 <- dygraphs::dyCrosshair(dg6, direction = "vertical")
dgMDq <- dygraphs::dygraph(data.xts, group = "mod_diag", ylab = paste0("flow [mm/", getPrep()$TMGR$TimeUnit, "]"), main = " ")
dgMDq <- dygraphs::dyOptions(dgMDq, colors = c(op$fg, "orangered", "grey"), drawPoints = TRUE,
axisLineColor = op$fg, axisLabelColor = op$fg, titleHeight = 10,
retainDateWindow = FALSE, useDataTimezone = TRUE)
dgMDq <- dygraphs::dySeries(dgMDq, name = "Qsim" , drawPoints = FALSE)
dgMDq <- dygraphs::dyEvent(dgMDq, input$Event, color = "orangered")
dgMDq <- dygraphs::dySeries(dgMDq, name = "QsimOld", label = "Qold", drawPoints = FALSE, strokePattern = "dashed")
dgMDq <- dygraphs::dyLegend(dgMDq, show = "onmouseover", width = 225)
dgMDq <- dygraphs::dyCrosshair(dgMDq, direction = "vertical")
idNA <- .StartStop(data$Qobs, FUN = is.na)
dgMDq <- .DyShadingMulti(dygraph = dgMDq, color = rgb(0.5, 0.5, 0.5, alpha = 0.4),
ts = data$DatesR, idStart = idNA$start, IdStop = idNA$stop)
})
......@@ -747,9 +811,9 @@ shinyServer(function(input, output, session) {
if (getPrep()$isUngauged) {
TabSim$Qobs <- NA
}
colnames(TabSim) <- sprintf("%s [%s]", colnames(TabSim), c("-", rep("mm", 3), "-", "°C", rep("mm", 2)))
colnames(TabSim) <- sprintf("%s [%s]", colnames(TabSim), c("-", rep("mm", 2), "-", "°C", rep("mm", 2)))
colnames(TabSim) <- ifelse(grepl("mm", colnames(TabSim)),
gsub("mm", paste0("mm/", .TypeModelGR(PREP)$TimeUnit), colnames(TabSim)),
gsub("mm", paste0("mm/", .TypeModelGR(getSim()$SIM)$TimeUnit), colnames(TabSim)),
colnames(TabSim))
write.table(TabSim, file = file, row.names = FALSE, sep = ";")
}
......@@ -790,7 +854,7 @@ shinyServer(function(input, output, session) {
if (getPlotType() == 2) {
png(filename =