Commit e159c5e2 authored by unknown's avatar unknown
Browse files

v0.1.2.0 shiny.SimGR() now presents a theme argument which allows to change de stylesheet

parent 8767082f
Package: airGRteaching
Type: Package
Title: Tools to Simplify the Use of the airGR Hydrological Package for Education (Including a Shiny Application)
Version: 0.1.1.20
Date: 2017-03-30
Version: 0.1.2.0
Date: 2017-03-31
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")))
Depends: airGR (>= 1.0.5.22)
Imports: xts, dygraphs, shiny, plotrix, markdown
......
......@@ -90,13 +90,19 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
radius2 <- 60
cex_max_poly <- 0.005
par(col.axis = par("fg"))
if (.GlobalEnv$.SimGR.args$theme == "Cyborg") {
col_mod_bg <- rgb(255-245, 255-245, 255-245, maxColorValue = 255)
col_mod_bd <- rgb(255-231, 255-231, 255-231, maxColorValue = 255)
}
# Pas de temps
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)
# 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 <- 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") {
xy <- matrix(NA, nrow = 3, ncol = 2)
......@@ -211,7 +217,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
# 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("white", alpha.f = 0.75), border = NA)
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()
......@@ -225,7 +231,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
# mtext(side = 4, line = 2, "ETP [mm/j]", col = col_E)
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("white", alpha.f = 0.75), border = NA)
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()
......@@ -251,7 +257,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
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("white", alpha.f = 0.75), border = NA)
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()
......@@ -265,6 +271,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
# Cadre
par(mar = rep(0.2, 4))
par(fg = par("fg"))
plot(x = 0, type = "n", xlab = "", ylab = "", axes = FALSE, ylim = c(0, 1000), xlim = c(0, 1000))#, asp = 1)
# Le modele
......@@ -297,7 +304,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
# Interception
segments(x0 = xy_E[1]-50, x1 = xy_P[1]+50, y0 = y_interception+tmp_decal, y1 = y_interception+tmp_decal)
text(x = xy_P[1]+50, y = y_interception+20, labels = "Interception", pos = 4, font = 1, col = "black", cex = 1.4)
text(x = xy_P[1]+50, y = y_interception+20, labels = "Interception", pos = 4, font = 1, col = par("fg"), cex = 1.4)
# P vers Pn
segments(x0 = xy_P[1], x1 = xy_P[1], y0 = xy_P[2], y1 = y_interception+tmp_decal)
......@@ -319,8 +326,8 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
segments(x0 = xy_E[1], x1 = xy_E[1], y0 = y_interception, y1 = y_rendement)
# Ecriture
boxed.labels(x = xy_P[1], y = y_interception, labels = "Pn", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_E[1], y = y_interception, labels = "En", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_P[1], y = y_interception, labels = "Pn", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_E[1], y = y_interception, labels = "En", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
##################################################################################
......@@ -328,20 +335,20 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
##################################################################################
# Es
boxed.labels(x = xy_E[1], y = y_rendement, labels = "Es", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_E[1], y = y_rendement, labels = "Es", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
# Ps et Pn-Ps
boxed.labels(x = x_Ps , y = y_rendement, labels = "Ps" , col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = x_PnPs, y = y_rendement, labels = "Pn-Ps", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = x_Ps , y = y_rendement, labels = "Ps" , col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = x_PnPs, y = y_rendement, labels = "Pn-Ps", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
# 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 = col_R, 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, "Prod. store", cex = 1.4, col = "black", pos = 4)
segments(x0 = xy_min_PROD[1], x1 = xy_min_PROD[1]+base_res, y0 = xy_min_PROD[2], y1 = xy_min_PROD[2], col = par("fg"))
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 = par("fg"))
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 = par("fg"))
text(x = 30, y = xy_min_PROD[2]+Param[1]*fact_res/3, "Prod. store", cex = 1.4, col = par("fg"), pos = 4)
##################################################################################
......@@ -353,7 +360,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
segments(x0 = xy_min_PROD[1]+base_res/2, x1 = x_PnPs, y0 = y_percolation, y1 = y_percolation)
# Perc
boxed.labels(x = xy_min_PROD[1]+base_res/2, y = y_percolation, labels = "Perc.", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_min_PROD[1]+base_res/2, y = y_percolation, labels = "Perc.", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
# Valeur de Perc
if (OutputsModel$Perc[i_pdt] != 0) {
......@@ -380,7 +387,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
segments(x0 = xy_Q1[1], x1 = xy_Q1[1], y0 = y_entreeHU+tmp_decal, y1 = y_routage)
# Pr
boxed.labels(x = x_PnPs, y = y_percolation, labels = "Pr", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = x_PnPs, y = y_percolation, labels = "Pr", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
##################################################################################
......@@ -457,7 +464,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
# }
# Q9
boxed.labels(x = xy_Q9[1], y = xy_Q9[2], labels = "Q9", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_Q9[1], y = xy_Q9[2], labels = "Q9", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
##################################################################################
......@@ -535,7 +542,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
segments(x0 = xy_Q[1], x1 = xy_Q1[1], y0 = y_routage, y1 = y_routage)
# Q1
boxed.labels(x = xy_Q1[1], y = xy_Q1[2], labels = "Q1", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_Q1[1], y = xy_Q1[2], labels = "Q1", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
# Echange
arrows(x0 = xy_Q1[1], y0 = y_Ech_Q1, x1 = 1025 , y1 = y_Ech_Q1, length = 0.075, angle = 20)
......@@ -549,7 +556,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
}
# Qd
boxed.labels(x = xy_Q1[1], y = y_routage, labels = "Qd", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_Q1[1], y = y_routage, labels = "Qd", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
##################################################################################
......@@ -562,13 +569,13 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
# 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 = col_R, 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, "Routing store", cex = 1.4, col = "black", pos = 4)
segments(x0 = xy_min_ROUT[1], x1 = xy_min_ROUT[1]+base_res, y0 = xy_min_ROUT[2], y1 = xy_min_ROUT[2], col = par("fg"))
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 = par("fg"))
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 = par("fg"))
text(x = 50, y = xy_min_ROUT[2]+Param[1]*fact_res/3, "Routing store", cex = 1.4, col = par("fg"), pos = 4)
# 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_min_ROUT[1]+base_res/2, y0 = xy_min_ROUT[2], y1 = y_routage, col = par("fg"))
segments(x0 = xy_min_ROUT[1]+base_res/2, x1 = xy_Q[1], y0 = y_routage, y1 = y_routage)
# Echange
......@@ -576,7 +583,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
arrows(x0 = 1025, y0 = y_Ech_Q9, x1 = xy_min_ROUT[1]+base_res,y1 = y_Ech_Q9, length = 0.075, angle = 20)
# Qr
boxed.labels(x = xy_min_ROUT[1]+base_res/2, y = y_routage, labels = "Qr", col = "black", bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
boxed.labels(x = xy_min_ROUT[1]+base_res/2, y = y_routage, labels = "Qr", col = par("fg"), bg = col_mod_bg, border = NA, xpad = xpad, ypad = ypad)
# Valeur de Qr
if (OutputsModel$QR[i_pdt] != 0) {
......@@ -600,7 +607,7 @@ DiagramGR4J <- function(OutputsModel, Param, SimPer, EventDate) {
} else {
tmp_sens <- "D"
}
# segments(x0 = xy_min_ROUT[1]+base_res/2, x1 = -10, y0 = y_routage+40, y1 = y_routage+40, col = "black")
# segments(x0 = xy_min_ROUT[1]+base_res/2, x1 = -10, y0 = y_routage+40, y1 = y_routage+40, col = par("fg"))
tmp_triangle <- create_polygon(x_center = xy_min_ROUT[1]-base_res/2, y_center = y_routage+40, cex = tmp_Exch*50, dir = tmp_sens)
polygon(x = tmp_triangle[,1], y = tmp_triangle[,2], border = NA, col = col_R)
......
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 = NULL) {
Param = c(200, 0, 100, 2), WupPer = NULL, SimPer = NULL,
theme = "RStudio") {
.GlobalEnv$.SimGR.args <- list(ObsBV = as.list(ObsBV),
DatesR = DatesR, Precip = Precip, PotEvap = PotEvap, Qobs = Qobs, TempMean = TempMean,
ZInputs = ZInputs, HypsoData = HypsoData, NLayers = NLayers,
Param = Param, WupPer = WupPer, SimPer = SimPer)
Param = Param, WupPer = WupPer, SimPer = SimPer,
theme = theme)
on.exit(rm(.SimGR.args, envir = .GlobalEnv))
......
......@@ -120,7 +120,9 @@ shinyServer(function(input, output, session) {
OutputsModel <- getRES()$SIM$OutputsModel
RunOptions <- getRES()$SIM$OptionsSimul
if (.GlobalEnv$.SimGR.args$theme == "Cyborg") {
par(bg = "black", fg = "white", col.axis = "white")
}
observe({
lag <- switch(.TypeModelGR(input$TypeModel)$TimeUnit, "hour" = 3600, "day" = 3600*24, "month" = 3600*24*31, "year" = 366)
......
......@@ -9,7 +9,10 @@ navbarPage(title = div("airGRteaching",
img(src = "logo_irstea_hydro.svg" , height = 350 / 9),
img(src = "logo_irstea.svg" , height = 350 / 9), style = "position:relative; top:-9px;"),
windowTitle = "airGRteaching",
theme = "bootstrap.min_United.css",
theme = switch(.GlobalEnv$.SimGR.args$theme,
RStudio = "",
United = "bootstrap.min_United.css",
Cyborg = "bootstrap.min_Cyborg.css"),
#header = tags$head(tags$style(".navbar {height: 20px;background-color: ##e74c3c;border-color: #c0392b;}")),
#header = tags$head(tags$style(".navbar {height: 20px;background-color: ##ffffff;border-color: #ffffff;}")),
......
......@@ -36,6 +36,8 @@ shiny.SimGR(ObsBV = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
\item{WupPer}{(optional) [character] vector of 2 values to define the warm-up period [\code{"YYYY-mm-dd"} or \code{"YYYY-mm-dd HH:MM:SS"}]}
\item{SimPer}{[character] vector of 2 values to define the simulation period [\code{"YYYY-mm-dd"} or \code{"YYYY-mm-dd HH:MM:SS"}]}
\item{theme}{[character] alternative stylesheet [\code{"RStudio"} (default), \code{"United"} or], \code{"Cyborg"}}
}
......
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