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
eec01d4f
Commit
eec01d4f
authored
Mar 01, 2019
by
Delaigue Olivier
Browse files
v1.2.7.3 CLEAN: remove unnecessary return(NULL) after stops
parent
f53b6a57
Changes
27
Hide whitespace changes
Inline
Side-by-side
DESCRIPTION
View file @
eec01d4f
Package: airGR
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.2.7.
2
Version: 1.2.7.
3
Date: 2019-03-01
Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
...
...
NEWS.rmd
View file @
eec01d4f
...
...
@@ -13,7 +13,7 @@ output:
### 1.2.7.
2
Release Notes (2019-03-01)
### 1.2.7.
3
Release Notes (2019-03-01)
...
...
R/Calibration_Michel.R
View file @
eec01d4f
...
...
@@ -5,27 +5,21 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##_____Arguments_check_____________________________________________________________________
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"InputsModel must be of class 'InputsModel'"
)
return
(
NULL
)
}
if
(
!
inherits
(
RunOptions
,
"RunOptions"
))
{
stop
(
"RunOptions must be of class 'RunOptions'"
)
return
(
NULL
)
}
if
(
!
inherits
(
InputsCrit
,
"InputsCrit"
))
{
stop
(
"InputsCrit must be of class 'InputsCrit'"
)
return
(
NULL
)
}
if
(
inherits
(
InputsCrit
,
"Multi"
))
{
stop
(
"InputsCrit must be of class 'Single' or 'Compo'"
)
return
(
NULL
)
}
if
(
!
inherits
(
CalibOptions
,
"CalibOptions"
))
{
stop
(
"CalibOptions must be of class 'CalibOptions'"
)
return
(
NULL
)
}
if
(
!
inherits
(
CalibOptions
,
"HBAN"
))
{
stop
(
"CalibOptions must be of class 'HBAN' if Calibration_Michel is used"
)
return
(
NULL
)
}
if
(
!
missing
(
FUN_CRIT
))
{
warning
(
"argument 'FUN_CRIT' is deprecated. The error criterion function is now automatically get from the 'InputsCrit' object"
,
call.
=
FALSE
)
...
...
@@ -92,7 +86,6 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
}
if
(
is.null
(
FUN_TRANSFO
))
{
stop
(
"FUN_TRANSFO was not found (in Calibration function)"
)
return
(
NULL
)
}
}
...
...
@@ -115,7 +108,6 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
}
if
(
NParam
>
20
)
{
stop
(
"Calibration_Michel can handle a maximum of 20 parameters"
)
return
(
NULL
)
}
HistParamR
<-
matrix
(
NA
,
nrow
=
500
*
NParam
,
ncol
=
NParam
)
HistParamT
<-
matrix
(
NA
,
nrow
=
500
*
NParam
,
ncol
=
NParam
)
...
...
@@ -238,11 +230,9 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Format_checking
if
(
nrow
(
NewParamOptimT
)
!=
1
|
nrow
(
OldParamOptimT
)
!=
1
)
{
stop
(
"each input set must be a matrix of one single line"
)
return
(
NULL
)
}
if
(
ncol
(
NewParamOptimT
)
!=
ncol
(
OldParamOptimT
)
|
ncol
(
NewParamOptimT
)
!=
length
(
OptimParam
))
{
stop
(
"each input set must have the same number of values"
)
return
(
NULL
)
}
##Proposal_of_new_parameter_sets ###(local search providing 2 * NParam-1 new sets)
NParam
<-
ncol
(
NewParamOptimT
)
...
...
R/CreateCalibOptions.R
View file @
eec01d4f
...
...
@@ -172,15 +172,12 @@ CreateCalibOptions <-
}
else
{
if
(
!
is.vector
(
FixedParam
))
{
stop
(
"FixedParam must be a vector"
)
return
(
NULL
)
}
if
(
length
(
FixedParam
)
!=
NParam
)
{
stop
(
"Incompatibility between FixedParam length and FUN_MOD"
)
return
(
NULL
)
}
if
(
all
(
!
is.na
(
FixedParam
)))
{
stop
(
"At least one parameter must be not set (NA)"
)
return
(
NULL
)
}
if
(
all
(
is.na
(
FixedParam
)))
{
warning
(
"You have not set any parameter in \"FixedParam\""
)
...
...
@@ -197,23 +194,18 @@ CreateCalibOptions <-
}
else
{
if
(
!
is.matrix
(
SearchRanges
))
{
stop
(
"SearchRanges must be a matrix"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
SearchRanges
))
{
stop
(
"SearchRanges must be a matrix of numeric values"
)
return
(
NULL
)
}
if
(
sum
(
is.na
(
SearchRanges
))
!=
0
)
{
stop
(
"SearchRanges must not include NA values"
)
return
(
NULL
)
}
if
(
nrow
(
SearchRanges
)
!=
2
)
{
stop
(
"SearchRanges must have 2 rows"
)
return
(
NULL
)
}
if
(
ncol
(
SearchRanges
)
!=
NParam
)
{
stop
(
"Incompatibility between SearchRanges ncol and FUN_MOD"
)
return
(
NULL
)
}
}
...
...
@@ -280,37 +272,29 @@ CreateCalibOptions <-
if
(
"HBAN"
%in%
ObjectClass
&
!
is.null
(
StartParamList
))
{
if
(
!
is.matrix
(
StartParamList
))
{
stop
(
"StartParamList must be a matrix"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
StartParamList
))
{
stop
(
"StartParamList must be a matrix of numeric values"
)
return
(
NULL
)
}
if
(
sum
(
is.na
(
StartParamList
))
!=
0
)
{
stop
(
"StartParamList must not include NA values"
)
return
(
NULL
)
}
if
(
ncol
(
StartParamList
)
!=
NParam
)
{
stop
(
"Incompatibility between StartParamList ncol and FUN_MOD"
)
return
(
NULL
)
}
}
if
(
"HBAN"
%in%
ObjectClass
&
!
is.null
(
StartParamDistrib
))
{
if
(
!
is.matrix
(
StartParamDistrib
))
{
stop
(
"StartParamDistrib must be a matrix"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
StartParamDistrib
[
1
,
]))
{
stop
(
"StartParamDistrib must be a matrix of numeric values"
)
return
(
NULL
)
}
if
(
sum
(
is.na
(
StartParamDistrib
[
1
,
]))
!=
0
)
{
stop
(
"StartParamDistrib must not include NA values on the first line"
)
return
(
NULL
)
}
if
(
ncol
(
StartParamDistrib
)
!=
NParam
)
{
stop
(
"Incompatibility between StartParamDistrib ncol and FUN_MOD"
)
return
(
NULL
)
}
}
...
...
R/CreateIniStates.R
View file @
eec01d4f
...
...
@@ -43,22 +43,18 @@ CreateIniStates <- function(FUN_MOD, InputsModel,
}
if
(
!
BOOL
)
{
stop
(
"Incorrect 'FUN_MOD' for use in 'CreateIniStates'"
)
return
(
NULL
)
}
## check InputsModel
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"'InputsModel' must be of class 'InputsModel'"
)
return
(
NULL
)
}
if
(
"GR"
%in%
ObjectClass
&
!
inherits
(
InputsModel
,
"GR"
))
{
stop
(
"'InputsModel' must be of class 'GR'"
)
return
(
NULL
)
}
if
(
"CemaNeige"
%in%
ObjectClass
&
!
inherits
(
InputsModel
,
"CemaNeige"
))
{
stop
(
"'InputsModel' must be of class 'CemaNeige'"
)
return
(
NULL
)
}
...
...
@@ -70,7 +66,6 @@ CreateIniStates <- function(FUN_MOD, InputsModel,
if
(
identical
(
FUN_MOD
,
RunModel_GR6J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR6J
))
{
if
(
is.null
(
ExpStore
))
{
stop
(
"'RunModel_*GR6J' need an 'ExpStore' value"
)
return
(
NULL
)
}
}
else
if
(
!
is.null
(
ExpStore
))
{
if
(
verbose
)
{
...
...
@@ -136,7 +131,6 @@ CreateIniStates <- function(FUN_MOD, InputsModel,
if
(
"CemaNeige"
%in%
ObjectClass
&
(
is.null
(
GCemaNeigeLayers
)
|
is.null
(
eTGCemaNeigeLayers
)))
{
stop
(
"'RunModel_CemaNeigeGR*' need values for 'GCemaNeigeLayers' and 'GCemaNeigeLayers'"
)
return
(
NULL
)
}
if
(
!
"CemaNeige"
%in%
ObjectClass
&
(
!
is.null
(
GCemaNeigeLayers
)
|
!
is.null
(
eTGCemaNeigeLayers
)))
{
...
...
R/CreateInputsCrit.R
View file @
eec01d4f
...
...
@@ -40,7 +40,6 @@ CreateInputsCrit <- function(FUN_CRIT,
## check 'InputsModel'
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"'InputsModel' must be of class 'InputsModel'"
)
return
(
NULL
)
}
...
...
@@ -109,7 +108,6 @@ CreateInputsCrit <- function(FUN_CRIT,
## check 'RunOptions'
if
(
!
inherits
(
RunOptions
,
"RunOptions"
))
{
stop
(
"'RunOptions' must be of class 'RunOptions'"
)
return
(
NULL
)
}
...
...
@@ -140,17 +138,14 @@ CreateInputsCrit <- function(FUN_CRIT,
if
(
!
(
identical
(
iListArgs2
$
FUN_CRIT
,
ErrorCrit_NSE
)
|
identical
(
iListArgs2
$
FUN_CRIT
,
ErrorCrit_KGE
)
|
identical
(
iListArgs2
$
FUN_CRIT
,
ErrorCrit_KGE2
)
|
identical
(
iListArgs2
$
FUN_CRIT
,
ErrorCrit_RMSE
)))
{
stop
(
"incorrect 'FUN_CRIT' for use in 'CreateInputsCrit'"
,
call.
=
FALSE
)
return
(
NULL
)
}
if
(
identical
(
iListArgs2
$
FUN_CRIT
,
ErrorCrit_RMSE
)
&
length
(
listArgs
$
weights
)
>
1
&
all
(
!
is.null
(
unlist
(
listArgs
$
weights
))))
{
stop
(
"calculating a composite criterion with the RMSE is not allowed since RMSE is not an adimensional measure"
,
call.
=
FALSE
)
return
(
NULL
)
}
## check 'obs'
if
(
!
is.vector
(
iListArgs2
$
obs
)
|
length
(
iListArgs2
$
obs
)
!=
LLL
|
!
is.numeric
(
iListArgs2
$
obs
))
{
stop
(
sprintf
(
"'obs' must be a (list of) vector(s) of numeric values of length %i"
,
LLL
),
call.
=
FALSE
)
return
(
NULL
)
}
## check 'BoolCrit'
...
...
@@ -159,17 +154,14 @@ CreateInputsCrit <- function(FUN_CRIT,
}
if
(
!
is.logical
(
iListArgs2
$
BoolCrit
))
{
stop
(
"'BoolCrit' must be a (list of) vector(s) of boolean"
,
call.
=
FALSE
)
return
(
NULL
)
}
if
(
length
(
iListArgs2
$
BoolCrit
)
!=
LLL
)
{
stop
(
"'BoolCrit' and 'InputsModel' series must have the same length"
,
call.
=
FALSE
)
return
(
NULL
)
}
## check 'varObs'
if
(
!
is.vector
(
iListArgs2
$
varObs
)
|
length
(
iListArgs2
$
varObs
)
!=
1
|
!
is.character
(
iListArgs2
$
varObs
)
|
!
all
(
iListArgs2
$
varObs
%in%
inVarObs
))
{
stop
(
msgVarObs
,
call.
=
FALSE
)
return
(
NULL
)
}
## check 'varObs' + 'obs'
...
...
@@ -193,14 +185,12 @@ CreateInputsCrit <- function(FUN_CRIT,
## check 'transfo'
if
(
is.null
(
iListArgs2
$
transfo
)
|
!
is.vector
(
iListArgs2
$
transfo
)
|
length
(
iListArgs2
$
transfo
)
!=
1
|
!
is.character
(
iListArgs2
$
transfo
)
|
!
all
(
iListArgs2
$
transfo
%in%
inTransfo
))
{
stop
(
msgTransfo
,
call.
=
FALSE
)
return
(
NULL
)
}
## check 'weights'
if
(
!
is.null
(
iListArgs2
$
weights
))
{
if
(
!
is.vector
(
iListArgs2
$
weights
)
|
length
(
iListArgs2
$
weights
)
!=
1
|
!
is.numeric
(
iListArgs2
$
weights
)
|
any
(
iListArgs2
$
weights
<
0
))
{
stop
(
"'weights' must be a single (list of) positive or equal to zero value(s)"
,
call.
=
FALSE
)
return
(
NULL
)
}
}
...
...
@@ -208,7 +198,6 @@ CreateInputsCrit <- function(FUN_CRIT,
if
(
!
is.null
(
iListArgs2
$
epsilon
))
{
if
(
!
is.vector
(
iListArgs2
$
epsilon
)
|
length
(
iListArgs2
$
epsilon
)
!=
1
|
!
is.numeric
(
iListArgs2
$
epsilon
)
|
any
(
iListArgs2
$
epsilon
<=
0
))
{
stop
(
"'epsilon' must be a single (list of) positive value(s)"
,
call.
=
FALSE
)
return
(
NULL
)
}
}
else
if
(
iListArgs2
$
transfo
%in%
c
(
"log"
,
"inv"
)
&
any
(
iListArgs2
$
obs
%in%
0
)
&
warnings
)
{
warning
(
"zeroes detected in obs: the corresponding time-steps will be excluded by the 'ErrorCrit*' functions if the epsilon agrument = NULL"
,
call.
=
FALSE
)
...
...
@@ -259,7 +248,6 @@ CreateInputsCrit <- function(FUN_CRIT,
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
)
}
return
(
NULL
)
})
}
...
...
R/CreateInputsModel.R
View file @
eec01d4f
...
...
@@ -59,18 +59,15 @@ CreateInputsModel <- function(FUN_MOD,
}
if
(
!
BOOL
)
{
stop
(
"Incorrect FUN_MOD for use in CreateInputsModel"
)
return
(
NULL
)
}
##check_arguments
if
(
"GR"
%in%
ObjectClass
|
"CemaNeige"
%in%
ObjectClass
)
{
if
(
is.null
(
DatesR
))
{
stop
(
"DatesR is missing"
)
return
(
NULL
)
}
if
(
"POSIXlt"
%in%
class
(
DatesR
)
==
FALSE
&
"POSIXct"
%in%
class
(
DatesR
)
==
FALSE
)
{
stop
(
"DatesR must be defined as POSIXlt or POSIXct"
)
return
(
NULL
)
}
if
(
"POSIXlt"
%in%
class
(
DatesR
)
==
FALSE
)
{
DatesR
<-
as.POSIXlt
(
DatesR
)
...
...
@@ -78,101 +75,79 @@ CreateInputsModel <- function(FUN_MOD,
if
(
difftime
(
tail
(
DatesR
,
1
),
tail
(
DatesR
,
2
),
units
=
"secs"
)[[
1
]]
%in%
TimeStep
==
FALSE
)
{
TimeStepName
<-
grep
(
"hourly|daily|monthly|yearly"
,
ObjectClass
,
value
=
TRUE
)
stop
(
paste0
(
"The time step of the model inputs must be "
,
TimeStepName
,
"\n"
))
return
(
NULL
)
}
if
(
any
(
duplicated
(
DatesR
)))
{
stop
(
"DatesR must not include duplicated values"
)
return
(
NULL
)
}
LLL
<-
length
(
DatesR
)
}
if
(
"GR"
%in%
ObjectClass
)
{
if
(
is.null
(
Precip
))
{
stop
(
"Precip is missing"
)
return
(
NULL
)
}
if
(
is.null
(
PotEvap
))
{
stop
(
"PotEvap is missing"
)
return
(
NULL
)
}
if
(
!
is.vector
(
Precip
)
|
!
is.vector
(
PotEvap
))
{
stop
(
"Precip and PotEvap must be vectors of numeric values"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
Precip
)
|
!
is.numeric
(
PotEvap
))
{
stop
(
"Precip and PotEvap must be vectors of numeric values"
)
return
(
NULL
)
}
if
(
length
(
Precip
)
!=
LLL
|
length
(
PotEvap
)
!=
LLL
)
{
stop
(
"Precip, PotEvap and DatesR must have the same length"
)
return
(
NULL
)
}
}
if
(
"CemaNeige"
%in%
ObjectClass
)
{
if
(
is.null
(
Precip
))
{
stop
(
"Precip is missing"
)
return
(
NULL
)
}
if
(
is.null
(
TempMean
))
{
stop
(
"TempMean is missing"
)
return
(
NULL
)
}
if
(
!
is.vector
(
Precip
)
|
!
is.vector
(
TempMean
))
{
stop
(
"Precip and TempMean must be vectors of numeric values"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
Precip
)
|
!
is.numeric
(
TempMean
))
{
stop
(
"Precip and TempMean must be vectors of numeric values"
)
return
(
NULL
)
}
if
(
length
(
Precip
)
!=
LLL
|
length
(
TempMean
)
!=
LLL
)
{
stop
(
"Precip, TempMean and DatesR must have the same length"
)
return
(
NULL
)
}
if
(
is.null
(
TempMin
)
!=
is.null
(
TempMax
))
{
stop
(
"TempMin and TempMax must be both defined if not null"
)
return
(
NULL
)
}
if
(
!
is.null
(
TempMin
)
&
!
is.null
(
TempMax
))
{
if
(
!
is.vector
(
TempMin
)
|
!
is.vector
(
TempMax
))
{
stop
(
"TempMin and TempMax must be vectors of numeric values"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
TempMin
)
|
!
is.numeric
(
TempMax
))
{
stop
(
"TempMin and TempMax must be vectors of numeric values"
)
return
(
NULL
)
}
if
(
length
(
TempMin
)
!=
LLL
|
length
(
TempMax
)
!=
LLL
)
{
stop
(
"TempMin, TempMax and DatesR must have the same length"
)
return
(
NULL
)
}
}
if
(
!
is.null
(
HypsoData
))
{
if
(
!
is.vector
(
HypsoData
))
{
stop
(
"HypsoData must be a vector of numeric values if not null"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
HypsoData
))
{
stop
(
"HypsoData must be a vector of numeric values if not null"
)
return
(
NULL
)
}
if
(
length
(
HypsoData
)
!=
101
)
{
stop
(
"HypsoData must be of length 101 if not null"
)
return
(
NULL
)
}
if
(
sum
(
is.na
(
HypsoData
))
!=
0
&
sum
(
is.na
(
HypsoData
))
!=
101
)
{
stop
(
"HypsoData must not contain any NA if not null"
)
return
(
NULL
)
}
}
if
(
!
is.null
(
ZInputs
))
{
if
(
length
(
ZInputs
)
!=
1
)
{
stop
(
"\t ZInputs must be a single numeric value if not null"
)
return
(
NULL
)
}
if
(
is.na
(
ZInputs
)
|
!
is.numeric
(
ZInputs
))
{
stop
(
"\t ZInputs must be a single numeric value if not null"
)
return
(
NULL
)
}
}
if
(
is.null
(
HypsoData
))
{
...
...
@@ -192,7 +167,6 @@ CreateInputsModel <- function(FUN_MOD,
}
if
(
NLayers
<=
0
)
{
stop
(
"NLayers must be a positive integer value"
)
return
(
NULL
)
}
if
(
NLayers
!=
as.integer
(
NLayers
))
{
warning
(
"Coerce NLayers to be of integer type ("
,
NLayers
,
" => "
,
as.integer
(
NLayers
),
")"
)
...
...
@@ -260,7 +234,6 @@ CreateInputsModel <- function(FUN_MOD,
if
(
Select
[
1L
]
>
Select
[
2L
])
{
stop
(
"Time series could not be trunced since missing values were detected at the list time-step"
)
return
(
NULL
)
}
if
(
"GR"
%in%
ObjectClass
)
{
Precip
<-
Precip
[
Select
]
...
...
R/CreateRunOptions.R
View file @
eec01d4f
...
...
@@ -38,60 +38,48 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
}
if
(
!
BOOL
)
{
stop
(
"incorrect 'FUN_MOD' for use in 'CreateRunOptions'"
)
return
(
NULL
)
}
##check_InputsModel
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"'InputsModel' must be of class 'InputsModel'"
)
return
(
NULL
)
}
if
(
"GR"
%in%
ObjectClass
&
!
inherits
(
InputsModel
,
"GR"
))
{
stop
(
"'InputsModel' must be of class 'GR'"
)
return
(
NULL
)
}
if
(
"CemaNeige"
%in%
ObjectClass
&
!
inherits
(
InputsModel
,
"CemaNeige"
))
{
stop
(
"'InputsModel' must be of class 'CemaNeige'"
)
return
(
NULL
)
}
if
(
"hourly"
%in%
ObjectClass
&
!
inherits
(
InputsModel
,
"hourly"
))
{
stop
(
"'InputsModel' must be of class 'hourly'"
)
return
(
NULL
)
}
if
(
"daily"
%in%
ObjectClass
&
!
inherits
(
InputsModel
,
"daily"
))
{
stop
(
"'InputsModel' must be of class 'daily'"
)
return
(
NULL
)
}
if
(
"monthly"
%in%
ObjectClass
&
!
inherits
(
InputsModel
,
"monthly"
))
{
stop
(
"'InputsModel' must be of class 'monthly'"
)
return
(
NULL
)
}
if
(
"yearly"
%in%
ObjectClass
&
!
inherits
(
InputsModel
,
"yearly"
))
{
stop
(
"'InputsModel' must be of class 'yearly'"
)
return
(
NULL
)
}
##check_IndPeriod_Run
if
(
!
is.vector
(
IndPeriod_Run
))
{
stop
(
"'IndPeriod_Run' must be a vector of numeric values"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
IndPeriod_Run
))
{
stop
(
"'IndPeriod_Run' must be a vector of numeric values"
)
return
(
NULL
)
}
if
(
identical
(
as.integer
(
IndPeriod_Run
),
as.integer
(
seq
(
from
=
IndPeriod_Run
[
1
],
to
=
tail
(
IndPeriod_Run
,
1
),
by
=
1
)))
==
FALSE
)
{
stop
(
"'IndPeriod_Run' must be a continuous sequence of integers"
)
return
(
NULL
)
}
if
(
storage.mode
(
IndPeriod_Run
)
!=
"integer"
)
{
stop
(
"'IndPeriod_Run' should be of type integer"
)
return
(
NULL
)
}
...
...
@@ -136,15 +124,12 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
if
(
!
is.null
(
IndPeriod_WarmUp
))
{
if
(
!
is.vector
(
IndPeriod_WarmUp
))
{
stop
(
"'IndPeriod_WarmUp' must be a vector of numeric values"
)
return
(
NULL
)
}
if
(
!
is.numeric
(
IndPeriod_WarmUp
))
{
stop
(
"'IndPeriod_WarmUp' must be a vector of numeric values"
)
return
(
NULL
)
}
if
(
storage.mode
(
IndPeriod_WarmUp
)
!=
"integer"
)
{
stop
(
"'IndPeriod_WarmUp' should be of type integer"
)
return
(
NULL
)
}
if
(
identical
(
IndPeriod_WarmUp
,
as.integer
(
0
))
&
verbose
)
{
message
(
paste0
(
WTxt
,
"\t No warm up period is used \n"
))
...
...
@@ -163,7 +148,6 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
if
(
!
is.null
(
IniResLevels
))
{
if
(
!
is.vector
(
IniResLevels
)
|
!
is.numeric
(
IniResLevels
)
|
any
(
is.na
(
IniResLevels
)))
{
stop
(
"'IniResLevels' must be a vector of numeric values"
)
return
(
NULL
)
}
if
((
identical
(
FUN_MOD
,
RunModel_GR4H
)
|
identical
(
FUN_MOD
,
RunModel_GR4J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR4J
)
|
...
...
@@ -171,12 +155,10 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
identical
(
FUN_MOD
,
RunModel_GR2M
))
&
length
(
IniResLevels
)
!=
2
)
{
stop
(
"The length of 'IniResLevels' must be 2 for the chosen 'FUN_MOD'"
)
return
(
NULL
)
}
if
((
identical
(
FUN_MOD
,
RunModel_GR6J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR6J
))
&
length
(
IniResLevels
)
!=
3
)
{
stop
(
"The length of 'IniResLevels' must be 3 for the chosen 'FUN_MOD'"
)
return
(
NULL
)
}
}
else
if
(
is.null
(
IniStates
))
{
if
(
identical
(
FUN_MOD
,
RunModel_GR6J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR6J
))
{
...
...
@@ -221,31 +203,24 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
if
(
!
inherits
(
IniStates
,
"IniStates"
))
{
stop
(
"'IniStates' must be an object of class 'IniStates'\n"
)
return
(
NULL
)
}
if
(
sum
(
ObjectClass
%in%
class
(
IniStates
))
<
2
)
{
stop
(
paste0
(
"Non convenient 'IniStates' for this 'FUN_MOD'\n"
))
return
(
NULL
)
}
if
(
identical
(
FUN_MOD
,
RunModel_GR1A
)
&
!
is.null
(
IniStates
))
{
## GR1A
stop
(
paste0
(
"'IniStates' is not available for this 'FUN_MOD'\n"
))
return
(
NULL
)
}
if
((
identical
(
FUN_MOD
,
RunModel_GR5J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR5J
))
&
!
all
(
is.na
(
IniStates
$
UH
$
UH1
)))
{
## GR5J
stop
(
paste0
(
"Non convenient IniStates for this 'FUN_MOD.' In 'IniStates', UH1 has to be a vector of NA for GR5J"
))
return
(
NULL
)
}
if
((
identical
(
FUN_MOD
,
RunModel_GR6J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR6J
))
&
is.na
(
IniStates
$
Store
$
Exp
))
{
## GR6J
stop
(
paste0
(
"Non convenient IniStates for this 'FUN_MOD.' GR6J needs an exponential store value in 'IniStates'"
))
return
(
NULL
)
}
if
(
!
(
identical
(
FUN_MOD
,
RunModel_GR6J
)
|
identical
(
FUN_MOD
,
RunModel_CemaNeigeGR6J
))
&
!
is.na
(
IniStates
$
Store
$
Exp
))
{
## except GR6J
stop
(
paste0
(
"Non convenient IniStates for this 'FUN_MOD.' No exponential store value needed in 'IniStates'"
))
return
(
NULL
)
}
# if (length(na.omit(unlist(IniStates))) != NState) {
# stop(paste0("The length of IniStates must be ", NState, " for the chosen FUN_MOD"))
# return(NULL)
# }
if
(
!
"CemaNeige"
%in%
ObjectClass
&
any
(
is.na
(
IniStates
$
CemaNeigeLayers
$
G
)))
{
IniStates
$
CemaNeigeLayers
$
G
<-
NULL
...
...
@@ -293,15 +268,12 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
##check_Outputs_Sim
if
(
!
is.vector
(
Outputs_Sim
))
{
stop
(
"Outputs_Sim must be a vector of characters"
)
return
(
NULL
)
}
if
(
!
is.character
(
Outputs_Sim
))
{
stop
(
"Outputs_Sim must be a vector of characters"
)
return
(
NULL
)
}
if
(
sum
(
is.na
(
Outputs_Sim
))
!=
0
)
{
stop
(
"Outputs_Sim must not contain NA"
)
return
(
NULL
)
}
if
(
"all"
%in%
Outputs_Sim
)
{
Outputs_Sim
<-
c
(
"DatesR"
,
Outputs_all
,
"StateEnd"
)
...
...
@@ -310,8 +282,6 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
if
(
length
(
Test
)
!=
0
)
{
stop
(
paste0
(
"'Outputs_Sim' is incorrectly defined: "
,
paste
(
Outputs_Sim
[
Test
],
collapse
=
", "
),
" not found"
))
return
(
NULL
)
}
Outputs_Sim
<-
Outputs_Sim
[
!
duplicated
(
Outputs_Sim
)]
...
...
@@ -331,15 +301,12 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
}
else
{
if
(
!
is.vector
(
Outputs_Cal
))
{
stop
(
"'Outputs_Cal' must be a vector of characters"
)
return
(
NULL
)
}
if
(
!
is.character
(
Outputs_Cal
))
{
stop
(
"'Outputs_Cal' must be a vector of characters"
)
return
(
NULL
)
}
if
(
sum
(
is.na
(
Outputs_Cal
))
!=
0
)
{
stop
(
"'Outputs_Cal' must not contain NA"
)
return
(
NULL
)
}
}
if
(
"all"
%in%
Outputs_Cal
)
{
...
...
@@ -351,8 +318,6 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
if
(
length
(
Test
)
!=
0
)
{
stop
(
paste0
(
"'Outputs_Cal' is incorrectly defined: "
,
paste
(
Outputs_Cal
[
Test
],
collapse
=
", "
),
" not found"
))
return
(
NULL
)
}
Outputs_Cal
<-
Outputs_Cal
[
!
duplicated
(
Outputs_Cal
)]
Outputs_Calxxx
<-
unique
(
Outputs_Cal
[
!
duplicated
(
Outputs_Cal
)])
...
...
@@ -388,7 +353,6 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
}
if
(
is.null
(
Factor
))
{
stop
(
"'InputsModel' must be of class 'hourly', 'daily', 'monthly' or 'yearly'"
)
return
(
NULL
)
}
MeanAnSolidPrecip
<-
rep
(
mean
(
SolidPrecip
)
*
Factor
,
NLayers
)
### default value: same Gseuil for all layers
...
...
@@ -401,15 +365,12 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
if
(
"CemaNeige"
%in%
ObjectClass
&
!
is.null
(
MeanAnSolidPrecip
))
{
if
(
!
is.vector
(
MeanAnSolidPrecip
))
{
stop
(
paste0
(
"'MeanAnSolidPrecip' must be a vector of numeric values"
))
return
(
NULL
)
}
if
(
!
is.numeric
(
MeanAnSolidPrecip
))
{
stop
(
paste0
(
"'MeanAnSolidPrecip' must be a vector of numeric values"
))
return
(
NULL
)
}