Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
HYCAR-Hydro
airGRteaching
Commits
a5f6e809
Commit
a5f6e809
authored
Oct 02, 2017
by
unknown
Browse files
v0.1.7.0 management of package imports
parent
0ec29fe7
Changes
6
Hide whitespace changes
Inline
Side-by-side
DESCRIPTION
View file @
a5f6e809
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.15
Date: 2017-
09-29
Version: 0.1.
7.0
Date: 2017-
10-01
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, shinyjs, plotrix, markdown
...
...
NAMESPACE
View file @
a5f6e809
...
...
@@ -41,8 +41,11 @@ import(graphics)
import(grDevices)
import(utils)
import(airGR)
import
(
xts)
import
From(xts,
xts)
import(dygraphs)
import(shiny)
importFrom(shinyjs, useShinyjs)
importFrom(shinyjs, enable)
importFrom(shinyjs, disable)
import(markdown)
importFrom(plotrix, boxed.labels)
\ No newline at end of file
R/Utils.R
View file @
a5f6e809
...
...
@@ -274,10 +274,10 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
y0
=
y_interception
,
y1
=
y_rendement
)
# Ecriture
boxed.labels
(
x
=
xy_P
[
1
],
y
=
y_interception
,
labels
=
"Pn"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
boxed.labels
(
x
=
xy_E
[
1
],
y
=
y_interception
,
labels
=
"En"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
xy_P
[
1
],
y
=
y_interception
,
labels
=
"Pn"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
xy_E
[
1
],
y
=
y_interception
,
labels
=
"En"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# ETP
if
(
OutputsModel
$
PotEvap
[
i_pdt
]
!=
0
)
{
...
...
@@ -309,8 +309,8 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
# --------------------------------------------------------------------------------
# Es
boxed.labels
(
x
=
xy_E
[
1
],
y
=
y_rendement
,
labels
=
"Es"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
xy_E
[
1
],
y
=
y_rendement
,
labels
=
"Es"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# Evaporation reelle
if
(
OutputsModel
$
AE
[
i_pdt
]
!=
0
)
{
...
...
@@ -320,10 +320,10 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
}
# Ps et Pn - Ps
boxed.labels
(
x
=
x_Ps
,
y
=
y_rendement
,
labels
=
"Ps"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
boxed.labels
(
x
=
x_PnPs
,
y
=
y_rendement
,
labels
=
"Pn - Ps"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
x_Ps
,
y
=
y_rendement
,
labels
=
"Ps"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
x_PnPs
,
y
=
y_rendement
,
labels
=
"Pn - Ps"
,
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
,
...
...
@@ -350,8 +350,8 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
y0
=
y_percolation
,
y1
=
y_percolation
)
# Perc
boxed.labels
(
x
=
xy_min_PROD
[
1
]
+
base_res
/
2
,
y
=
y_percolation
,
labels
=
"Perc."
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
xy_min_PROD
[
1
]
+
base_res
/
2
,
y
=
y_percolation
,
labels
=
"Perc."
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# Valeur de Perc
if
(
OutputsModel
$
Perc
[
i_pdt
]
!=
0
)
{
...
...
@@ -386,8 +386,8 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
y0
=
y_entreeUH
+
tmp_decal
/
2
,
y1
=
y_routage
)
# Pr
boxed.labels
(
x
=
x_PnPs
,
y
=
y_percolation
,
labels
=
"Pr"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
x_PnPs
,
y
=
y_percolation
,
labels
=
"Pr"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# Pr
if
(
OutputsModel
$
PR
[
i_pdt
]
!=
0
)
{
...
...
@@ -460,8 +460,8 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
y0
=
y_entreeUH
-3
*
tmp_decal
,
y1
=
y_routage
)
# Pr
boxed.labels
(
x
=
x_PnPs
,
y
=
y_percolation
,
labels
=
"Pr"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
x_PnPs
,
y
=
y_percolation
,
labels
=
"Pr"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# --------------------------------------------------------------------------------
...
...
@@ -501,8 +501,8 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
cex
=
cex_tri
(
OutputsModel
$
Q9
[
i_pdt
],
fact
=
fact_triangle
,
max
=
cex_max_poly
))
}
boxed.labels
(
x
=
xy_Q9
[
1
],
y
=
xy_Q9
[
2
],
labels
=
"Q9"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
xy_Q9
[
1
],
y
=
xy_Q9
[
2
],
labels
=
"Q9"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# Q1
if
(
OutputsModel
$
Q1
[
i_pdt
]
!=
0
)
{
...
...
@@ -512,7 +512,7 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
segments
(
x0
=
xy_Q
[
1
],
x1
=
xy_Q1
[
1
],
y0
=
y_routage
,
y1
=
y_routage
)
}
boxed.labels
(
x
=
xy_Q1
[
1
],
y
=
xy_Q1
[
2
],
labels
=
"Q1"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
xy_Q1
[
1
],
y
=
xy_Q1
[
2
],
labels
=
"Q1"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# Valeur de Qd
if
(
OutputsModel
$
QD
[
i_pdt
]
!=
0
)
{
...
...
@@ -522,7 +522,7 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
}
# Qd
boxed.labels
(
x
=
xy_Q1
[
1
],
y
=
y_routage
,
labels
=
"Qd"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
xy_Q1
[
1
],
y
=
y_routage
,
labels
=
"Qd"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# --------------------------------------------------------------------------------
# RESERVOIR DE ROUTAGE
...
...
@@ -551,8 +551,8 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
y0
=
y_routage
,
y1
=
y_routage
)
# Qr
boxed.labels
(
x
=
xy_min_ROUT
[
1
]
+
base_res
/
2
,
y
=
y_routage
,
labels
=
"Qr"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
plotrix
::
boxed.labels
(
x
=
xy_min_ROUT
[
1
]
+
base_res
/
2
,
y
=
y_routage
,
labels
=
"Qr"
,
bg
=
col_mod_bg
,
border
=
NA
,
xpad
=
xpad
,
ypad
=
ypad
)
# Valeur de Qr
if
(
OutputsModel
$
QR
[
i_pdt
]
!=
0
)
{
...
...
@@ -582,7 +582,7 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
points
(
x
=
xy_min_ROUT
[
1
]
+
base_res
+100
,
y
=
y_Ech_Q9
,
type
=
"p"
,
pch
=
pch
,
col
=
col_P
,
cex
=
cex_tri
(
OutputsModel
$
AExch1
[
i_pdt
],
fact
=
fact_triangle
,
max
=
cex_max_poly
))
# Actual exchange Q1
arrows
(
x0
=
xy_Q1
[
1
],
x1
=
1025
,
y0
=
y_Ech_Q1
,
y1
=
y_Ech_Q1
,
...
...
@@ -591,7 +591,7 @@ DiagramGR <- function(OutputsModel, Param, SimPer, EventDate, HydroModel) {
points
(
x
=
xy_Q1
[
1
]
+100
,
y
=
y_Ech_Q1
,
type
=
"p"
,
pch
=
pch
,
col
=
col_P
,
cex
=
cex_tri
(
OutputsModel
$
AExch2
[
i_pdt
],
fact
=
fact_triangle
,
max
=
cex_max_poly
))
if
(
HydroModel
==
"GR4J"
)
{
# --------------------------------------------------------------------------------
...
...
R/dyplot.default.R
View file @
a5f6e809
...
...
@@ -35,8 +35,8 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
if
(
!
is.character
(
Qsup.name
))
{
Qsup.name
<-
as.character
(
Qsup.name
)
}
if
(
any
(
class
(
x
)
%in%
"ObsGR"
))
{
data
<-
data.frame
(
DatesR
=
x
$
InputsModel
$
DatesR
,
Precip
=
x
$
InputsModel
$
Precip
,
...
...
@@ -60,8 +60,8 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
data
$
Precip
<-
NULL
}
}
data.xts
<-
xts
(
data
[,
-1L
],
order.by
=
data
$
DatesR
)
data.xts
<-
xts
::
xts
(
data
[,
-1L
],
order.by
=
data
$
DatesR
)
rgba
<-
function
(
x
,
alpha
=
1
)
{
sprintf
(
"rgba(%s, %f)"
,
paste0
(
col2rgb
(
x
),
collapse
=
", "
),
alpha
)
...
...
@@ -85,17 +85,17 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
}
dg
<-
dygraph
(
data.xts
,
main
=
main
)
dg
<-
dySeries
(
dygraph
=
dg
,
name
=
"Qobs"
,
axis
=
'y'
,
color
=
col.Q
[
1L
],
drawPoints
=
TRUE
)
dg
<-
dySeries
(
dygraph
=
dg
,
name
=
"Qsim"
,
axis
=
'y'
,
color
=
col.Q
[
2L
])
dg
<-
dySeries
(
dygraph
=
dg
,
name
=
"Qsup"
,
axis
=
'y'
,
color
=
col.Q
[
3L
],
label
=
Qsup.name
,
strokePattern
=
"dashed"
)
dg
<-
dyStackedBarGroup
(
dygraph
=
dg
,
name
=
grep
(
"^P"
,
colnames
(
data.xts
),
value
=
TRUE
),
axis
=
"y2"
,
color
=
rev
(
col.Precip
))
dg
<-
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
))
dg
<-
dyAxis
(
dygraph
=
dg
,
name
=
"y2"
,
label
=
ylab
[
2L
],
independentTicks
=
FALSE
,
valueRange
=
rev
(
Plim
)
*
c
(
2.99
,
0.01
))
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
=
grep
(
"^P"
,
colnames
(
data.xts
),
value
=
TRUE
),
axis
=
"y2"
,
color
=
rev
(
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
))
dg
<-
dygraphs
::
dyAxis
(
dygraph
=
dg
,
name
=
"y2"
,
label
=
ylab
[
2L
],
independentTicks
=
FALSE
,
valueRange
=
rev
(
Plim
)
*
c
(
2.99
,
0.01
))
if
(
RangeSelector
)
{
dg
<-
dyRangeSelector
(
dygraph
=
dg
,
height
=
15
)
dg
<-
dygraphs
::
dyRangeSelector
(
dygraph
=
dg
,
height
=
15
)
}
if
(
plot.na
)
{
naQ_rle
<-
rle
(
is.na
(
data
$
Qobs
))
...
...
@@ -103,22 +103,22 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
naQ_ids
<-
naQ_ide
-
naQ_rle
$
lengths
[
naQ_rle
$
values
]
-1
IDna
<-
data.frame
(
start
=
naQ_ids
,
end
=
naQ_ide
)
for
(
i
in
seq_len
(
nrow
(
IDna
)))
{
dg
<-
dyShading
(
dygraph
=
dg
,
from
=
as.character
(
data
$
DatesR
)[
IDna
[
i
,
"start"
]],
to
=
as.character
(
data
$
DatesR
)[
IDna
[
i
,
"end"
]],
color
=
col.na
)
dg
<-
dygraphs
::
dyShading
(
dygraph
=
dg
,
from
=
as.character
(
data
$
DatesR
)[
IDna
[
i
,
"start"
]],
to
=
as.character
(
data
$
DatesR
)[
IDna
[
i
,
"end"
]],
color
=
col.na
)
}
}
if
(
Roller
)
{
dg
<-
dyRoller
(
dygraph
=
dg
,
rollPeriod
=
5
)
dg
<-
dygraphs
::
dyRoller
(
dygraph
=
dg
,
rollPeriod
=
5
)
}
if
(
is.numeric
(
Roller
))
{
dg
<-
dyRoller
(
dygraph
=
dg
,
rollPeriod
=
Roller
)
dg
<-
dygraphs
::
dyRoller
(
dygraph
=
dg
,
rollPeriod
=
Roller
)
}
if
(
any
(
LegendShow
%in%
c
(
"follow"
,
"auto"
,
"always"
,
"onmouseover"
,
"never"
)))
{
dg
<-
dyLegend
(
dygraph
=
dg
,
show
=
LegendShow
[
1L
])
dg
<-
dygraphs
::
dyLegend
(
dygraph
=
dg
,
show
=
LegendShow
[
1L
])
}
dg
<-
dyOptions
(
dygraph
=
dg
,
useDataTimezone
=
TRUE
)
dg
<-
dygraphs
::
dyOptions
(
dygraph
=
dg
,
useDataTimezone
=
TRUE
)
return
(
dg
)
...
...
inst/ShinyGR/server.R
View file @
a5f6e809
...
...
@@ -310,7 +310,7 @@ shinyServer(function(input, output, session) {
## Plot flow time series
output
$
dyPlotTS
<-
renderDygraph
({
output
$
dyPlotTS
<-
dygraphs
::
renderDygraph
({
if
(
length
(
.GlobalEnv
$
.ShinyGR.hist
)
==
2
&
input
$
ShowOldQsim
==
"Yes"
)
{
QsimOld
<-
getRES
()
$
SIMold
[[
1
]]
$
Qsim
}
else
{
...
...
@@ -320,31 +320,31 @@ shinyServer(function(input, output, session) {
op
<-
getPlotPar
()
$
par
dg1
<-
dyplot
(
getRES
()
$
SIM
,
Qsup
=
QsimOld
,
Qsup.name
=
"Qold"
,
RangeSelector
=
FALSE
,
LegendShow
=
"auto"
,
col.Q
=
c
(
op
$
fg
,
"orangered"
,
"grey"
),
col.Precip
=
"#428BCA"
)
dg1
<-
dyOptions
(
dg1
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
retainDateWindow
=
FALSE
)
dg1
<-
dyLegend
(
dg1
,
show
=
"follow"
,
width
=
325
)
dg1
<-
dygraphs
::
dyOptions
(
dg1
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
retainDateWindow
=
FALSE
)
dg1
<-
dygraphs
::
dyLegend
(
dg1
,
show
=
"follow"
,
width
=
325
)
})
## Plot state variables stores
output
$
dyPlotSVs
<-
renderDygraph
({
output
$
dyPlotSVs
<-
dygraphs
::
renderDygraph
({
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
)
data.xts
<-
xts
::
xts
(
data
[,
-1L
],
order.by
=
data
$
DatesR
)
op
<-
getPlotPar
()
$
par
dg2
<-
dygraph
(
data.xts
,
group
=
"state_var"
,
ylab
=
"store [mm]"
)
dg2
<-
dyOptions
(
dg2
,
colors
=
c
(
"#00008B"
,
"#008B8B"
),
fillGraph
=
TRUE
,
fillAlpha
=
0.3
,
drawXAxis
=
FALSE
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
retainDateWindow
=
FALSE
)
dg2
<-
dyLegend
(
dg2
,
show
=
"always"
,
width
=
325
)
dg2
<-
dyCrosshair
(
dg2
,
direction
=
"vertical"
)
dg2
<-
dygraphs
::
dygraph
(
data.xts
,
group
=
"state_var"
,
ylab
=
"store [mm]"
)
dg2
<-
dygraphs
::
dyOptions
(
dg2
,
colors
=
c
(
"#00008B"
,
"#008B8B"
),
fillGraph
=
TRUE
,
fillAlpha
=
0.3
,
drawXAxis
=
FALSE
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
retainDateWindow
=
FALSE
)
dg2
<-
dygraphs
::
dyLegend
(
dg2
,
show
=
"always"
,
width
=
325
)
dg2
<-
dygraphs
::
dyCrosshair
(
dg2
,
direction
=
"vertical"
)
})
## Plot state variables Q
output
$
dyPlotSVq
<-
renderDygraph
({
output
$
dyPlotSVq
<-
dygraphs
::
renderDygraph
({
OutputsModel
<-
getRES
()
$
SIM
$
OutputsModel
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
])
...
...
@@ -360,60 +360,60 @@ shinyServer(function(input, output, session) {
}
else
{
data
$
QrExp
<-
NA
}
data.xts
<-
xts
(
data
[,
-1L
],
order.by
=
data
$
DatesR
)
data.xts
<-
xts
::
xts
(
data
[,
-1L
],
order.by
=
data
$
DatesR
)
op
<-
getPlotPar
()
$
par
dg3
<-
dygraph
(
data.xts
,
group
=
"state_var"
,
ylab
=
"flow [mm/d]"
,
main
=
" "
)
dg3
<-
dyOptions
(
dg3
,
fillAlpha
=
1.0
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
titleHeight
=
10
,
retainDateWindow
=
FALSE
)
dg3
<-
dyStackedRibbonGroup
(
dg3
,
name
=
c
(
"Qd"
,
"Qr"
,
"QrExp"
),
color
=
c
(
"#FFD700"
,
"#EE6300"
,
"brown"
),
strokeBorderColor
=
"black"
)
dg3
<-
dySeries
(
dg3
,
name
=
"Qobs"
,
fillGraph
=
FALSE
,
drawPoints
=
TRUE
,
color
=
op
$
fg
)
dg3
<-
dySeries
(
dg3
,
name
=
"Qsim"
,
fillGraph
=
FALSE
,
color
=
"orangered"
)
dg3
<-
dyCrosshair
(
dg3
,
direction
=
"vertical"
)
dg3
<-
dyLegend
(
dg3
,
show
=
"always"
,
width
=
325
)
dg3
<-
dygraphs
::
dygraph
(
data.xts
,
group
=
"state_var"
,
ylab
=
"flow [mm/d]"
,
main
=
" "
)
dg3
<-
dygraphs
::
dyOptions
(
dg3
,
fillAlpha
=
1.0
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
titleHeight
=
10
,
retainDateWindow
=
FALSE
)
dg3
<-
dygraphs
::
dyStackedRibbonGroup
(
dg3
,
name
=
c
(
"Qd"
,
"Qr"
,
"QrExp"
),
color
=
c
(
"#FFD700"
,
"#EE6300"
,
"brown"
),
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"
)
dg3
<-
dygraphs
::
dyCrosshair
(
dg3
,
direction
=
"vertical"
)
dg3
<-
dygraphs
::
dyLegend
(
dg3
,
show
=
"always"
,
width
=
325
)
})
## Plot model diagram precipitation
output
$
dyPlotMDp
<-
renderDygraph
({
output
$
dyPlotMDp
<-
dygraphs
::
renderDygraph
({
# barChartPrecip <- scan(file = system.file("plugins/barChartPrecip.js", package = "airGRteaching"),
# what = "character", quiet = TRUE)
data
<-
data.frame
(
DatesR
=
getRES
()
$
SIM
$
OutputsModel
$
DatesR
,
precip.
=
getRES
()
$
SIM
$
OutputsModel
$
Precip
)
data.xts
<-
xts
(
data
[,
-1L
,
drop
=
FALSE
],
order.by
=
data
$
DatesR
)
data.xts
<-
xts
::
xts
(
data
[,
-1L
,
drop
=
FALSE
],
order.by
=
data
$
DatesR
)
dg4
<-
dygraph
(
data.xts
,
group
=
"mod_diag"
,
ylab
=
"precip. [mm/d]"
)
dg4
<-
dyOptions
(
dg4
,
colors
=
"#428BCA"
,
drawXAxis
=
FALSE
,
retainDateWindow
=
FALSE
)
dg4
<-
dyBarSeries
(
dg4
,
name
=
"precip."
)
dg4
<-
dyAxis
(
dg4
,
name
=
"y"
,
valueRange
=
c
(
max
(
data.xts
[,
"precip."
],
na.rm
=
TRUE
),
-1e-3
))
dg4
<-
dyEvent
(
dg4
,
input
$
Event
,
color
=
"orangered"
)
dg4
<-
dyLegend
(
dg4
,
show
=
"onmouseover"
,
width
=
225
)
dg4
<-
dyCrosshair
(
dg4
,
direction
=
"vertical"
)
dg4
<-
dygraphs
::
dygraph
(
data.xts
,
group
=
"mod_diag"
,
ylab
=
"precip. [mm/d]"
)
dg4
<-
dygraphs
::
dyOptions
(
dg4
,
colors
=
"#428BCA"
,
drawXAxis
=
FALSE
,
retainDateWindow
=
FALSE
)
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"
)
})
## Plot model diagram ETP
output
$
dyPlotMDe
<-
renderDygraph
({
output
$
dyPlotMDe
<-
dygraphs
::
renderDygraph
({
op
<-
getPlotPar
()
$
par
data
<-
data.frame
(
DatesR
=
getRES
()
$
SIM
$
OutputsModel
$
DatesR
,
PET
=
getRES
()
$
SIM
$
OutputsModel
$
PotEvap
)
data.xts
<-
xts
(
data
[,
-1L
,
drop
=
FALSE
],
order.by
=
data
$
DatesR
)
data.xts
<-
xts
::
xts
(
data
[,
-1L
,
drop
=
FALSE
],
order.by
=
data
$
DatesR
)
dg5
<-
dygraph
(
data.xts
,
group
=
"mod_diag"
,
ylab
=
"PET [mm/d]"
,
main
=
" "
)
dg5
<-
dyOptions
(
dg5
,
colors
=
"#A4C400"
,
drawPoints
=
TRUE
,
strokeWidth
=
0
,
pointSize
=
2
,
drawXAxis
=
FALSE
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
titleHeight
=
10
,
retainDateWindow
=
FALSE
)
dg5
<-
dyEvent
(
dg5
,
input
$
Event
,
color
=
"orangered"
)
dg5
<-
dyLegend
(
dg5
,
show
=
"onmouseover"
,
width
=
225
)
dg5
<-
dyCrosshair
(
dg5
,
direction
=
"vertical"
)
dg5
<-
dygraphs
::
dygraph
(
data.xts
,
group
=
"mod_diag"
,
ylab
=
"PET [mm/d]"
,
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
)
dg5
<-
dygraphs
::
dyEvent
(
dg5
,
input
$
Event
,
color
=
"orangered"
)
dg5
<-
dygraphs
::
dyLegend
(
dg5
,
show
=
"onmouseover"
,
width
=
225
)
dg5
<-
dygraphs
::
dyCrosshair
(
dg5
,
direction
=
"vertical"
)
})
## Plot model diagram flow
output
$
dyPlotMDq
<-
renderDygraph
({
output
$
dyPlotMDq
<-
dygraphs
::
renderDygraph
({
if
(
length
(
.GlobalEnv
$
.ShinyGR.hist
)
==
2
&
input
$
ShowOldQsim
==
"Yes"
)
{
QsimOld
<-
getRES
()
$
SIMold
[[
1
]]
$
Qsim
}
else
{
...
...
@@ -430,18 +430,18 @@ shinyServer(function(input, output, session) {
Qobs
=
OutputsModel2
$
Qobs
,
Qsim
=
OutputsModel2
$
Qsim
,
QsimOld
=
OutputsModel2
$
Qold
)
data.xts
<-
xts
(
data
[,
-1L
,
drop
=
FALSE
],
order.by
=
data
$
DatesR
)
data.xts
<-
xts
::
xts
(
data
[,
-1L
,
drop
=
FALSE
],
order.by
=
data
$
DatesR
)
op
<-
getPlotPar
()
$
par
dg6
<-
dygraph
(
data.xts
,
group
=
"mod_diag"
,
ylab
=
"flow [mm/d]"
,
main
=
" "
)
dg6
<-
dyOptions
(
dg6
,
colors
=
c
(
op
$
fg
,
"grey"
,
"orangered"
),
drawPoints
=
TRUE
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
titleHeight
=
10
,
retainDateWindow
=
FALSE
)
dg6
<-
dySeries
(
dg6
,
name
=
"QsimOld"
,
drawPoints
=
FALSE
,
strokePattern
=
"dashed"
)
dg6
<-
dySeries
(
dg6
,
name
=
"Qsim"
,
drawPoints
=
FALSE
)
dg6
<-
dyEvent
(
dg6
,
input
$
Event
,
color
=
"orangered"
)
dg6
<-
dyLegend
(
dg6
,
show
=
"onmouseover"
,
width
=
225
)
dg6
<-
dyCrosshair
(
dg6
,
direction
=
"vertical"
)
dg6
<-
dygraphs
::
dygraph
(
data.xts
,
group
=
"mod_diag"
,
ylab
=
"flow [mm/d]"
,
main
=
" "
)
dg6
<-
dygraphs
::
dyOptions
(
dg6
,
colors
=
c
(
op
$
fg
,
"grey"
,
"orangered"
),
drawPoints
=
TRUE
,
axisLineColor
=
op
$
fg
,
axisLabelColor
=
op
$
fg
,
titleHeight
=
10
,
retainDateWindow
=
FALSE
)
dg6
<-
dygraphs
::
dySeries
(
dg6
,
name
=
"QsimOld"
,
drawPoints
=
FALSE
,
strokePattern
=
"dashed"
)
dg6
<-
dygraphs
::
dySeries
(
dg6
,
name
=
"Qsim"
,
drawPoints
=
FALSE
)
dg6
<-
dygraphs
::
dyEvent
(
dg6
,
input
$
Event
,
color
=
"orangered"
)
dg6
<-
dygraphs
::
dyLegend
(
dg6
,
show
=
"onmouseover"
,
width
=
225
)
dg6
<-
dygraphs
::
dyCrosshair
(
dg6
,
direction
=
"vertical"
)
})
...
...
@@ -487,7 +487,7 @@ shinyServer(function(input, output, session) {
## --------------- Download buttons
## simulation table
##
Download
simulation table
output
$
DownloadTab
<-
downloadHandler
(
filename
=
function
()
{
filename
<-
"TabSim"
...
...
@@ -527,7 +527,7 @@ shinyServer(function(input, output, session) {
}
)
## plots
##
Download
plots
output
$
DownloadPlot
<-
downloadHandler
(
filename
=
function
()
{
filename
<-
switch
(
input
$
PlotType
,
...
...
inst/ShinyGR/ui.R
View file @
a5f6e809
...
...
@@ -101,8 +101,8 @@ navbarPage(title = div("airGRteaching",
h4
(
"Automatic calibration:"
),
fluidRow
(
column
(
width
=
6
,
selectInput
(
"TypeCrit"
,
label
=
"Objective function"
,
choices
=
c
(
"NSE [Q]"
,
"NSE [sqrt(Q)]"
,
"NSE [log(Q)]"
,
"KGE [Q]"
,
"KGE [sqrt(Q)]"
,
"KGE [log(Q)]"
))),
choices
=
c
(
"NSE [Q]"
,
"NSE [sqrt(Q)]"
,
"NSE [log(Q)]"
,
"KGE [Q]"
,
"KGE [sqrt(Q)]"
,
"KGE [log(Q)]"
))),
column
(
width
=
6
,
actionButton
(
"CalButton"
,
label
=
"Run"
,
width
=
"100%"
,
icon
=
icon
(
"refresh"
),
style
=
ifelse
(
.GlobalEnv
$
.ShinyGR.args
$
theme
!=
"Cerulean"
,
...
...
@@ -149,16 +149,16 @@ navbarPage(title = div("airGRteaching",
plotOutput
(
"stPlotMP"
,
width
=
"100%"
,
height
=
"900px"
))),
conditionalPanel
(
condition
=
"input.PlotType == 'Flow time series'"
,
column
(
width
=
10
,
dygraphOutput
(
"dyPlotTS"
,
width
=
"100%"
,
height
=
"400px"
))),
dygraphs
::
dygraphOutput
(
"dyPlotTS"
,
width
=
"100%"
,
height
=
"400px"
))),
conditionalPanel
(
condition
=
"input.PlotType == 'State variables'"
,
column
(
width
=
10
,
dygraphOutput
(
"dyPlotSVs"
,
width
=
"100%"
,
height
=
"325px"
),
dygraphOutput
(
"dyPlotSVq"
,
width
=
"100%"
,
height
=
"355px"
))),
dygraphs
::
dygraphOutput
(
"dyPlotSVs"
,
width
=
"100%"
,
height
=
"325px"
),
dygraphs
::
dygraphOutput
(
"dyPlotSVq"
,
width
=
"100%"
,
height
=
"355px"
))),
conditionalPanel
(
condition
=
"input.PlotType == 'Model diagram'"
,
column
(
width
=
06
,
dygraphOutput
(
"dyPlotMDp"
,
width
=
"100%"
,
height
=
"190px"
),
dygraphOutput
(
"dyPlotMDe"
,
width
=
"100%"
,
height
=
"215px"
),
dygraphOutput
(
"dyPlotMDq"
,
width
=
"100%"
,
height
=
"235px"
)),
dygraphs
::
dygraphOutput
(
"dyPlotMDp"
,
width
=
"100%"
,
height
=
"190px"
),
dygraphs
::
dygraphOutput
(
"dyPlotMDe"
,
width
=
"100%"
,
height
=
"215px"
),
dygraphs
::
dygraphOutput
(
"dyPlotMDq"
,
width
=
"100%"
,
height
=
"235px"
)),
column
(
width
=
04
,
plotOutput
(
"stPlotMD"
,
width
=
"100%"
,
height
=
"665px"
))),
column
(
width
=
02
,
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment