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
c8027afe
Commit
c8027afe
authored
Dec 09, 2020
by
Delaigue Olivier
Browse files
v0.2.10.92 style(R): trim horizontal whitespaces in R functions
parent
511eaeb4
Pipeline
#18274
passed with stages
in 1 minute and 29 seconds
Changes
17
Pipelines
1
Expand all
Hide whitespace changes
Inline
Side-by-side
DESCRIPTION
View file @
c8027afe
Package: airGRteaching
Type: Package
Title: Teaching Hydrological Modelling with the GR Rainfall-Runoff Models ('Shiny' Interface Included)
Version: 0.2.10.9
1
Version: 0.2.10.9
2
Date: 2020-12-09
Authors@R: c(
person("Olivier", "Delaigue", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7668-8468"), email = "airGR@inrae.fr"),
...
...
NEWS.md
View file @
c8027afe
...
...
@@ -4,7 +4,7 @@
### 0.2.10.9
1
Release Notes (2020-12-09)
### 0.2.10.9
2
Release Notes (2020-12-09)
#### New features
...
...
R/CalGR.R
View file @
c8027afe
CalGR
<-
function
(
PrepGR
,
CalCrit
=
c
(
"NSE"
,
"KGE"
,
"KGE2"
,
"RMSE"
),
CalGR
<-
function
(
PrepGR
,
CalCrit
=
c
(
"NSE"
,
"KGE"
,
"KGE2"
,
"RMSE"
),
WupPer
=
NULL
,
CalPer
,
transfo
=
c
(
""
,
"sqrt"
,
"log"
,
"inv"
,
"sort"
),
verbose
=
TRUE
)
{
CalCrit
<-
match.arg
(
arg
=
CalCrit
)
CalCrit
<-
sprintf
(
"ErrorCrit_%s"
,
CalCrit
)
FUN_CRIT
<-
get
(
CalCrit
)
if
(
!
any
(
transfo
%in%
c
(
""
,
"sqrt"
,
"log"
,
"inv"
,
"sort"
)))
{
stop
(
"Non convenient transformation \"transfo\""
)
}
else
{
transfo
<-
transfo
[
1L
]
}
if
(
!
any
(
class
(
PrepGR
)
%in%
"PrepGR"
))
{
stop
(
"Non convenient data for argument \"PrepGR\". Must be of class \"PrepGR\""
)
}
isQobs
<-
!
all
(
is.na
(
PrepGR
$
Qobs
))
if
(
!
isQobs
)
{
stop
(
"\"PrepGR\" does not contain any Qobs values. It is not possible to calibrate the model"
)
}
WupInd
<-
NULL
if
(
!
is.null
(
WupPer
))
{
WupPer
<-
as.POSIXct
(
WupPer
,
tz
=
"UTC"
)
...
...
@@ -37,7 +37,7 @@ CalGR <- function(PrepGR, CalCrit = c("NSE", "KGE", "KGE2", "RMSE"),
}
}
}
CalPer
<-
as.POSIXct
(
CalPer
,
tz
=
"UTC"
)
if
(
length
(
CalPer
)
!=
2
)
{
stop
(
"Calibration period \"CalPer\" must be of length 2"
)
...
...
@@ -51,36 +51,36 @@ CalGR <- function(PrepGR, CalCrit = c("NSE", "KGE", "KGE2", "RMSE"),
CalInd
<-
which
(
PrepGR
$
InputsModel
$
DatesR
==
CalPer
[
1
])
:
which
(
PrepGR
$
InputsModel
$
DatesR
==
CalPer
[
2
])
}
}
MOD_opt
<-
CreateRunOptions
(
FUN_MOD
=
get
(
PrepGR
$
TypeModel
),
InputsModel
=
PrepGR
$
InputsModel
,
IndPeriod_WarmUp
=
WupInd
,
IndPeriod_Run
=
CalInd
,
verbose
=
FALSE
)
MOD_crt
<-
CreateInputsCrit
(
FUN_CRIT
=
FUN_CRIT
,
InputsModel
=
PrepGR
$
InputsModel
,
MOD_opt
<-
CreateRunOptions
(
FUN_MOD
=
get
(
PrepGR
$
TypeModel
),
InputsModel
=
PrepGR
$
InputsModel
,
IndPeriod_WarmUp
=
WupInd
,
IndPeriod_Run
=
CalInd
,
verbose
=
FALSE
)
MOD_crt
<-
CreateInputsCrit
(
FUN_CRIT
=
FUN_CRIT
,
InputsModel
=
PrepGR
$
InputsModel
,
RunOptions
=
MOD_opt
,
Obs
=
PrepGR
$
Qobs
[
CalInd
],
transfo
=
transfo
)
CAL_opt
<-
CreateCalibOptions
(
FUN_MOD
=
get
(
PrepGR
$
TypeModel
),
FUN_CALIB
=
Calibration_Michel
)
CAL
<-
Calibration
(
InputsModel
=
PrepGR
$
InputsModel
,
RunOptions
=
MOD_opt
,
InputsCrit
=
MOD_crt
,
CalibOptions
=
CAL_opt
,
FUN_MOD
=
get
(
PrepGR
$
TypeModel
),
FUN_CRIT
=
FUN_CRIT
,
FUN_CALIB
=
Calibration_Michel
,
verbose
=
verbose
)
SIM
<-
RunModel
(
InputsModel
=
PrepGR
$
InputsModel
,
RunOptions
=
MOD_opt
,
Param
=
CAL
$
ParamFinalR
,
FUN_MOD
=
get
(
PrepGR
$
TypeModel
))
CalGR
<-
list
(
OptionsCalib
=
MOD_opt
,
Qobs
=
PrepGR
$
Qobs
[
CalInd
],
OutputsCalib
=
CAL
,
OutputsModel
=
SIM
,
TypeModel
=
PrepGR
$
TypeModel
,
CalCrit
=
CalCrit
,
PeriodModel
=
list
(
WarmUp
=
as.POSIXct
(
PrepGR
$
InputsModel
$
DatesR
[
range
(
MOD_opt
$
IndPeriod_WarmUp
)],
tz
=
"UTC"
),
Run
=
CalPer
))
class
(
CalGR
)
<-
c
(
"CalGR"
,
"GR"
,
"airGRt"
)
return
(
CalGR
)
}
\ No newline at end of file
return
(
CalGR
)
}
R/PrepGR.R
View file @
c8027afe
PrepGR
<-
function
(
ObsDF
=
NULL
,
DatesR
=
NULL
,
Precip
=
NULL
,
PotEvap
=
NULL
,
Qobs
=
NULL
,
TempMean
=
NULL
,
PrepGR
<-
function
(
ObsDF
=
NULL
,
DatesR
=
NULL
,
Precip
=
NULL
,
PotEvap
=
NULL
,
Qobs
=
NULL
,
TempMean
=
NULL
,
ZInputs
=
NULL
,
HypsoData
=
NULL
,
NLayers
=
5
,
HydroModel
,
CemaNeige
=
FALSE
)
{
SuiteGR
<-
paste0
(
"GR"
,
c
(
"1A"
,
"2M"
,
"4J"
,
"5J"
,
"6J"
,
"4H"
,
"5H"
))
HydroModel
<-
match.arg
(
arg
=
HydroModel
,
choices
=
SuiteGR
)
if
(
is.null
(
ObsDF
)
&&
(
is.null
(
DatesR
)
|
is.null
(
Precip
)
|
is.null
(
PotEvap
)))
{
stop
(
"Missing input data"
)
}
...
...
@@ -15,19 +15,19 @@ PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Q
TempMean
<-
ObsDF
[,
5L
]
}
}
if
(
!
is.null
(
Qobs
))
{
Qobs
<-
Qobs
}
else
{
Qobs
<-
NA
}
if
(
!
is.null
(
TempMean
))
{
TempMean
<-
TempMean
}
else
{
TempMean
<-
NA
}
if
(
is.null
(
ObsDF
))
{
ObsDF
<-
data.frame
(
DatesR
=
DatesR
,
Precip
=
Precip
,
...
...
@@ -35,7 +35,7 @@ PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Q
Qobs
=
Qobs
,
TempMean
=
TempMean
)
}
if
(
!
is.null
(
ObsDF
))
{
ObsDF
<-
data.frame
(
DatesR
=
ObsDF
[,
1L
],
Precip
=
ObsDF
[,
2L
],
...
...
@@ -43,11 +43,11 @@ PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Q
Qobs
=
ObsDF
[,
4L
],
TempMean
=
TempMean
)
}
if
(
!
any
(
attributes
(
ObsDF
$
DatesR
[
1
])
$
tzone
%in%
"UTC"
))
{
stop
(
"Non convenient date format. Time zone must be defined as \"UTC\""
)
}
if
(
!
CemaNeige
)
{
TypeModel
<-
sprintf
(
"RunModel_%s"
,
HydroModel
)
}
...
...
@@ -61,13 +61,13 @@ PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Q
FUN_MOD
<-
get
(
TypeModel
)
MOD_obs
<-
CreateInputsModel
(
FUN_MOD
=
FUN_MOD
,
DatesR
=
ObsDF
$
DatesR
,
Precip
=
ObsDF
$
Precip
,
PotEvap
=
ObsDF
$
PotEvap
,
TempMean
=
ObsDF
$
TempMean
,
MOD_obs
<-
CreateInputsModel
(
FUN_MOD
=
FUN_MOD
,
DatesR
=
ObsDF
$
DatesR
,
Precip
=
ObsDF
$
Precip
,
PotEvap
=
ObsDF
$
PotEvap
,
TempMean
=
ObsDF
$
TempMean
,
ZInputs
=
ZInputs
,
HypsoData
=
HypsoData
,
NLayers
=
NLayers
,
verbose
=
FALSE
)
PrepGR
<-
list
(
InputsModel
=
MOD_obs
,
Qobs
=
ObsDF
$
Qobs
,
TypeModel
=
TypeModel
)
class
(
PrepGR
)
<-
c
(
"PrepGR"
,
"GR"
,
"airGRt"
)
return
(
PrepGR
)
}
R/ShinyGR.R
View file @
c8027afe
ShinyGR
<-
function
(
ObsDF
=
NULL
,
DatesR
=
NULL
,
Precip
=
NULL
,
PotEvap
=
NULL
,
Qobs
=
NULL
,
TempMean
=
NULL
,
ShinyGR
<-
function
(
ObsDF
=
NULL
,
DatesR
=
NULL
,
Precip
=
NULL
,
PotEvap
=
NULL
,
Qobs
=
NULL
,
TempMean
=
NULL
,
ZInputs
=
NULL
,
HypsoData
=
NULL
,
NLayers
=
5
,
SimPer
,
NamesObsBV
=
NULL
,
theme
=
"RStudio"
)
{
...
...
@@ -14,7 +14,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
if
(
is.null
(
SimPer
)
|
any
(
sapply
(
SimPer
,
is.null
)))
{
stop
(
"Null values non suitable for 'SimPer'."
)
}
if
(
!
is.null
(
ObsDF
))
{
if
(
!
is.list
(
ObsDF
)
|
inherits
(
ObsDF
,
"PrepGR"
))
{
stop
(
"'ObsDF' must be a (list of) 'data.frame'."
)
...
...
@@ -23,21 +23,21 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
if
(
is.data.frame
(
ObsDF
))
{
ObsDF
<-
list
(
ObsDF
)
}
if
(
!
is.list
(
HypsoData
))
{
HypsoData
<-
list
(
HypsoData
)
}
if
(
!
is.list
(
SimPer
))
{
SimPer
<-
list
(
SimPer
)
}
if
(
is.null
(
ObsDF
))
{
lenObsDF
<-
1L
}
else
{
lenObsDF
<-
length
(
ObsDF
)
}
if
(
is.null
(
names
(
ObsDF
))
&
!
is.null
(
ObsDF
))
{
if
(
is.null
(
NamesObsBV
))
{
NamesObsBV
<-
paste0
(
"%s %0"
,
nchar
(
lenObsDF
),
"d"
)
...
...
@@ -60,8 +60,8 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
if
(
any
(
nchar
(
NamesObsBV
)
==
0
))
{
stop
(
"NamesObsBV must be a string vector of at least one character."
)
}
}
}
if
(
is.null
(
ObsDF
))
{
if
(
length
(
ZInputs
)
>
1
)
{
warning
(
"Too long 'ZInputs'. Only the first element(s) of 'ZInputs' argument used."
)
...
...
@@ -80,7 +80,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
SimPer
<-
SimPer
[[
1L
]]
}
}
if
(
is.null
(
ZInputs
))
{
ZInputs
<-
vector
(
mode
=
"list"
,
length
=
lenObsDF
)
}
else
{
...
...
@@ -98,7 +98,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
}
}
names
(
ZInputs
)
<-
NamesObsBV
if
(
is.null
(
HypsoData
))
{
HypsoData
<-
vector
(
mode
=
"list"
,
length
=
lenObsDF
)
}
else
{
...
...
@@ -135,7 +135,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
}
}
names
(
NLayers
)
<-
NamesObsBV
if
(
length
(
SimPer
)
>
lenObsDF
)
{
SimPer
<-
as.list
(
SimPer
)[
seq_along
(
ObsDF
)]
warning
(
"Too long 'SimPer'. Only the first element(s) of 'SimPer' argument used."
)
...
...
@@ -147,20 +147,20 @@ 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
,
DatesR
=
DatesR
,
Precip
=
Precip
,
PotEvap
=
PotEvap
,
Qobs
=
Qobs
,
TempMean
=
TempMean
,
ZInputs
=
ZInputs
,
HypsoData
=
HypsoData
,
NLayers
=
NLayers
,
SimPer
=
SimPer
,
theme
=
theme
)
## timezone used
# oTZ <- Sys.timezone()
Sys.setenv
(
TZ
=
"UTC"
)
on.exit
({
rm
(
.ShinyGR.args
,
.ShinyGR.hist
,
envir
=
.GlobalEnv
)
;
Sys.unsetenv
(
"TZ"
)})
shiny
::
runApp
(
system.file
(
"ShinyGR"
,
package
=
"airGRteaching"
),
launch.browser
=
TRUE
)
return
(
NULL
)
}
R/SimGR.R
View file @
c8027afe
SimGR
<-
function
(
PrepGR
,
CalGR
=
NULL
,
Param
,
EffCrit
=
c
(
"NSE"
,
"KGE"
,
"KGE2"
,
"RMSE"
),
WupPer
=
NULL
,
SimPer
,
transfo
=
c
(
""
,
"sqrt"
,
"log"
,
"inv"
,
"sort"
),
verbose
=
TRUE
)
{
EffCrit
<-
match.arg
(
arg
=
EffCrit
)
EffCrit
<-
sprintf
(
"ErrorCrit_%s"
,
EffCrit
)
FUN_CRIT
<-
get
(
EffCrit
)
if
(
!
any
(
transfo
%in%
c
(
""
,
"sqrt"
,
"log"
,
"inv"
,
"sort"
)))
{
stop
(
"Non convenient transformation \"transfo\""
)
}
else
{
transfo
<-
transfo
[
1L
]
}
if
(
!
any
(
class
(
PrepGR
)
%in%
"PrepGR"
))
{
stop
(
"Non convenient data for argument \"PrepGR\". Must be of class \"PrepGR\""
)
}
isQobs
<-
!
all
(
is.na
(
PrepGR
$
Qobs
))
if
(
!
isQobs
)
{
warning
(
"\"PrepGR\" does not contain any Qobs values. The efficiency criterion is not computed"
)
}
if
(
!
missing
(
CalGR
))
{
warning
(
"Deprecated \"CalGR\" argument. Use \"Param\" instead"
)
}
...
...
@@ -41,7 +41,7 @@ SimGR <- function(PrepGR, CalGR = NULL, Param, EffCrit = c("NSE", "KGE", "KGE2",
if
(
inherits
(
Param
,
"CalGR"
))
{
Param
<-
Param
$
OutputsCalib
$
ParamFinalR
}
WupInd
<-
NULL
if
(
!
is.null
(
WupPer
))
{
WupPer
<-
as.POSIXct
(
WupPer
,
tz
=
"UTC"
)
...
...
@@ -58,7 +58,7 @@ SimGR <- function(PrepGR, CalGR = NULL, Param, EffCrit = c("NSE", "KGE", "KGE2",
}
}
}
SimPer
<-
as.POSIXct
(
SimPer
,
tz
=
"UTC"
)
if
(
length
(
SimPer
)
!=
2
)
{
stop
(
"Simulation period \"SimPer\" must be of length 2"
)
...
...
@@ -73,37 +73,37 @@ SimGR <- function(PrepGR, CalGR = NULL, Param, EffCrit = c("NSE", "KGE", "KGE2",
}
}
MOD_opt
<-
CreateRunOptions
(
FUN_MOD
=
get
(
PrepGR
$
TypeModel
),
InputsModel
=
PrepGR
$
InputsModel
,
MOD_opt
<-
CreateRunOptions
(
FUN_MOD
=
get
(
PrepGR
$
TypeModel
),
InputsModel
=
PrepGR
$
InputsModel
,
IndPeriod_WarmUp
=
WupInd
,
IndPeriod_Run
=
SimInd
,
verbose
=
verbose
)
if
(
isQobs
)
{
MOD_crt
<-
CreateInputsCrit
(
FUN_CRIT
=
FUN_CRIT
,
InputsModel
=
PrepGR
$
InputsModel
,
MOD_crt
<-
CreateInputsCrit
(
FUN_CRIT
=
FUN_CRIT
,
InputsModel
=
PrepGR
$
InputsModel
,
RunOptions
=
MOD_opt
,
Obs
=
PrepGR
$
Qobs
[
SimInd
],
transfo
=
transfo
)
}
else
{
MOD_crt
<-
NULL
}
SIM
<-
RunModel
(
InputsModel
=
PrepGR
$
InputsModel
,
RunOptions
=
MOD_opt
,
SIM
<-
RunModel
(
InputsModel
=
PrepGR
$
InputsModel
,
RunOptions
=
MOD_opt
,
Param
=
Param
,
FUN_MOD
=
get
(
PrepGR
$
TypeModel
))
if
(
isQobs
)
{
CRT
<-
ErrorCrit
(
InputsCrit
=
MOD_crt
,
OutputsModel
=
SIM
,
verbose
=
verbose
)
}
else
{
CRT
<-
NULL
}
SimGR
<-
list
(
OptionsSimul
=
MOD_opt
,
OptionsCrit
=
MOD_crt
,
OutputsModel
=
SIM
,
Qobs
=
PrepGR
$
Qobs
[
SimInd
],
TypeModel
=
PrepGR
$
TypeModel
,
CalCrit
=
CalGR
$
CalCrit
,
EffCrit
=
CRT
,
PeriodModel
=
list
(
WarmUp
=
as.POSIXct
(
PrepGR
$
InputsModel
$
DatesR
[
range
(
MOD_opt
$
IndPeriod_WarmUp
)],
tz
=
"UTC"
),
Run
=
SimPer
))
class
(
SimGR
)
<-
c
(
"SimGR"
,
"GR"
,
"airGRt"
)
return
(
SimGR
)
}
\ No newline at end of file
return
(
SimGR
)
}
R/Utils.R
View file @
c8027afe
This diff is collapsed.
Click to expand it.
R/as.data.frame.airGRt.R
View file @
c8027afe
as.data.frame.airGRt
<-
function
(
x
,
row.names
=
NULL
,
...
)
{
if
(
!
(
inherits
(
x
,
"PrepGR"
)
|
inherits
(
x
,
"CalGR"
)
|
inherits
(
x
,
"SimGR"
)))
{
stop
(
"'InputsCrit' must be of class 'PrepGR', 'CalGR', 'SimGR'"
)
}
TMGR
<-
.TypeModelGR
(
x
)
myGR
<-
list
()
myGR
$
FracSolid
<-
NA
myGR
$
TempMean
<-
NA
if
(
inherits
(
x
,
"PrepGR"
))
{
if
(
TMGR
$
CemaNeige
)
{
PrecipSol
<-
rowMeans
(
as.data.frame
(
x
$
InputsModel
$
LayerPrecip
)
*
as.data.frame
(
x
$
InputsModel
$
LayerFracSolidPrecip
),
na.rm
=
TRUE
)
...
...
@@ -41,7 +41,7 @@ as.data.frame.airGRt <- function(x, row.names = NULL, ...) {
myGR
$
Precip
<-
x
$
OutputsModel
$
Precip
myGR
$
Qobs
<-
x
$
Qobs
myGR
$
Qsim
<-
x
$
OutputsModel
$
Qsim
}
}
TabSim
<-
data.frame
(
Dates
=
myGR
$
DatesR
,
PotEvap
=
myGR
$
PotEvap
,
PrecipObs
=
myGR
$
Precip
,
...
...
R/dyplot.CalGR.R
View file @
c8027afe
...
...
@@ -3,7 +3,7 @@ dyplot.CalGR <- function(x, ...) {
if
(
!
any
(
class
(
x
)
%in%
"CalGR"
))
{
stop
(
"Non convenient data for x argument. Must be of class \"CalGR\""
)
}
dyplot.default
(
x
,
...
)
}
R/dyplot.PrepGR.R
View file @
c8027afe
...
...
@@ -3,7 +3,7 @@ dyplot.PrepGR <- function(x, ...) {
if
(
!
any
(
class
(
x
)
%in%
"PrepGR"
))
{
stop
(
"Non convenient data for x argument. Must be of class \"PrepGR\""
)
}
dyplot.default
(
x
,
...
)
}
R/dyplot.SimGR.R
View file @
c8027afe
...
...
@@ -3,7 +3,7 @@ dyplot.SimGR <- function(x, ...) {
if
(
!
any
(
class
(
x
)
%in%
"SimGR"
))
{
stop
(
"Non convenient data for x argument. Must be of class \"SimGR\""
)
}
dyplot.default
(
x
,
...
)
}
R/dyplot.default.R
View file @
c8027afe
...
...
@@ -3,14 +3,14 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
ylab
=
NULL
,
main
=
NULL
,
plot.na
=
TRUE
,
RangeSelector
=
TRUE
,
Roller
=
FALSE
,
LegendShow
=
c
(
"follow"
,
"auto"
,
"always"
,
"onmouseover"
,
"never"
),
...
)
{
# barChartPrecip <- scan(file = system.file("plugins/barChartPrecip.js", package = "airGRteaching"),
# what = "character", quiet = TRUE)
if
(
!
any
(
class
(
x
)
%in%
c
(
"PrepGR"
,
"CalGR"
,
"SimGR"
)))
{
stop
(
"Non convenient data for x argument. Must be of class \"PrepGR\", \"CalGR\" or \"SimGR\""
)
}
if
(
is.null
(
ylab
))
{
yunit
<-
.TypeModelGR
(
x
)
$
TimeUnit
ylab
<-
paste0
(
c
(
"flow [mm/"
,
"precip. [mm/"
),
yunit
,
"]"
)
...
...
@@ -18,11 +18,11 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
if
(
length
(
ylab
)
<
2
)
{
ylab
<-
c
(
ylab
,
""
)
}
}
}
if
(
is.null
(
Qsup
))
{
Qsup
<-
as.numeric
(
rep
(
NA
,
length.out
=
length
(
x
$
Qobs
)))
}
}
if
(
!
is.numeric
(
Qsup
))
{
stop
(
"'Qsup' must be numeric"
)
}
...
...
@@ -32,8 +32,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%
"PrepGR"
))
{
data
<-
data.frame
(
DatesR
=
x
$
InputsModel
$
DatesR
,
Precip
=
x
$
InputsModel
$
Precip
,
...
...
@@ -44,7 +44,7 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
data
$
Psol
<-
rowMeans
(
as.data.frame
(
x
$
InputsModel
$
LayerPrecip
)
*
as.data.frame
(
x
$
InputsModel
$
LayerFracSolidPrecip
),
na.rm
=
TRUE
)
data
$
Pliq
<-
data
$
Precip
-
data
$
Psol
data
$
Precip
<-
NULL
}
}
}
else
{
data
<-
data.frame
(
DatesR
=
x
$
OutputsModel
$
DatesR
,
Precip
=
x
$
OutputsModel
$
Precip
,
...
...
@@ -58,8 +58,8 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
}
}
data.xts
<-
xts
::
xts
(
data
[,
-1L
],
order.by
=
data
$
DatesR
,
tz
=
"UTC"
)
rgba
<-
function
(
x
,
alpha
=
1
)
{
sprintf
(
"rgba(%s, %f)"
,
paste0
(
col2rgb
(
x
),
collapse
=
", "
),
alpha
)
}
...
...
@@ -72,16 +72,16 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
if
(
length
(
col.Precip
)
<
2
)
{
col.Precip
<-
c
(
rgba
(
col.Precip
),
rgba
(
col.Precip
,
alpha
=
0.5
))
}
if
(
grepl
(
"CemaNeige"
,
x
$
TypeModel
))
{
Plim
<-
c
(
-1e-3
,
max
(
data
$
Psol
+
data
$
Pliq
,
na.rm
=
TRUE
))
}
else
{
Plim
<-
c
(
-1e-3
,
max
(
data
$
Precip
,
na.rm
=
TRUE
))
col.Precip
<-
col.Precip
[
1L
]
}
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
])
...
...
@@ -109,7 +109,7 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
dg
<-
dygraphs
::
dyLegend
(
dygraph
=
dg
,
show
=
LegendShow
[
1L
])
}
dg
<-
dygraphs
::
dyOptions
(
dygraph
=
dg
,
useDataTimezone
=
TRUE
)
return
(
dg
)
}
R/plot.CalGR.R
View file @
c8027afe
plot.CalGR
<-
function
(
x
,
xlab
=
NULL
,
ylab
=
NULL
,
main
=
NULL
,
which
=
c
(
"perf"
,
"iter"
,
"ts"
),
...
)
{
if
(
!
any
(
class
(
x
)
%in%
"CalGR"
))
{
stop
(
"Non convenient data for x argument. Must be of class \"CalGR\""
)
}
if
(
!
any
(
which
%in%
c
(
"perf"
,
"iter"
,
"ts"
)))
{
stop
(
"Non convenient data for which argument. Must be of class \"perf\", \"iter\" or \"ts\""
)
}
nbParamX
<-
.TypeModelGR
(
x
)
$
NbParam
#as.numeric(gsub("\\D", "", x$TypeModel))
nbParamC
<-
ifelse
(
.TypeModelGR
(
x
)
$
CemaNeige
,
2
,
0
)
nbParam
<-
nbParamX
+
nbParamC
nmParam
<-
c
(
sprintf
(
"X%i"
,
1
:
nbParamX
),
sprintf
(
"C%i"
,
seq_len
(
nbParamC
)))
opar
<-
par
(
no.readonly
=
TRUE
)
on.exit
(
par
(
opar
))
if
(
any
(
which
[
1L
]
%in%
c
(
"perf"
)))
{
plot
(
x
$
OutputsModel
,
Qobs
=
x
$
Qobs
,
...
)
}
if
(
any
(
which
[
1L
]
%in%
c
(
"iter"
)))
{
layout.list
<-
list
(
matrix
(
c
(
1
:
2
),
ncol
=
2
),
matrix
(
c
(
1
:
3
,
3
),
ncol
=
2
),
...
...
@@ -40,7 +40,7 @@ plot.CalGR <- function(x, xlab = NULL, ylab = NULL, main = NULL, which = c("per
if
(
which
[
1L
]
%in%
c
(
"ts"
))
{
layout
(
mat
=
matrix
(
1
:
2
),
widths
=
c
(
1
,
2
),
heights
=
c
(
1
,
2
))
}
if
(
any
(
which
[
1L
]
%in%
c
(
"iter"
)))
{
ParamLab
<-
data.frame
(
Name
=
c
(
sprintf
(
"X%i"
,
1
:
6
),
sprintf
(
"C%i"
,
1
:
2
)),
Label
=
c
(
"prod. store capacity [mm]"
,
...
...
@@ -52,8 +52,8 @@ plot.CalGR <- function(x, xlab = NULL, ylab = NULL, main = NULL, which = c("per
"weight for snowpack thermal state [-]"
,
"degree-day melt coef. [mm/degC/TimeUnit]"
))
ParamLab
$
Label
<-
gsub
(
"TimeUnit"
,
substr
(
.TypeModelGR
(
x
)
$
TimeUnit
,
1
,
1
),
ParamLab
$
Label
)