Commit b37de031 authored by unknown's avatar unknown
Browse files

v0.0.3 it is now possible de calibrate the model in shiny.SimGR and to draw new plots

parent fd8ea522
......@@ -10,32 +10,26 @@
##################################################################################
##################################################################################
#! for GR diagrams
create_polygon <- function(x_center = x_center, y_center = y_center, cex = cex, dir = "D") {
xy <- matrix(NA, nrow = 3, ncol = 2)
cex <- log(cex * fact_triangle + 1)
if(dir == "D") {
xy[,1] <- c(x_center-cex/2, x_center-cex/2, x_center+cex/2)
xy[,2] <- c(y_center-cex/2, y_center+cex/2, y_center)
}
if(dir == "G") {
xy[,1] <- c(x_center+cex/2, x_center+cex/2, x_center-cex/2)
xy[,2] <- c(y_center-cex/2, y_center+cex/2, y_center)
TypeModelGR <- function(x) {
if (!is.list(x)) {
x <- list(TypeModel = x)
}
if(dir == "H") {
xy[,1] <- c(x_center-cex/2, x_center+cex/2, x_center)
xy[,2] <- c(y_center-cex/2, y_center-cex/2, y_center+cex/2)
}
if(dir == "B") {
xy[,1] <- c(x_center-cex/2, x_center+cex/2, x_center)
xy[,2] <- c(y_center+cex/2, y_center+cex/2, y_center-cex/2)
if (any(class(x) %in% c("ObsGR", "CalGR", "SimGR")) || names(x) %in% "TypeModel") {
#stop("Non convenient data for x argument. Must be of class \"ObsGR\", \"CalGR\" or \"SimGR\"")
x <- x$TypeModel
}
return(xy)
StrName <- "(.*)(GR)(\\d{1})(\\D{1})"
TimeUnit <- gsub(StrName, "\\4", x)
NbParam <- gsub(StrName, "\\3", x)
isCN <- grepl("CemaNeige" , x)
res <- list(TypeModel = x, NbParam = as.numeric(NbParam), TimeUnit = TimeUnit, CemaNeige = isCN)
return(res)
}
##################################################################################
##################################################################################
##################################################################################
......@@ -44,13 +38,12 @@ create_polygon <- function(x_center = x_center, y_center = y_center, cex = cex,
DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
require(plotrix)
##################################################################################
# PARAMETRES
##################################################################################
# Param?tres
# Parametres
mgp <- c(3,0.5,0)
col_P <- "black"
col_E <- "forestgreen"
......@@ -94,7 +87,7 @@ dates_deb <- EventDate#as.Date(OutputsModel$DatesR)[1]
n_pdt <- length(which(OutputsModel$DatesR >= EventDate & OutputsModel$DatesR <= SimPer[2L]))#365
dates_epi <- OutputsModel$DatesR[which(OutputsModel$DatesR >= EventDate & OutputsModel$DatesR <= SimPer[2L])]#as.Date(OutputsModel$DatesR[1:n_pdt])
dates_epi <- as.Date(dates_epi)
i_pdt <- 1
i_pdt <- which(format(OutputsModel$DatesR, "%Y%m%d") == format(EventDate, "%Y%m%d")) #150#
version <- "V5"
create_polygon <- function(x_center = x_center, y_center = y_center, cex = cex, dir = "D") {
......@@ -133,37 +126,37 @@ create_polygon <- function(x_center = x_center, y_center = y_center, cex = cex,
# HUs
##################################################################################
# Calcul des ordonn?es SH1 de l' "hydrogramme unitaire cumul?" HU1
# Calcul des ordonnees SH1 de l' "hydrogramme unitaire cumule" HU1
SH1 <- array(NA, NH)
for (i in 1:NH) {
if(i <= 0) SH1[i] = 0
if(i > 0 & i < Param[4]) SH1[i] = (i/Param[4])^(D)
if(i >= Param[4]) SH1[i] = 1
if (i <= 0) SH1[i] <- 0
if (i > 0 & i < Param[4]) SH1[i] <- (i/Param[4])^(D)
if (i >= Param[4]) SH1[i] <- 1
}
# Calcul des ordonn?es UH1 de l' "hydrogramme unitaire discret" HU1
# Calcul des ordonnees UH1 de l' "hydrogramme unitaire discret" HU1
UH1 <- array(NA, NH)
for (j in 1:NH) {
if(j == 1) {
if (j == 1) {
UH1[j] <- SH1[j]
} else {
UH1[j] <- SH1[j] - SH1[j-1]
}
}
# Calcul des ordonn?es SH2 de l' "hydrogramme unitaire cumul?" HU2
# Calcul des ordonnees SH2 de l' "hydrogramme unitaire cumule" HU2
SH2 <- array(NA, 2*NH)
for (i in 1:(2*NH)) {
if(i <= 0) SH2[i] = 0
if(i > 0 & i < Param[4]) SH2[i] = 0.5*(i/Param[4])^(D)
if(i > Param[4] & i < 2*Param[4]) SH2[i] = 1 - (0.5*(2-i/Param[4])^(D))
if(i >= 2*Param[4]) SH2[i] = 1
if(i <= 0) SH2[i] <- 0
if(i > 0 & i < Param[4]) SH2[i] <- 0.5*(i/Param[4])^(D)
if(i > Param[4] & i < 2*Param[4]) SH2[i] <- 1 - (0.5*(2-i/Param[4])^(D))
if(i >= 2*Param[4]) SH2[i] <- 1
}
# Calcul des ordonn?es UH2 de l' "hydrogramme unitaire discret" HU2
# Calcul des ordonnees UH2 de l' "hydrogramme unitaire discret" HU2
UH2 <- array(NA, 2*NH)
for (j in 1:(2*NH)) {
if(j == 1) {
if (j == 1) {
UH2[j] <- SH2[j]
} else {
UH2[j] <- SH2[j] - SH2[j-1]
......@@ -181,50 +174,81 @@ max_UH2 <- log(sqrt(max(max(UH2)*OutputsModel$PR*0.1))+1)
# for(i_pdt in 1:n_pdt) {
i_pdt <- 150
##################################################################################
# PNG
##################################################################################
# PNG
# nom_PNG <- paste(DIR_OUT, "__TEST_FLOWCHART_GR4J__", as.Date(OutputsModel$DatesR[i_pdt]), "__", i_pdt,"__", version, ".png", sep="")
# png(file=nom_PNG, width=21, height=29.7, units="cm", res=100)
layout(matrix(1:3, nrow=3, ncol=1, byrow=TRUE), height=c(5,12,5))
# layout(matrix(1:3, nrow=3, ncol=1, byrow=TRUE), height=c(5,12,5))
layout(matrix(c(1:4, 4, 4), nrow = 3, ncol = 2, byrow = FALSE), widths = c(1.0, 0.6))
##################################################################################
# PLUIE ET ETP
##################################################################################
# Param?tres
ind <- which(as.Date(OutputsModel$DatesR) %in% dates_epi)
tmp_P <- barplot(OutputsModel$Precip[ind], plot=FALSE)
ylim <- c(100,0)
tmp_bar <- rep(NA, n_pdt)
tmp_bar[i_pdt] <- ylim[1]
col_bars <- c(rep(col_P, i_pdt), rep("grey90", n_pdt-i_pdt))
# Parametres
# ind <- which(as.Date(OutputsModel$DatesR) %in% dates_epi)
# tmp_P <- barplot(OutputsModel$Precip[ind], plot=FALSE)
# ylim <- c(100,0)
# tmp_bar <- rep(NA, n_pdt)
# tmp_bar[i_pdt] <- ylim[1]
# col_bars <- c(rep(col_P, i_pdt), rep("grey90", n_pdt-i_pdt))
# P
par(mar=c(1, 8, 1, 8))
barplot(OutputsModel$Precip[ind], axes=FALSE, ylim=ylim, col=col_bars, border=NA)
grid()
abline(v=tmp_P[i_pdt], col="red", lwd=0.8, lty=2)
barplot(OutputsModel$Precip[ind], axes=FALSE, ylim=ylim, col=col_bars, border=NA, add=TRUE)
axis(2, mgp=mgp)
mtext(side=3, line=0.2, paste(format(as.Date(OutputsModel$DatesR[ind[i_pdt]]), "%d/%m/%Y"), sep=""), font=2, cex=1.4)
mtext(side=2, line=2, "P [mm/j]")
# barplot(OutputsModel$Precip[ind], axes=FALSE, ylim=ylim, col=col_bars, border=NA)
# grid()
# abline(v=tmp_P[i_pdt], col="red", lwd=0.8, lty=2)
# barplot(OutputsModel$Precip[ind], axes=FALSE, ylim=ylim, col=col_bars, border=NA, add=TRUE)
# axis(2, mgp=mgp)
# mtext(side=3, line=0.2, paste(format(as.Date(OutputsModel$DatesR[ind[i_pdt]]), "%d/%m/%Y"), sep=""), font=2, cex=1.4)
# mtext(side=2, line=2, "P [mm/j]")
# box()
par(mar = c(2, 4, 1, 0), mgp = mgp)
plot(OutputsModel$Dates, OutputsModel$Precip, type = "h", col = "royalblue", 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("white", alpha.f = 0.75))
abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
box()
# ETP
par(new=TRUE)
ylim <- c(0,10)
col_pts <- c(rep(col_E, i_pdt), rep("grey90", n_pdt-i_pdt))
barplot(rep(0,n_pdt), axes=FALSE, ylim=ylim, col=NA, border=NA)
points(x=tmp_P, y=OutputsModel$PotEvap[ind], col=col_pts, cex=0.8, pch=16)
axis(4, mgp=mgp, col.axis=col_E)
mtext(side=4, line=2, "ETP [mm/j]", col=col_E)
# par(new=TRUE)
# ylim <- c(0,10)
# col_pts <- c(rep(col_E, i_pdt), rep("grey90", n_pdt-i_pdt))
# barplot(rep(0,n_pdt), axes=FALSE, ylim=ylim, col=NA, border=NA)
# points(x=tmp_P, y=OutputsModel$PotEvap[ind], col=col_pts, cex=0.8, pch=16)
# axis(4, mgp=mgp, col.axis=col_E)
# mtext(side=4, line=2, "ETP [mm/j]", col=col_E)
par(mar = c(2, 4, 1, 0), mgp = mgp)
plot(OutputsModel$Dates, OutputsModel$PotEvap, pch = 19, col = "green4", xaxt = "n", ylab = "evapo. [mm/d]")
rect(xleft = EventDate, ybottom = par("usr")[3], xright = par("usr")[2], ytop = par("usr")[4], col = adjustcolor("white", alpha.f = 0.75))
abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
box()
##################################################################################
# DEBIT
##################################################################################
# Parametres
# ylim <- c(0, 10)
# tmp_col_Q <- c(rep(col_Q, i_pdt), rep("grey90", n_pdt-i_pdt))
# ind <- which(as.Date(BasinObs$DatesR) %in% dates_epi)
# Cadre
# par(mar=c(2, 8, 1, 8), mgp=mgp)
# plot(x=dates_epi, y=BasinObs$Qmm[ind], pch=16, cex=0.8, col=tmp_col_Q, xlab="", ylab="", xlim=range(dates_epi), ylim=ylim)
# grid()
# abline(v=dates_epi[i_pdt], col="red", lwd=0.8, lty=2)
# points(x=dates_epi, y=BasinObs$Qmm[ind], pch=16, cex=0.8, col=tmp_col_Q)
# lines(x=dates_epi[1:i_pdt], y=BasinObs$Qmm[ind][1:i_pdt], lwd=1, col=col_Q)
# axis(2, mgp=mgp)
# mtext(side=2, line=2, "Q [mm/j]")
# box()
par(mar = c(2, 4, 1, 0), 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("white", alpha.f = 0.75))
abline(v = EventDate, col = "grey", lwd = 2, lty = 2)
box()
# Simus
# lines(x=dates_epi[1:i_pdt], y=OutputsModel$Qsim[1:i_pdt], lwd=1, col="royalblue")
##################################################################################
......@@ -232,10 +256,10 @@ i_pdt <- 150
##################################################################################
# Cadre
par(mar=rep(1,4))
plot(x=0, type="n", xlab="", ylab="", axes=FALSE, ylim=c(0,1000), xlim=c(0,1000), asp=1)
par(mar = rep(0.2, 4))
plot(x = 0, type = "n", xlab = "", ylab = "", axes = FALSE, ylim = c(0,1000), xlim = c(0,1000), asp = 1)
# Le mod?le
# Le modele
rect(xleft=0, xright=1000, ybottom=50, ytop=950, col=col_modele, border=NA)
segments(x0=0, y0=50, x1=1000, y1=50, lwd=3)
segments(x0=0, y0=50, x1=0, y1=950, lwd=3)
......@@ -248,7 +272,7 @@ i_pdt <- 150
# ENTREES / SORTIES
##################################################################################
# Entr?es P et ETP
# Entrees P et ETP
text(x=xy_P[1], y=xy_P[2], labels="P", pos=3, font=2, col="black", cex=1.6)
text(x=xy_E[1], y=xy_E[2], labels="E", pos=3, font=2, col="black", cex=1.6)
......@@ -260,7 +284,7 @@ i_pdt <- 150
# NEUTRALISATION DE P
##################################################################################
# Param?tres
# Parametres
tmp_decal <- 20
# Interception
......@@ -302,20 +326,20 @@ i_pdt <- 150
boxed.labels(x=x_Ps, y=y_rendement, labels="Ps", col="black", bg=col_modele, border=NA, xpad=xpad, ypad=ypad)
boxed.labels(x=x_PnPs, y=y_rendement, labels="Pn-Ps", col="black", bg=col_modele, border=NA, xpad=xpad, ypad=ypad)
# R?servoir de production
# Reservoir de production
rect(xleft=xy_min_PROD[1], xright=xy_min_PROD[1]+base_res, ybottom=xy_min_PROD[2],
ytop=xy_min_PROD[2]+OutputsModel$Prod[i_pdt]*fact_res, col="royalblue", border=NA)
segments(x0=xy_min_PROD[1], x1=xy_min_PROD[1]+base_res, y0=xy_min_PROD[2], y1=xy_min_PROD[2], col="black")
segments(x0=xy_min_PROD[1], x1=xy_min_PROD[1], y0=xy_min_PROD[2], y1=xy_min_PROD[2]+Param[1]*fact_res, col="black")
segments(x0=xy_min_PROD[1]+base_res, x1=xy_min_PROD[1]+base_res, y0=xy_min_PROD[2], y1=xy_min_PROD[2]+Param[1]*fact_res, col="black")
text(x=30, y=xy_min_PROD[2]+Param[1]*fact_res/3, "R?servoir de\nproduction", cex=1.4, col="black", pos=4)
text(x=30, y=xy_min_PROD[2]+Param[1]*fact_res/3, "prod. store", cex=1.4, col="black", pos=4)
##################################################################################
# PERCOLATION
##################################################################################
# R?servoir de production vers Pr
# Reservoir de production vers Pr
segments(x0=xy_min_PROD[1]+base_res/2, x1=xy_min_PROD[1]+base_res/2, y0=xy_min_PROD[2], y1=y_percolation)
segments(x0=xy_min_PROD[1]+base_res/2, x1=x_PnPs, y0=y_percolation, y1=y_percolation)
......@@ -334,7 +358,7 @@ i_pdt <- 150
# SEPARATION DE PR
##################################################################################
# param?tres
# parametres
tmp_decal <- (y_percolation - y_entreeHU) / 2
# Pr vers HU1
......@@ -354,14 +378,14 @@ i_pdt <- 150
# HYDROGRAMME UNITAIRE 1 (AUBE)
##################################################################################
# Entr?e de HU1
# Entree de HU1
if(OutputsModel$PR[i_pdt] != 0) {
tmp_triangle <- create_polygon(x_center=xy_Q9[1], y_center=y_entreeHU+tmp_decal/2,
cex=OutputsModel$PR[i_pdt]*max_triangle / cex_max_poly, dir="B")
polygon(x=tmp_triangle[,1], y=tmp_triangle[,2], border=NA, col="royalblue")
}
# Fl?che vers HU1
# Fleche vers HU1
arrows(x0=xy_Q9[1], y0=y_entreeHU, x1=xy_Q9[1]+30, y1=y_entreeHU-10, length=0.075, angle=20)
# Remplissage de HU1
......@@ -413,7 +437,7 @@ i_pdt <- 150
segments(x0=xy_HU1[1], y0=xy_HU1[2], x1=(cos(angle2)*radius2) + xy_HU1[1], y1=(sin(angle2)*radius2) + xy_HU1[2])
}
# Fl?che sortant de HU1
# Fleche sortant de HU1
arrows(x0=xy_Q9[1]+30, y0=y_out_aubes+10, x1=xy_Q9[1], y1=y_out_aubes, length=0.075, angle=20)
# Sorties de HU1
......@@ -431,14 +455,14 @@ i_pdt <- 150
# HYDROGRAMME UNITAIRE 2
##################################################################################
# Entr?e de HU2
# Entree de HU2
if(OutputsModel$PR[i_pdt] != 0) {
tmp_triangle <- create_polygon(x_center=xy_Q1[1], y_center=y_entreeHU+tmp_decal/2,
cex=OutputsModel$PR[i_pdt]*0.1*max_triangle / cex_max_poly, dir="B")
polygon(x=tmp_triangle[,1], y=tmp_triangle[,2], border=NA, col="royalblue")
}
# Fl?che vers HU2
# Fleche vers HU2
arrows(x0=xy_Q1[1], y0=y_entreeHU, x1=xy_Q1[1]+30, y1=y_entreeHU-10, length=0.075, angle=20)
# Remplissage de HU2
......@@ -490,7 +514,7 @@ i_pdt <- 150
# segments(x0=xy_HU2[1], y0=xy_HU2[2], x1=(cos(angle2)*radius2) + xy_HU2[1], y1=(sin(angle2)*radius2) + xy_HU2[2])
# }
#
# Fl?che sortant de HU2
# Fleche sortant de HU2
arrows(x0=xy_Q1[1]+30, y0=y_out_aubes+10, x1=xy_Q1[1], y1=y_out_aubes, length=0.075, angle=20)
# Sorties de HU2
......@@ -523,18 +547,18 @@ i_pdt <- 150
# RESERVOIR DE ROUTAGE
##################################################################################
# Triche pour la taille du r?servoire de routage
# Triche pour la taille du reservoire de routage
tmp_triche <- 80
# R?servoir de routage
# Reservoir de routage
rect(xleft=xy_min_ROUT[1], xright=xy_min_ROUT[1]+base_res, ybottom=xy_min_ROUT[2],
ytop=xy_min_ROUT[2]+OutputsModel$Rout[i_pdt]*fact_res+tmp_triche, col="royalblue", border=NA)
segments(x0=xy_min_ROUT[1], x1=xy_min_ROUT[1]+base_res, y0=xy_min_ROUT[2], y1=xy_min_ROUT[2], col="black")
segments(x0=xy_min_ROUT[1], x1=xy_min_ROUT[1], y0=xy_min_ROUT[2], y1=xy_min_ROUT[2]+Param[3]*fact_res+tmp_triche, col="black")
segments(x0=xy_min_ROUT[1]+base_res, x1=xy_min_ROUT[1]+base_res, y0=xy_min_ROUT[2], y1=xy_min_ROUT[2]+Param[3]*fact_res+tmp_triche, col="black")
text(x=50, y=xy_min_ROUT[2]+Param[1]*fact_res/3, "R?servoir de\nroutage", cex=1.4, col="black", pos=4)
text(x=50, y=xy_min_ROUT[2]+Param[1]*fact_res/3, "routing store", cex=1.4, col="black", pos=4)
# Sorties du r?servoir
# Sorties du reservoir
segments(x0=xy_min_ROUT[1]+base_res/2, x1=xy_min_ROUT[1]+base_res/2, y0=xy_min_ROUT[2], y1=y_routage, col="black")
segments(x0=xy_min_ROUT[1]+base_res/2, x1=xy_Q[1], y0=y_routage, y1=y_routage)
......@@ -556,28 +580,6 @@ i_pdt <- 150
segments(x0=xy_Q[1], x1=xy_Q[1], y0=y_routage, y1=xy_Q[2]+10)
##################################################################################
# DEBIT
##################################################################################
# Param?tres
ylim <- c(0, 10)
tmp_col_Q <- c(rep(col_Q, i_pdt), rep("grey90", n_pdt-i_pdt))
ind <- which(as.Date(BasinObs$DatesR) %in% dates_epi)
# Cadre
par(mar=c(2, 8, 1, 8), mgp=mgp)
plot(x=dates_epi, y=BasinObs$Qmm[ind], pch=16, cex=0.8, col=tmp_col_Q, xlab="", ylab="", xlim=range(dates_epi), ylim=ylim)
grid()
abline(v=dates_epi[i_pdt], col="red", lwd=0.8, lty=2)
points(x=dates_epi, y=BasinObs$Qmm[ind], pch=16, cex=0.8, col=tmp_col_Q)
lines(x=dates_epi[1:i_pdt], y=BasinObs$Qmm[ind][1:i_pdt], lwd=1, col=col_Q)
axis(2, mgp=mgp)
mtext(side=2, line=2, "Q [mm/j]")
box()
# Simus
lines(x=dates_epi[1:i_pdt], y=OutputsModel$Qsim[1:i_pdt], lwd=1, col="royalblue")
......
shiny.SimGR <- function(ObsBV = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Qobs = NULL, TempMean = NULL,
ZInputs = NULL, HypsoData = NULL, NLayers = 5,
Param = c(200, 0, 100, 2), WupPer = NULL, SimPer) {
Param = c(200, 0, 100, 2), WupPer = NULL, SimPer = NULL) {
.GlobalEnv$.SimGR.args <- list(ObsBV = BasinObs2, NLayers = NLayers,
.GlobalEnv$.SimGR.args <- list(ObsBV = BasinObs2,
DatesR = DatesR, Precip = Precip, PotEvap = PotEvap, Qobs = Qobs, TempMean = TempMean,
ZInputs = ZInputs, HypsoData = HypsoData, NLayers = NLayers,
Param = Param, WupPer = WupPer, SimPer = SimPer)
on.exit(rm(.SimGR.args, envir = .GlobalEnv))
......
# server.R
shinyServer(function(input, output, session) {
# output$Setup <- renderUI({
output$myPlot <- renderPlot({
TMGR <- airGRscholar:::TypeModelGR(input$TypeModel)
Param <- c(input$X1, input$X2, input$X3, input$X4, input$X5, input$X6)[seq_len(gsub("(GR)(\\d{1})(.*)", "\\2", input$TypeModel))]
if (input$CemaNeige == "CemaNeige") {
Param <- c(input$X1, input$X2, input$X3, input$X4, input$X5, input$X6)[seq_len(TMGR$NbParam)]#seq_len(gsub("(GR)(\\d{1})(.*)", "\\2", input$TypeModel))
if (input$CemaNeige == "CemaNeige") {#TypeModelGR(input$TypeModel)$CemaNeige) {
Param <- c(Param, input$C1, input$C2)
}
OBS <- ObsGR(ObsBV = .SimGR.args$ObsBV, TypeModel = input$TypeModel,
CemaNeige = ifelse(input$CemaNeige == "CemaNeige", TRUE, FALSE),
CemaNeige = input$CemaNeige == "CemaNeige",
Precip = .SimGR.args$Precip, PotEvap = .SimGR.args$PotEvap, Qobs = .SimGR.args$Qobs, TempMean = .SimGR.args$TempMean,
ZInputs = .SimGR.args$ZInputs, HypsoData = .SimGR.args$HypsoData,
NLayers = .SimGR.args$NLayers)
SIM <- SimGR(ObsGR = OBS, Param = Param, WupPer = .SimGR.args$WupPer, SimPer = .SimGR.args$SimPer, verbose = FALSE)
zz <- ifelse(!exists("zz"), 1, input$CalButton+1)
if (zz <= input$CalButton) {
isolate({
CAL <- invisible(CalGR(ObsGR = OBS, WupPer = .SimGR.args$WupPer, CalPer = .SimGR.args$SimPer, verbose = FALSE))
SIM <- SimGR(ObsGR = OBS, CalGR = CAL, WupPer = .SimGR.args$WupPer, SimPer = .SimGR.args$SimPer, verbose = FALSE)
Param_Cal <- CAL$OutputsCalib$ParamFinalR
observe({
updateSliderInput(session, inputId = "X1", value = Param_Cal[1L])
updateSliderInput(session, inputId = "X2", value = Param_Cal[2L])
updateSliderInput(session, inputId = "X3", value = Param_Cal[3L])
updateSliderInput(session, inputId = "X4", value = Param_Cal[4L])
# updateSliderInput(session, inputId = "X5", value = Param_Cal[5L])
# updateSliderInput(session, inputId = "X6", value = Param_Cal[6L])
updateActionButton(session, "CalButton", label = "Model calibrated")
})
})
} else {
# print(input$CalButton)
SIM <- SimGR(ObsGR = OBS, Param = Param, WupPer = .SimGR.args$WupPer, SimPer = .SimGR.args$SimPer, verbose = FALSE)
}
# })
# if (input$CalButton) {
# if (zz <= input$CalButton) { #(input$CalButton >= 1)
# isolate({
# CAL <- CalGR(ObsGR = OBS, WupPer = .SimGR.args$WupPer, CalPer = .SimGR.args$SimPer, verbose = FALSE)
# SIM <- SimGR(ObsGR = OBS, CalGR = CAL, WupPer = .SimGR.args$WupPer, SimPer = .SimGR.args$SimPer, verbose = FALSE)
# Param_Cal <- CAL$OutputsCalib$ParamFinalR
# observe({
# # req(input$update)
# # Control the value, min, max, and step.
# # Step size is 2 when input value is even; 1 when value is odd.
# updateSliderInput(session, inputId = "X1", value = Param_Cal[1L])
# updateSliderInput(session, inputId = "X2", value = Param_Cal[2L])
# updateSliderInput(session, inputId = "X3", value = Param_Cal[3L])
# updateSliderInput(session, inputId = "X4", value = Param_Cal[4L])
# updateActionButton(session, "CalButton", label = "New label")
# # req(input$CalButton, cancelOutput = TRUE)
# })
# zz <- input$CalButton+2
# })
# } else {
# isolate({
# SIM <- SimGR(ObsGR = OBS, Param = Param, WupPer = .SimGR.args$WupPer, SimPer = .SimGR.args$SimPer, verbose = FALSE)
# updateSliderInput(session, inputId = "X1", value = Param[1L])
# updateSliderInput(session, inputId = "X2", value = Param[2L])
# updateSliderInput(session, inputId = "X3", value = Param[3L])
# updateSliderInput(session, inputId = "X4", value = Param[4L])
# updateActionButton(session, "CalButton", label = "REINITIALIZED")
# zz <- input$CalButton+2
# })
# }
#CRT <- ErrorCrit(
......@@ -23,15 +82,14 @@ shinyServer(function(input, output, session) {
getplotType <- reactive({
switch(input$plotType,
"time series" = 1,
"synthesis" = 2,
"diagram" = 3)#,
"Model performance" = 1,
"Flow time series" = 2,
"State variables" = 3,
"Model diagram" = 4)#,
# "user-defined" = 3)
})
observe({
# Control the value, min, max, and step.
# Step size is 2 when input value is even; 1 when value is odd.
updateSliderInput(session, inputId = "Event", value = input$Event,
min = input$Period[1L], max = input$Period[2L])
})
......@@ -54,18 +112,36 @@ shinyServer(function(input, output, session) {
# }
# IndPlot <- seq(from = IndStart2, to = IndStop2, by = 1)
IndPlot <- which(OutputsModel$DatesR >= input$Period[1L] & OutputsModel$DatesR <= input$Period[2L])
aaa <- sapply(OutputsModel[1:15], function(x) x[IndPlot])
aaa <- c(aaa, Qobs = list(SIM$Qobs[IndPlot]))
if (getplotType() == 4) {
observe({
updateSelectInput(session, inputId = "TypeModel", choice = c("GR4J"))
updateSelectInput(session, inputId = "CemaNeige", choice = c("None"))
})
# } else {
# observe({
# updateSelectInput(session, inputId = "TypeModel", choice = c("GR4J", "GR5J", "GR6J"))
# updateSelectInput(session, inputId = "CemaNeige", choice = c("no", "CemaNeige"))
# })
} else {
observe({
updateSelectInput(session, inputId = "TypeModel", choice = c("GR4J", "GR5J", "GR6J"), selected = input$TypeModel)
updateSelectInput(session, inputId = "CemaNeige", choice = c("None", "CemaNeige"), selected = input$CemaNeige)
})
}
if (getplotType() == 1) {
if (getplotType() == 2) {
par(mfrow = c(1, 1))#SIM$Qobs[RunOptions$IndPeriod_Run][IndPlot]
plot(OutputsModel$DatesR[IndPlot], SIM$Qobs[IndPlot], type = "l", lwd = 1, col = "black", xlab = "", ylab = "Q [mm/d]")
lines(OutputsModel$DatesR[IndPlot], OutputsModel$Qsim[IndPlot], lwd = 1, col = "red")
legend("topright", bty = "n", c("obs.", "sim."), col = c("black", "red"), lwd = 2)
mtext(side = 3, line = 1, paste("Period ", format(OutputsModel$DatesR[IndPlot[1]], "%d/%m/%Y"), " - ", format(OutputsModel$DatesR[tail(IndPlot, 1)], "%d/%m/%Y"), sep = ""))
plot(OutputsModel$DatesR[IndPlot], SIM$Qobs[IndPlot], type = "l", lwd = 1, col = "black", xlab = "", ylab = "flow [mm/d]")
lines(OutputsModel$DatesR[IndPlot], OutputsModel$Qsim[IndPlot], lwd = 1, col = "orangered")
legend("topright", bty = "n", c("obs.", "sim."), col = c("black", "orangered"), lwd = 2)
# mtext(side = 3, line = 1, paste("Period ", format(OutputsModel$DatesR[IndPlot[1]], "%d/%m/%Y"), " - ", format(OutputsModel$DatesR[tail(IndPlot, 1)], "%d/%m/%Y"), sep = ""))
# dyplot(SIM)
}
if (getplotType() == 2) {
if (getplotType() == 1) {
plot_OutputsModel(OutputsModel = OutputsModel, Qobs = SIM$Qobs, IndPeriod_Plot = IndPlot)
}
......@@ -85,9 +161,27 @@ shinyServer(function(input, output, session) {
# }
# }
if (getplotType() == 4) {
airGRscholar:::DiagramGR4J(OutputsModel = aaa, Param = Param, SimPer = input$Period, EventDate = input$Event)
}
if (getplotType() == 3) {
airGRscholar:::DiagramGR4J(OutputsModel = OutputsModel, Param = Param, SimPer = input$Period, EventDate = input