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
airGR
Commits
36154a79
Commit
36154a79
authored
Jul 14, 2021
by
Delaigue Olivier
Browse files
Merge branch 'dev' into '122-review-the-x-axis-management-of-the-plot-outputsmodel'
# Conflicts: # R/plot.OutputsModel.R
parents
90a095fc
265725dc
Changes
41
Hide whitespace changes
Inline
Side-by-side
.Rbuildignore
View file @
36154a79
...
...
@@ -9,3 +9,5 @@
^\.vscode$
^Rplots\.pdf$
^ci$
^data-raw$
^revdep$
.gitignore
View file @
36154a79
...
...
@@ -12,6 +12,8 @@ packrat/lib*/
*.pdf
!man/figures/*.pdf
# revdep
/revdep/
######################################################################################################
### Generic .gitignore for R (source: https://github.com/github/gitignore/blob/master/R.gitignore) ###
...
...
.gitlab-ci.yml
View file @
36154a79
stages
:
-
check
-
regression
-
scheduled_tests
-
revdepcheck
default
:
...
...
@@ -10,13 +10,14 @@ default:
-
PATH=~/R/sources/R-${R_VERSION}/bin:$PATH
-
R -e 'remotes::install_deps(dep = TRUE)'
.
regression
:
stage
:
regression
.
scheduled_tests
:
stage
:
scheduled_tests
script
:
-
Rscript tests/testthat/regression_tests.R stable
-
Rscript tests/scheduled_tests/scheduled.R
-
Rscript tests/scheduled_tests/regression.R stable
-
R CMD INSTALL .
-
Rscript tests/
testthat
/regression
_tests
.R dev
-
Rscript tests/
testthat
/regression
_tests
.R compare
-
Rscript tests/
scheduled_tests
/regression.R dev
-
Rscript tests/
scheduled_tests
/regression.R compare
.check
:
stage
:
check
...
...
@@ -33,26 +34,31 @@ default:
NOT_CRAN
:
"
false"
extends
:
.check
regression_patched
:
scheduled_tests_patched
:
only
:
refs
:
-
dev
-
master
-
schedules
variables
:
R_VERSION
:
"
patched"
extends
:
.
regression
extends
:
.
scheduled_tests
regression
_devel
:
scheduled_tests
_devel
:
only
:
refs
:
-
schedules
variables
:
R_VERSION
:
"
devel"
extends
:
.
regression
extends
:
.
scheduled_tests
regression
_oldrel
:
scheduled_tests
_oldrel
:
only
:
refs
:
-
schedules
variables
:
R_VERSION
:
"
oldrel"
extends
:
.
regression
extends
:
.
scheduled_tests
check_not_cran_patched
:
variables
:
...
...
.regressionignore
View file @
36154a79
...
...
@@ -4,3 +4,62 @@
# ignored variable : [Topic]<SPACE>[Variable].
# Example for ignoring OutputsModel variable produced by example("RunModel_GR2M"): RunModel_GR2M OutputsModel
Calibration_Michel RunOptions
Calibration RunOptions
CreateCalibOptions RunOptions
CreateIniStates RunOptions
CreateInputsCrit RunOptions
CreateInputsModel RunOptions
CreateRunOptions RunOptions
ErrorCrit_KGE RunOptions
ErrorCrit_KGE2 RunOptions
ErrorCrit_NSE RunOptions
ErrorCrit_RMSE RunOptions
ErrorCrit RunOptions
Imax RunOptions
Param_Sets_GR4J RunOptions_Cal
Param_Sets_GR4J RunOptions_Val
RunModel_CemaNeige RunOptions
RunModel_CemaNeigeGR4J RunOptions
RunModel_CemaNeigeGR5J RunOptions
RunModel_CemaNeigeGR6J RunOptions
RunModel_GR1A RunOptions
RunModel_GR2M RunOptions
RunModel_GR4H RunOptions
RunModel_GR4J RunOptions
RunModel_GR5H RunOptions
RunModel_GR5J RunOptions
RunModel_GR6J RunOptions
RunModel_Lag RunOptions
RunModel RunOptions
SeriesAggreg RunOptions
Calibration OutputsModel
Calibration_Michel OutputsModel
CreateCalibOptions OutputsModel
CreateIniStates OutputsModel
CreateInputsCrit OutputsModel
CreateInputsModel OutputsModel
CreateRunOptions OutputsModel
ErrorCrit OutputsModel
ErrorCrit_KGE OutputsModel
ErrorCrit_KGE2 OutputsModel
ErrorCrit_NSE OutputsModel
ErrorCrit_RMSE OutputsModel
Imax OutputsModel
RunModel OutputsModel
RunModel_CemaNeige OutputsModel
RunModel_CemaNeigeGR4J OutputsModel
RunModel_CemaNeigeGR5J OutputsModel
RunModel_CemaNeigeGR6J OutputsModel
RunModel_GR1A OutputsModel
RunModel_GR2M OutputsModel
RunModel_GR4H OutputsModel
RunModel_GR4J OutputsModel
RunModel_GR5H OutputsModel
RunModel_GR5J OutputsModel
RunModel_GR6J OutputsModel
RunModel_Lag OutputsModel
SeriesAggreg OutputsModel
Param_Sets_GR4J OutputsModel_Val
RunModel_Lag OutputsModelDown
SeriesAggreg SimulatedMonthlyRegime
R/Calibration_Michel.R
View file @
36154a79
...
...
@@ -17,7 +17,7 @@ Calibration_Michel <- function(InputsModel,
# Handling 'FUN_TRANSFO' from direct argument or provided by 'CaliOptions'
if
(
!
is.null
(
FUN_TRANSFO
))
{
FUN_TRANSFO
<-
match.fun
(
FUN_TRANSFO
)
}
else
if
(
!
is.null
(
CalibOptions
$
FUN_TRANSFO
))
{
}
else
if
(
!
is.null
(
CalibOptions
$
FUN_TRANSFO
))
{
FUN_TRANSFO
<-
CalibOptions
$
FUN_TRANSFO
}
else
{
stop
(
"'FUN_TRANSFO' is not provided neither as 'FUN_TRANSFO' argument or in 'CaliOptions' argument"
)
...
...
R/CreateCalibOptions.R
View file @
36154a79
...
...
@@ -12,7 +12,7 @@ CreateCalibOptions <- function(FUN_MOD,
FUN_MOD
<-
match.fun
(
FUN_MOD
)
FUN_CALIB
<-
match.fun
(
FUN_CALIB
)
if
(
!
is.null
(
FUN_TRANSFO
))
{
if
(
!
is.null
(
FUN_TRANSFO
))
{
FUN_TRANSFO
<-
match.fun
(
FUN_TRANSFO
)
}
if
(
!
is.logical
(
IsHyst
)
|
length
(
IsHyst
)
!=
1L
)
{
...
...
R/CreateIniStates.R
View file @
36154a79
...
...
@@ -153,19 +153,19 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
}
UH2
<-
rep
(
Inf
,
UH2n
)
}
if
(
IsIntStore
&
is.null
(
IntStore
))
{
if
(
IsIntStore
&
is.null
(
IntStore
))
{
stop
(
sprintf
(
"'%s' need values for 'IntStore'"
,
nameFUN_MOD
))
}
if
(
"CemaNeige"
%in%
ObjectClass
&
!
IsHyst
&
if
(
"CemaNeige"
%in%
ObjectClass
&
!
IsHyst
&
(
is.null
(
GCemaNeigeLayers
)
|
is.null
(
eTGCemaNeigeLayers
)))
{
stop
(
sprintf
(
"'%s' need values for 'GCemaNeigeLayers' and 'GCemaNeigeLayers'"
,
nameFUN_MOD
))
}
if
(
"CemaNeige"
%in%
ObjectClass
&
IsHyst
&
if
(
"CemaNeige"
%in%
ObjectClass
&
IsHyst
&
(
is.null
(
GCemaNeigeLayers
)
|
is.null
(
eTGCemaNeigeLayers
)
|
is.null
(
GthrCemaNeigeLayers
)
|
is.null
(
GlocmaxCemaNeigeLayers
)))
{
stop
(
sprintf
(
"'%s' need values for 'GCemaNeigeLayers', 'GCemaNeigeLayers', 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'"
,
nameFUN_MOD
))
}
if
(
"CemaNeige"
%in%
ObjectClass
&
!
IsHyst
&
if
(
"CemaNeige"
%in%
ObjectClass
&
!
IsHyst
&
(
!
is.null
(
GthrCemaNeigeLayers
)
|
!
is.null
(
GlocmaxCemaNeigeLayers
)))
{
if
(
verbose
)
{
warning
(
sprintf
(
"'%s' does not require 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'. Values set to NA"
,
nameFUN_MOD
))
...
...
@@ -173,7 +173,7 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
GthrCemaNeigeLayers
<-
Inf
GlocmaxCemaNeigeLayers
<-
Inf
}
if
(
!
"CemaNeige"
%in%
ObjectClass
&
if
(
!
"CemaNeige"
%in%
ObjectClass
&
(
!
is.null
(
GCemaNeigeLayers
)
|
!
is.null
(
eTGCemaNeigeLayers
)
|
!
is.null
(
GthrCemaNeigeLayers
)
|
!
is.null
(
GlocmaxCemaNeigeLayers
)))
{
if
(
verbose
)
{
warning
(
sprintf
(
"'%s' does not require 'GCemaNeigeLayers' 'GCemaNeigeLayers', 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'. Values set to NA"
,
nameFUN_MOD
))
...
...
@@ -186,7 +186,7 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
## set states
if
(
"CemaNeige"
%in%
ObjectClass
)
{
if
(
"CemaNeige"
%in%
ObjectClass
)
{
NLayers
<-
length
(
InputsModel
$
LayerPrecip
)
}
else
{
NLayers
<-
1
...
...
@@ -284,17 +284,17 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
}
# SD model state handling
if
(
!
is.null
(
SD
))
{
if
(
!
inherits
(
InputsModel
,
"SD"
))
{
if
(
!
is.null
(
SD
))
{
if
(
!
inherits
(
InputsModel
,
"SD"
))
{
stop
(
"'SD' argument provided and 'InputsModel' is not of class 'SD'"
)
}
if
(
!
is.list
(
SD
))
{
if
(
!
is.list
(
SD
))
{
stop
(
"'SD' argument must be a list"
)
}
lapply
(
SD
,
function
(
x
)
{
if
(
!
is.numeric
(
x
))
stop
(
"Each item of 'SD' list argument must be numeric"
)
if
(
!
is.numeric
(
x
))
stop
(
"Each item of 'SD' list argument must be numeric"
)
})
if
(
length
(
SD
)
!=
length
(
InputsModel
$
LengthHydro
))
{
if
(
length
(
SD
)
!=
length
(
InputsModel
$
LengthHydro
))
{
stop
(
"Number of items of 'SD' list argument must be the same as the number of upstream connections"
,
sprintf
(
" (%i required, found %i)"
,
length
(
InputsModel
$
LengthHydro
),
length
(
SD
)))
}
...
...
@@ -309,15 +309,15 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
IniStatesNA
[
is.infinite
(
IniStatesNA
)]
<-
NA
IniStatesNA
<-
relist
(
IniStatesNA
,
skeleton
=
IniStates
)
if
(
!
is.null
(
SD
))
{
if
(
!
is.null
(
SD
))
{
IniStatesNA
$
SD
<-
SD
}
class
(
IniStatesNA
)
<-
c
(
"IniStates"
,
ObjectClass
)
if
(
IsHyst
)
{
if
(
IsHyst
)
{
class
(
IniStatesNA
)
<-
c
(
class
(
IniStatesNA
),
"hysteresis"
)
}
if
(
IsIntStore
)
{
if
(
IsIntStore
)
{
class
(
IniStatesNA
)
<-
c
(
class
(
IniStatesNA
),
"interception"
)
}
...
...
R/CreateInputsCrit.R
View file @
36154a79
...
...
@@ -293,7 +293,7 @@ CreateInputsCrit <- function(FUN_CRIT,
listVarObs
<-
sapply
(
InputsCrit
,
FUN
=
"[["
,
"VarObs"
)
inCnVarObs
<-
c
(
"SCA"
,
"SWE"
)
if
(
!
"ZLayers"
%in%
names
(
InputsModel
))
{
if
(
any
(
listVarObs
%in%
inCnVarObs
))
{
if
(
any
(
listVarObs
%in%
inCnVarObs
))
{
stop
(
sprintf
(
"'VarObs' can not be equal to %i if CemaNeige is not used"
,
paste
(
sapply
(
inCnVarObs
,
shQuote
),
collapse
=
" or "
)))
}
...
...
@@ -348,7 +348,7 @@ CreateInputsCrit <- function(FUN_CRIT,
combInputsCrit
<-
combn
(
x
=
length
(
InputsCrit
),
m
=
2
)
apply
(
combInputsCrit
,
MARGIN
=
2
,
function
(
i
)
{
equalInputsCrit
<-
identical
(
InputsCrit
[[
i
[
1
]]],
InputsCrit
[[
i
[
2
]]])
if
(
equalInputsCrit
)
{
if
(
equalInputsCrit
)
{
warning
(
sprintf
(
"elements %i and %i of the criteria list are identical. This might not be necessary"
,
i
[
1
],
i
[
2
]),
call.
=
FALSE
)
}
})
...
...
R/CreateInputsModel.R
View file @
36154a79
...
...
@@ -153,10 +153,10 @@ CreateInputsModel <- function(FUN_MOD,
if
(
nrow
(
Qupstream
)
!=
LLL
)
{
stop
(
"'Qupstream' must have same number of rows as 'DatesR' length"
)
}
if
(
any
(
is.na
(
Qupstream
)))
{
if
(
any
(
is.na
(
Qupstream
)))
{
warning
(
"'Qupstream' contains NA values: model outputs will contain NAs"
)
}
if
(
any
(
LengthHydro
>
1000
))
{
if
(
any
(
LengthHydro
>
1000
))
{
warning
(
"The unit of 'LengthHydro' has changed from m to km in airGR >= 1.6.12: values superior to 1000 km seem unrealistic"
)
}
QupstrUnit
<-
tolower
(
QupstrUnit
)
...
...
R/CreateRunOptions.R
View file @
36154a79
...
...
@@ -24,12 +24,17 @@ CreateRunOptions <- function(FUN_MOD, InputsModel,
ObjectClass
<-
FeatFUN_MOD
$
Class
TimeStepMean
<-
FeatFUN_MOD
$
TimeStepMean
## Model output variable list
FortranOutputs
<-
.FortranOutputs
(
GR
=
FeatFUN_MOD
$
CodeModHydro
,
isCN
=
"CemaNeige"
%in%
FeatFUN_MOD
$
Class
)
## manage class
if
(
IsIntStore
)
{
ObjectClass
<-
c
(
ObjectClass
,
"interception"
)
}
if
(
IsHyst
)
{
ObjectClass
<-
c
(
ObjectClass
,
"hysteresis"
)
FeatFUN_MOD
$
NbParam
<-
FeatFUN_MOD
$
NbParam
+
2
}
if
(
!
"CemaNeige"
%in%
ObjectClass
&
"hysteresis"
%in%
ObjectClass
)
{
...
...
@@ -290,31 +295,7 @@ CreateRunOptions <- function(FUN_MOD, InputsModel,
##check_Outputs_Cal_and_Sim
##Outputs_all
Outputs_all
<-
NULL
if
(
identical
(
FUN_MOD
,
RunModel_GR4H
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR4H
))
{
Outputs_all
<-
c
(
Outputs_all
,
.FortranOutputs
(
GR
=
"GR4H"
)
$
GR
)
}
if
(
identical
(
FUN_MOD
,
RunModel_GR5H
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR5H
))
{
Outputs_all
<-
c
(
Outputs_all
,
.FortranOutputs
(
GR
=
"GR5H"
)
$
GR
)
}
if
(
identical
(
FUN_MOD
,
RunModel_GR4J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR4J
))
{
Outputs_all
<-
c
(
Outputs_all
,
.FortranOutputs
(
GR
=
"GR4J"
)
$
GR
)
}
if
(
identical
(
FUN_MOD
,
RunModel_GR5J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR5J
))
{
Outputs_all
<-
c
(
Outputs_all
,
.FortranOutputs
(
GR
=
"GR5J"
)
$
GR
)
}
if
(
identical
(
FUN_MOD
,
RunModel_GR6J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR6J
))
{
Outputs_all
<-
c
(
Outputs_all
,
.FortranOutputs
(
GR
=
"GR6J"
)
$
GR
)
}
if
(
identical
(
FUN_MOD
,
RunModel_GR2M
))
{
Outputs_all
<-
c
(
Outputs_all
,
.FortranOutputs
(
GR
=
"GR2M"
)
$
GR
)
}
if
(
identical
(
FUN_MOD
,
RunModel_GR1A
))
{
Outputs_all
<-
c
(
Outputs_all
,
.FortranOutputs
(
GR
=
"GR1A"
)
$
GR
)
}
if
(
"CemaNeige"
%in%
ObjectClass
)
{
Outputs_all
<-
c
(
Outputs_all
,
.FortranOutputs
(
GR
=
NULL
,
isCN
=
TRUE
)
$
CN
)
}
Outputs_all
<-
c
(
"DatesR"
,
unlist
(
FortranOutputs
),
"WarmUpQsim"
,
"StateEnd"
)
##check_Outputs_Sim
if
(
!
is.vector
(
Outputs_Sim
))
{
...
...
@@ -327,9 +308,9 @@ CreateRunOptions <- function(FUN_MOD, InputsModel,
stop
(
"'Outputs_Sim' must not contain NA"
)
}
if
(
"all"
%in%
Outputs_Sim
)
{
Outputs_Sim
<-
c
(
"DatesR"
,
Outputs_all
,
"StateEnd"
)
Outputs_Sim
<-
Outputs_all
}
Test
<-
which
(
!
Outputs_Sim
%in%
c
(
"DatesR"
,
Outputs_all
,
"StateEnd"
)
)
Test
<-
which
(
!
Outputs_Sim
%in%
Outputs_all
)
if
(
length
(
Test
)
!=
0
)
{
stop
(
paste0
(
"'Outputs_Sim' is incorrectly defined: "
,
paste
(
Outputs_Sim
[
Test
],
collapse
=
", "
),
" not found"
))
...
...
@@ -361,10 +342,9 @@ CreateRunOptions <- function(FUN_MOD, InputsModel,
}
}
if
(
"all"
%in%
Outputs_Cal
)
{
Outputs_Cal
<-
c
(
"DatesR"
,
Outputs_all
,
"StateEnd"
)
Outputs_Cal
<-
Outputs_all
}
Test
<-
which
(
!
Outputs_Cal
%in%
c
(
"DatesR"
,
Outputs_all
,
"StateEnd"
)
)
Test
<-
which
(
!
Outputs_Cal
%in%
Outputs_all
)
if
(
length
(
Test
)
!=
0
)
{
stop
(
paste0
(
"'Outputs_Cal' is incorrectly defined: "
,
paste
(
Outputs_Cal
[
Test
],
collapse
=
", "
),
" not found"
))
...
...
@@ -473,7 +453,9 @@ CreateRunOptions <- function(FUN_MOD, InputsModel,
IniStates
=
IniStates
,
IniResLevels
=
IniResLevels
,
Outputs_Cal
=
Outputs_Cal
,
Outputs_Sim
=
Outputs_Sim
)
Outputs_Sim
=
Outputs_Sim
,
FortranOutputs
=
FortranOutputs
,
FeatFUN_MOD
=
FeatFUN_MOD
)
if
(
"CemaNeige"
%in%
ObjectClass
)
{
RunOptions
<-
c
(
RunOptions
,
list
(
MeanAnSolidPrecip
=
MeanAnSolidPrecip
))
...
...
R/RunModel_CemaNeige.R
View file @
36154a79
...
...
@@ -148,7 +148,7 @@ RunModel_CemaNeige <- function(InputsModel, RunOptions, Param) {
## End
class
(
OutputsModel
)
<-
c
(
"OutputsModel"
,
time_step
,
"CemaNeige"
)
if
(
IsHyst
)
{
if
(
IsHyst
)
{
class
(
OutputsModel
)
<-
c
(
class
(
OutputsModel
),
"hysteresis"
)
}
return
(
OutputsModel
)
...
...
R/RunModel_CemaNeigeGR4H.R
View file @
36154a79
...
...
@@ -3,40 +3,12 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
## Initialization of variables
IsHyst
<-
inherits
(
RunOptions
,
"hysteresis"
)
NParam
<-
ifelse
(
test
=
IsHyst
,
yes
=
8L
,
no
=
6L
)
NParamCN
<-
NParam
-
4L
NParamCN
<-
RunOptions
$
FeatFUN_MOD
$
NbParam
-
4L
NStates
<-
4L
FortranOutputs
<-
.FortranOutputs
(
GR
=
"GR4H"
,
isCN
=
TRUE
)
## Arguments check
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"'InputsModel' must be of class 'InputsModel'"
)
}
if
(
!
inherits
(
InputsModel
,
"hourly"
))
{
stop
(
"'InputsModel' must be of class 'hourly'"
)
}
if
(
!
inherits
(
InputsModel
,
"GR"
))
{
stop
(
"'InputsModel' must be of class 'GR'"
)
}
if
(
!
inherits
(
InputsModel
,
"CemaNeige"
))
{
stop
(
"'InputsModel' must be of class 'CemaNeige'"
)
}
if
(
!
inherits
(
RunOptions
,
"RunOptions"
))
{
stop
(
"'RunOptions' must be of class 'RunOptions'"
)
}
if
(
!
inherits
(
RunOptions
,
"GR"
))
{
stop
(
"'RunOptions' must be of class 'GR'"
)
}
if
(
!
inherits
(
RunOptions
,
"CemaNeige"
))
{
stop
(
"'RunOptions' must be of class 'CemaNeige'"
)
}
if
(
!
is.vector
(
Param
)
|
!
is.numeric
(
Param
))
{
stop
(
"'Param' must be a numeric vector"
)
}
if
(
sum
(
!
is.na
(
Param
))
!=
NParam
)
{
stop
(
paste
(
"'Param' must be a vector of length"
,
NParam
,
"and contain no NA"
))
}
.ArgumentsCheckGR
(
InputsModel
,
RunOptions
,
Param
)
Param
<-
as.double
(
Param
)
...
...
@@ -76,9 +48,9 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
## CemaNeige________________________________________________________________________________
if
(
inherits
(
RunOptions
,
"CemaNeige"
))
{
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
FortranOutputs
$
CN
))
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
CN
))
}
else
{
IndOutputsCemaNeige
<-
which
(
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsCemaNeige
<-
which
(
RunOptions
$
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
}
CemaNeigeLayers
<-
list
()
CemaNeigeStateEnd
<-
NULL
...
...
@@ -116,7 +88,7 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
## Data storage
CemaNeigeLayers
[[
iLayer
]]
<-
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
])
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
RunOptions
$
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
IndPliqAndMelt
<-
which
(
names
(
CemaNeigeLayers
[[
iLayer
]])
==
"PliqAndMelt"
)
if
(
iLayer
==
1
)
{
CatchMeltAndPliq
<-
RESULTS
$
Outputs
[,
IndPliqAndMelt
]
/
NLayers
...
...
@@ -142,9 +114,9 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
## GR model
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsMod
<-
as.integer
(
1
:
length
(
FortranOutputs
$
GR
))
IndOutputsMod
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
GR
))
}
else
{
IndOutputsMod
<-
which
(
FortranOutputs
$
GR
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsMod
<-
which
(
RunOptions
$
FortranOutputs
$
GR
%in%
RunOptions
$
Outputs_Sim
)
}
## Use of IniResLevels
...
...
@@ -186,45 +158,14 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
}
if
(
inherits
(
RunOptions
,
"CemaNeige"
)
&
"Precip"
%in%
RunOptions
$
Outputs_Sim
)
{
RESULTS
$
Outputs
[,
which
(
FortranOutputs
$
GR
[
IndOutputsMod
]
==
"Precip"
)]
<-
InputsModel
$
Precip
[
IndPeriod1
]
}
## Output data preparation
## OutputsModel only
if
(
!
ExportDatesR
&
!
ExportStateEnd
)
{
OutputsModel
<-
c
(
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
))
names
(
OutputsModel
)
<-
c
(
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
)
}
## DatesR and OutputsModel only
if
(
ExportDatesR
&
!
ExportStateEnd
)
{
OutputsModel
<-
c
(
list
(
InputsModel
$
DatesR
[
RunOptions
$
IndPeriod_Run
]),
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
))
names
(
OutputsModel
)
<-
c
(
"DatesR"
,
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
)
}
## OutputsModel and StateEnd only
if
(
!
ExportDatesR
&
ExportStateEnd
)
{
OutputsModel
<-
c
(
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
),
list
(
RESULTS
$
StateEnd
))
names
(
OutputsModel
)
<-
c
(
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
,
"StateEnd"
)
}
## DatesR and OutputsModel and StateEnd
if
(
ExportDatesR
&
ExportStateEnd
)
{
OutputsModel
<-
c
(
list
(
InputsModel
$
DatesR
[
RunOptions
$
IndPeriod_Run
]),
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
),
list
(
RESULTS
$
StateEnd
))
names
(
OutputsModel
)
<-
c
(
"DatesR"
,
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
,
"StateEnd"
)
}
## End
rm
(
RESULTS
)
class
(
OutputsModel
)
<-
c
(
"OutputsModel"
,
"hourly"
,
"GR"
,
"CemaNeige"
)
if
(
IsHyst
)
{
class
(
OutputsModel
)
<-
c
(
class
(
OutputsModel
),
"hysteresis"
)
RESULTS
$
Outputs
[,
which
(
RunOptions
$
FortranOutputs
$
GR
[
IndOutputsMod
]
==
"Precip"
)]
<-
InputsModel
$
Precip
[
IndPeriod1
]
}
return
(
OutputsModel
)
## OutputsModel generation
.GetOutputsModelGR
(
InputsModel
,
RunOptions
,
RESULTS
,
LInputSeries
,
CemaNeigeLayers
)
}
R/RunModel_CemaNeigeGR4J.R
View file @
36154a79
RunModel_CemaNeigeGR4J
<-
function
(
InputsModel
,
RunOptions
,
Param
)
{
## Initialization of variables
IsHyst
<-
inherits
(
RunOptions
,
"hysteresis"
)
NParam
<-
ifelse
(
test
=
IsHyst
,
yes
=
8L
,
no
=
6L
)
NParamCN
<-
NParam
-
4L
NParamCN
<-
RunOptions
$
FeatFUN_MOD
$
NbParam
-
4L
NStates
<-
4L
FortranOutputs
<-
.FortranOutputs
(
GR
=
"GR4J"
,
isCN
=
TRUE
)
## Arguments check
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"'InputsModel' must be of class 'InputsModel'"
)
}
if
(
!
inherits
(
InputsModel
,
"daily"
))
{
stop
(
"'InputsModel' must be of class 'daily'"
)
}
if
(
!
inherits
(
InputsModel
,
"GR"
))
{
stop
(
"'InputsModel' must be of class 'GR'"
)
}
if
(
!
inherits
(
InputsModel
,
"CemaNeige"
))
{
stop
(
"'InputsModel' must be of class 'CemaNeige'"
)
}
if
(
!
inherits
(
RunOptions
,
"RunOptions"
))
{
stop
(
"'RunOptions' must be of class 'RunOptions'"
)
}
if
(
!
inherits
(
RunOptions
,
"GR"
))
{
stop
(
"'RunOptions' must be of class 'GR'"
)
}
if
(
!
inherits
(
RunOptions
,
"CemaNeige"
))
{
stop
(
"'RunOptions' must be of class 'CemaNeige'"
)
}
if
(
!
is.vector
(
Param
)
|
!
is.numeric
(
Param
))
{
stop
(
"'Param' must be a numeric vector"
)
}
if
(
sum
(
!
is.na
(
Param
))
!=
NParam
)
{
stop
(
paste
(
"'Param' must be a vector of length"
,
NParam
,
"and contain no NA"
))
}
.ArgumentsCheckGR
(
InputsModel
,
RunOptions
,
Param
)
Param
<-
as.double
(
Param
)
Param_X1X3_threshold
<-
1e-2
Param_X4_threshold
<-
0.5
...
...
@@ -53,8 +25,8 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
if
(
Param
[
4L
]
<
Param_X4_threshold
)
{
warning
(
sprintf
(
"Param[4] (X4: unit hydrograph time constant [d]) < %.2f\n X4 set to %.2f"
,
Param_X4_threshold
,
Param_X4_threshold
))
Param
[
4L
]
<-
Param_X4_threshold
}
}
## Input data preparation
if
(
identical
(
RunOptions
$
IndPeriod_WarmUp
,
0L
))
{
RunOptions
$
IndPeriod_WarmUp
<-
NULL
...
...
@@ -71,28 +43,28 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
## Output data preparation
ExportDatesR
<-
"DatesR"
%in%
RunOptions
$
Outputs_Sim
ExportStateEnd
<-
"StateEnd"
%in%
RunOptions
$
Outputs_Sim
## CemaNeige________________________________________________________________________________
if
(
inherits
(
RunOptions
,
"CemaNeige"
))
{
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
FortranOutputs
$
CN
))
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
CN
))
}
else
{
IndOutputsCemaNeige
<-
which
(
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsCemaNeige
<-
which
(
RunOptions
$
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
}
CemaNeigeLayers
<-
list
()
CemaNeigeStateEnd
<-
NULL
NameCemaNeigeLayers
<-
"CemaNeigeLayers"
## Call CemaNeige Fortran_________________________
for
(
iLayer
in
1
:
NLayers
)
{
for
(
iLayer
in
1
:
NLayers
)
{
if
(
!
IsHyst
)
{