From 99f77c30db298605b937808ccb56a98d38829e91 Mon Sep 17 00:00:00 2001
From: Delaigue Olivier <olivier.delaigue@irstea.priv>
Date: Wed, 10 Oct 2018 11:14:59 +0200
Subject: [PATCH] v1.0.15.1 CLEAN: syntax revision of CreateRunOptions
---
DESCRIPTION | 4 +-
NEWS.rmd | 6 +-
R/CreateRunOptions.R | 679 +++++++++++++++++++++++++++----------------
3 files changed, 428 insertions(+), 261 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 22da82dc..1e2f71f2 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,8 +1,8 @@
Package: airGR
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
-Version: 1.0.15.0
-Date: 2018-10-05
+Version: 1.0.15.1
+Date: 2018-10-10
Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
person("Charles", "Perrin", role = c("aut", "ths"), comment = c(ORCID = "0000-0001-8552-1881")),
diff --git a/NEWS.rmd b/NEWS.rmd
index 0634ff1c..6802f1d3 100644
--- a/NEWS.rmd
+++ b/NEWS.rmd
@@ -13,7 +13,7 @@ output:
-### 1.0.14.5 Release Notes (2018-10-10)
+### 1.0.15.1 Release Notes (2018-10-10)
#### Bug fixes
@@ -21,6 +21,10 @@ output:
- Fixed bug in <code>CreateRunOptions()</code>. The function now accounts correctly for leap years when no warm-up period is defined.
+#### Minor user-visible changes
+
+- <code>CreateRunOptions()</code> was cleant, with no effect on its outputs.
+
____________________________________________________________________________________
diff --git a/R/CreateRunOptions.R b/R/CreateRunOptions.R
index 2c69dfa7..57c7bfef 100644
--- a/R/CreateRunOptions.R
+++ b/R/CreateRunOptions.R
@@ -4,290 +4,453 @@ CreateRunOptions <- function(FUN_MOD, InputsModel, IndPeriod_WarmUp = NULL, IndP
if (!missing(RunSnowModule)) {
warning("argument RunSnowModule is deprecated; please adapt FUN_MOD instead.", call. = FALSE)
}
-
+
ObjectClass <- NULL
-
+
##check_FUN_MOD
- BOOL <- FALSE;
- if(identical(FUN_MOD,RunModel_GR4H)){
- ObjectClass <- c(ObjectClass,"GR","hourly");
- BOOL <- TRUE;
- }
- if(identical(FUN_MOD,RunModel_GR4J) | identical(FUN_MOD,RunModel_GR5J) | identical(FUN_MOD,RunModel_GR6J)){
- ObjectClass <- c(ObjectClass,"GR","daily");
- BOOL <- TRUE;
- }
- if(identical(FUN_MOD,RunModel_GR2M)){
- ObjectClass <- c(ObjectClass,"GR","monthly");
- BOOL <- TRUE;
- }
- if(identical(FUN_MOD,RunModel_GR1A)){
- ObjectClass <- c(ObjectClass,"GR","yearly");
- BOOL <- TRUE;
- }
- if(identical(FUN_MOD,RunModel_CemaNeige)){
- ObjectClass <- c(ObjectClass,"CemaNeige","daily");
- BOOL <- TRUE;
- }
- if(identical(FUN_MOD,RunModel_CemaNeigeGR4J) | identical(FUN_MOD,RunModel_CemaNeigeGR5J) | identical(FUN_MOD,RunModel_CemaNeigeGR6J)){
- ObjectClass <- c(ObjectClass,"GR","CemaNeige","daily");
- BOOL <- TRUE;
- }
- if(!BOOL){ stop("incorrect FUN_MOD for use in CreateRunOptions \n"); return(NULL); }
-
-
+ BOOL <- FALSE;
+ if (identical(FUN_MOD, RunModel_GR4H)) {
+ ObjectClass <- c(ObjectClass, "GR", "hourly")
+ BOOL <- TRUE
+ }
+ if (identical(FUN_MOD, RunModel_GR4J) | identical(FUN_MOD, RunModel_GR5J) | identical(FUN_MOD, RunModel_GR6J)) {
+ ObjectClass <- c(ObjectClass, "GR", "daily")
+ BOOL <- TRUE
+ }
+ if (identical(FUN_MOD, RunModel_GR2M)) {
+ ObjectClass <- c(ObjectClass, "GR", "monthly")
+ BOOL <- TRUE
+ }
+ if (identical(FUN_MOD, RunModel_GR1A)) {
+ ObjectClass <- c(ObjectClass, "GR", "yearly")
+ BOOL <- TRUE
+ }
+ if (identical(FUN_MOD, RunModel_CemaNeige)) {
+ ObjectClass <- c(ObjectClass, "CemaNeige", "daily")
+ BOOL <- TRUE
+ }
+ if (identical(FUN_MOD, RunModel_CemaNeigeGR4J) | identical(FUN_MOD, RunModel_CemaNeigeGR5J) | identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
+ ObjectClass <- c(ObjectClass, "GR", "CemaNeige", "daily")
+ BOOL <- TRUE
+ }
+ if (!BOOL) {
+ stop("incorrect FUN_MOD for use in CreateRunOptions \n")
+ return(NULL)
+ }
+
##check_InputsModel
- if(!inherits(InputsModel,"InputsModel")){
- stop("InputsModel must be of class 'InputsModel' \n"); return(NULL); }
- if("GR" %in% ObjectClass & !inherits(InputsModel,"GR")){
- stop("InputsModel must be of class 'GR' \n"); return(NULL); }
- if("CemaNeige" %in% ObjectClass & !inherits(InputsModel,"CemaNeige")){
- stop("InputsModel must be of class 'CemaNeige' \n"); return(NULL); }
- if("hourly" %in% ObjectClass & !inherits(InputsModel,"hourly")){
- stop("InputsModel must be of class 'hourly' \n"); return(NULL); }
- if("daily" %in% ObjectClass & !inherits(InputsModel,"daily")){
- stop("InputsModel must be of class 'daily' \n"); return(NULL); }
- if("monthly" %in% ObjectClass & !inherits(InputsModel,"monthly")){
- stop("InputsModel must be of class 'monthly' \n"); return(NULL); }
- if("yearly" %in% ObjectClass & !inherits(InputsModel,"yearly")){
- stop("InputsModel must be of class 'yearly' \n"); return(NULL); }
-
-
+ if (!inherits(InputsModel, "InputsModel")) {
+ stop("InputsModel must be of class 'InputsModel' \n")
+ return(NULL)
+ }
+ if ("GR" %in% ObjectClass & !inherits(InputsModel, "GR")) {
+ stop("InputsModel must be of class 'GR' \n")
+ return(NULL)
+ }
+ if ("CemaNeige" %in% ObjectClass &
+ !inherits(InputsModel, "CemaNeige")) {
+ stop("InputsModel must be of class 'CemaNeige' \n")
+ return(NULL)
+ }
+ if ("hourly" %in% ObjectClass &
+ !inherits(InputsModel, "hourly")) {
+ stop("InputsModel must be of class 'hourly' \n")
+ return(NULL)
+ }
+ if ("daily" %in% ObjectClass & !inherits(InputsModel, "daily")) {
+ stop("InputsModel must be of class 'daily' \n")
+ return(NULL)
+ }
+ if ("monthly" %in% ObjectClass &
+ !inherits(InputsModel, "monthly")) {
+ stop("InputsModel must be of class 'monthly' \n")
+ return(NULL)
+ }
+ if ("yearly" %in% ObjectClass &
+ !inherits(InputsModel, "yearly")) {
+ stop("InputsModel must be of class 'yearly' \n")
+ return(NULL)
+ }
+
+
##check_IndPeriod_Run
- if(!is.vector( IndPeriod_Run)){ stop("IndPeriod_Run must be a vector of numeric values \n"); return(NULL); }
- if(!is.numeric(IndPeriod_Run)){ stop("IndPeriod_Run must be a vector of numeric values \n"); 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 \n"); return(NULL); }
- if(storage.mode(IndPeriod_Run)!="integer"){ stop("IndPeriod_Run should be of type integer \n"); return(NULL); }
-
-
+ if (!is.vector(IndPeriod_Run)) {
+ stop("IndPeriod_Run must be a vector of numeric values \n")
+ return(NULL)
+ }
+ if (!is.numeric(IndPeriod_Run)) {
+ stop("IndPeriod_Run must be a vector of numeric values \n")
+ 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 \n")
+ return(NULL)
+ }
+ if (storage.mode(IndPeriod_Run) != "integer") {
+ stop("IndPeriod_Run should be of type integer \n")
+ return(NULL)
+ }
+
+
##check_IndPeriod_WarmUp
- WTxt <- NULL;
- if(is.null(IndPeriod_WarmUp)){
- WTxt <- paste(WTxt,"\t Model warm up period not defined -> default configuration used \n",sep="");
- ##If_the_run_period_starts_at_the_very_beginning_of_the_time_series
- if(IndPeriod_Run[1]==as.integer(1)){
- IndPeriod_WarmUp <- as.integer(0);
- WTxt <- paste(WTxt,"\t No data were found for model warm up! \n",sep="");
+ WTxt <- NULL
+ if (is.null(IndPeriod_WarmUp)) {
+ WTxt <- paste0(WTxt,"\t Model warm up period not defined -> default configuration used \n")
+ ##If_the_run_period_starts_at_the_very_beginning_of_the_time_series
+ if (IndPeriod_Run[1] == as.integer(1)) {
+ IndPeriod_WarmUp <- as.integer(0)
+ WTxt <- paste0(WTxt,"\t No data were found for model warm up! \n")
##We_look_for_the_longest_period_preceeding_the_run_period_with_a_maximum_of_one_year
- } else {
- TmpDateR0 <- InputsModel$DatesR[IndPeriod_Run[1]]
- TmpDateR <- TmpDateR0 - 365*24*60*60; ### minimal date to start the warmup
- if (format(TmpDateR, format = "%d") != format(TmpDateR0, format = "%d")) { ### leap year
- TmpDateR <- TmpDateR - 1*24*60*60
- }
- IndPeriod_WarmUp <- which(InputsModel$DatesR==max(InputsModel$DatesR[1],TmpDateR)) : (IndPeriod_Run[1]-1);
- if("hourly" %in% ObjectClass){ TimeStep <- as.integer( 60*60); }
- if("daily" %in% ObjectClass){ TimeStep <- as.integer( 24*60*60); }
- if("monthly" %in% ObjectClass){ TimeStep <- as.integer( 30.44*24*60*60); }
- if("yearly" %in% ObjectClass){ TimeStep <- as.integer(365.25*24*60*60); }
- if(length(IndPeriod_WarmUp)*TimeStep/(365*24*60*60)>=1){
- WTxt <- paste(WTxt,"\t The year preceding the run period is used \n",sep="");
- } else {
- WTxt <- paste(WTxt,"\t Less than a year (without missing values) was found for model warm up: \n",sep="");
- WTxt <- paste(WTxt,"\t (",length(IndPeriod_WarmUp)," time-steps are used for initialisation) \n",sep="");
- }
+ } else {
+ TmpDateR0 <- InputsModel$DatesR[IndPeriod_Run[1]]
+ TmpDateR <- TmpDateR0 - 365 * 24 * 60 * 60
+ ### minimal date to start the warmup
+ if (format(TmpDateR, format = "%d") != format(TmpDateR0, format = "%d")) {
+ ### leap year
+ TmpDateR <- TmpDateR - 1 * 24 * 60 * 60
}
- }
- if(!is.null(IndPeriod_WarmUp)){
- if(!is.vector( IndPeriod_WarmUp)){ stop("IndPeriod_Run must be a vector of numeric values \n"); return(NULL); }
- if(!is.numeric(IndPeriod_WarmUp)){ stop("IndPeriod_Run must be a vector of numeric values \n"); return(NULL); }
- if(storage.mode(IndPeriod_WarmUp)!="integer"){ stop("IndPeriod_Run should be of type integer \n"); return(NULL); }
- if(identical(IndPeriod_WarmUp,as.integer(0))){
- WTxt <- paste(WTxt,"\t No warm up period is used! \n",sep=""); }
- if((IndPeriod_Run[1]-1)!=tail(IndPeriod_WarmUp,1) & !identical(IndPeriod_WarmUp,as.integer(0))){
- WTxt <- paste(WTxt,"\t Model warm up period is not directly before the model run period \n",sep=""); }
- }
- if(!is.null(WTxt) & verbose){ warning(WTxt); }
-
-
- ## check IniResLevels
- if ("GR" %in% ObjectClass & ("monthly" %in% ObjectClass | "daily" %in% ObjectClass | "hourly" %in% ObjectClass)) {
- if (!is.null(IniResLevels)) {
- if (!is.vector(IniResLevels) | !is.numeric(IniResLevels) | any(is.na(IniResLevels))) {
- stop("IniResLevels must be a vector of numeric values \n")
- return(NULL)
- }
- if ((identical(FUN_MOD, RunModel_GR4H) |
- identical(FUN_MOD, RunModel_GR4J) | identical(FUN_MOD, RunModel_CemaNeigeGR4J) |
- identical(FUN_MOD, RunModel_GR5J) | identical(FUN_MOD, RunModel_CemaNeigeGR5J) |
- identical(FUN_MOD, RunModel_GR2M)) &
- length(IniResLevels) != 2) {
- stop("The length of IniResLevels must be 2 for the chosen FUN_MOD \n")
- 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 \n")
- return(NULL)
- }
- } else if (is.null(IniStates)) {
- if (identical(FUN_MOD, RunModel_GR6J) | identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
- IniResLevels <- as.double(c(0.3, 0.5, 0))
- } else {
- IniResLevels <- as.double(c(0.3, 0.5, NA))
- }
+ IndPeriod_WarmUp <- which(InputsModel$DatesR == max(InputsModel$DatesR[1], TmpDateR)):(IndPeriod_Run[1] - 1)
+ if ("hourly" %in% ObjectClass) {
+ TimeStep <- as.integer(60 * 60)
}
- } else {
- if (!is.null(IniResLevels)) {
- stop("IniResLevels can only be used with monthly or daily or hourly GR models \n")
+ if ("daily" %in% ObjectClass) {
+ TimeStep <- as.integer(24 * 60 * 60)
}
- }
- ## check IniStates
- if (is.null(IniStates) & is.null(IniResLevels) & verbose) {
- warning("\t Model states initialisation not defined -> default configuration used \n")
- }
- if (!is.null(IniStates) & !is.null(IniResLevels) & verbose) {
- warning("\t IniStates and IniResLevels are both defined -> Store levels are taken from IniResLevels \n")
- }
- if("CemaNeige" %in% ObjectClass){ NLayers <- length(InputsModel$LayerPrecip); } else { NLayers <- 0; }
- NState <- NULL;
- if("GR" %in% ObjectClass | "CemaNeige" %in% ObjectClass){
- if("hourly" %in% ObjectClass){ NState <- 7 + 3*24*20 }
- if("daily" %in% ObjectClass){ NState <- 7 + 3*20 + 2*NLayers }
- if("monthly" %in% ObjectClass){ NState <- 2; }
- if("yearly" %in% ObjectClass){ NState <- 1; }
- }
- if (!is.null(IniStates)) {
- if (!inherits(IniStates, "IniStates")) {
- stop("IniStates must be an object of class IniStates\n")
- return(NULL)
+ if ("monthly" %in% ObjectClass) {
+ TimeStep <- as.integer(30.44 * 24 * 60 * 60)
}
- if (sum(ObjectClass %in% class(IniStates)) < 2) {
- stop(paste0("Non convenient IniStates for this FUN_MOD\n"))
- return(NULL)
+ if ("yearly" %in% ObjectClass) {
+ TimeStep <- as.integer(365.25 * 24 * 60 * 60)
}
- if (identical(FUN_MOD, RunModel_GR1A) & !is.null(IniStates)) { ## GR1A
- stop(paste0("IniStates is not available for this FUN_MOD\n"))
- return(NULL)
+ if (length(IndPeriod_WarmUp) * TimeStep / (365 * 24 * 60 * 60) >= 1) {
+ WTxt <- paste0(WTxt, "\t The year preceding the run period is used \n")
+ } else {
+ WTxt <- paste0(WTxt, "\t Less than a year (without missing values) was found for model warm up: \n")
+ WTxt <- paste0(WTxt, "\t (", length(IndPeriod_WarmUp), " time-steps are used for initialisation) \n")
}
- 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 \n"))
+ }
+ }
+ if (!is.null(IndPeriod_WarmUp)) {
+ if (!is.vector(IndPeriod_WarmUp)) {
+ stop("IndPeriod_Run must be a vector of numeric values \n")
+ return(NULL)
+ }
+ if (!is.numeric(IndPeriod_WarmUp)) {
+ stop("IndPeriod_Run must be a vector of numeric values \n")
+ return(NULL)
+ }
+ if (storage.mode(IndPeriod_WarmUp) != "integer") {
+ stop("IndPeriod_Run should be of type integer \n")
+ return(NULL)
+ }
+ if (identical(IndPeriod_WarmUp, as.integer(0))) {
+ WTxt <- paste0(WTxt, "\t No warm up period is used! \n")
+ }
+ if ((IndPeriod_Run[1] - 1) != tail(IndPeriod_WarmUp, 1) & !identical(IndPeriod_WarmUp, as.integer(0))) {
+ WTxt <- paste0(WTxt, "\t Model warm up period is not directly before the model run period \n")
+ }
+ }
+ if (!is.null(WTxt) & verbose) {
+ warning(WTxt)
+
+ }
+
+
+ ## check IniResLevels
+ if ("GR" %in% ObjectClass & ("monthly" %in% ObjectClass | "daily" %in% ObjectClass | "hourly" %in% ObjectClass)) {
+ if (!is.null(IniResLevels)) {
+ if (!is.vector(IniResLevels) | !is.numeric(IniResLevels) | any(is.na(IniResLevels))) {
+ stop("IniResLevels must be a vector of numeric values \n")
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 \n"))
+ if ((identical(FUN_MOD, RunModel_GR4H) |
+ identical(FUN_MOD, RunModel_GR4J) | identical(FUN_MOD, RunModel_CemaNeigeGR4J) |
+ identical(FUN_MOD, RunModel_GR5J) | identical(FUN_MOD, RunModel_CemaNeigeGR5J) |
+ identical(FUN_MOD, RunModel_GR2M)) &
+ length(IniResLevels) != 2) {
+ stop("The length of IniResLevels must be 2 for the chosen FUN_MOD \n")
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 \n"))
+ 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 \n")
return(NULL)
}
- # if (length(na.omit(unlist(IniStates))) != NState) {
- # stop(paste0("The length of IniStates must be ", NState, " for the chosen FUN_MOD \n"))
- # return(NULL)
- # }
- if (!"CemaNeige" %in% ObjectClass & any(is.na(IniStates$CemaNeigeLayers$G ))) {
- IniStates$CemaNeigeLayers$G <- NULL
- }
- if (!"CemaNeige" %in% ObjectClass & any(is.na(IniStates$CemaNeigeLayers$eTG))) {
- IniStates$CemaNeigeLayers$eTG <- NULL
+ } else if (is.null(IniStates)) {
+ if (identical(FUN_MOD, RunModel_GR6J) | identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
+ IniResLevels <- as.double(c(0.3, 0.5, 0))
+ } else {
+ IniResLevels <- as.double(c(0.3, 0.5, NA))
}
- IniStates$Store$Rest <- rep(NA, 4)
- IniStates <- unlist(IniStates)
- IniStates[is.na(IniStates)] <- 0
- if ("monthly" %in% ObjectClass) {
- IniStates <- IniStates[seq_len(NState)]
- }
- } else {
- IniStates <- as.double(rep(0.0, NState))
}
-
-
+ } else {
+ if (!is.null(IniResLevels)) {
+ stop("IniResLevels can only be used with monthly or daily or hourly GR models \n")
+ }
+ }
+ ## check IniStates
+ if (is.null(IniStates) & is.null(IniResLevels) & verbose) {
+ warning("\t Model states initialisation not defined -> default configuration used \n")
+ }
+ if (!is.null(IniStates) & !is.null(IniResLevels) & verbose) {
+ warning("\t IniStates and IniResLevels are both defined -> Store levels are taken from IniResLevels \n")
+ }
+ if ("CemaNeige" %in% ObjectClass) {
+ NLayers <- length(InputsModel$LayerPrecip)
+ } else {
+ NLayers <- 0
+ }
+ NState <- NULL
+ if ("GR" %in% ObjectClass | "CemaNeige" %in% ObjectClass) {
+ if ("hourly" %in% ObjectClass) {
+ NState <- 7 + 3 * 24 * 20
+ }
+ if ("daily" %in% ObjectClass) {
+ NState <- 7 + 3 * 20 + 2 * NLayers
+ }
+ if ("monthly" %in% ObjectClass) {
+ NState <- 2
+ }
+ if ("yearly" %in% ObjectClass) {
+ NState <- 1
+ }
+ }
+ if (!is.null(IniStates)) {
+
+ 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 \n"))
+ 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 \n"))
+ 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 \n"))
+ return(NULL)
+ }
+ # if (length(na.omit(unlist(IniStates))) != NState) {
+ # stop(paste0("The length of IniStates must be ", NState, " for the chosen FUN_MOD \n"))
+ # return(NULL)
+ # }
+ if (!"CemaNeige" %in% ObjectClass & any(is.na(IniStates$CemaNeigeLayers$G ))) {
+ IniStates$CemaNeigeLayers$G <- NULL
+ }
+ if (!"CemaNeige" %in% ObjectClass & any(is.na(IniStates$CemaNeigeLayers$eTG))) {
+ IniStates$CemaNeigeLayers$eTG <- NULL
+ }
+ IniStates$Store$Rest <- rep(NA, 4)
+ IniStates <- unlist(IniStates)
+ IniStates[is.na(IniStates)] <- 0
+ if ("monthly" %in% ObjectClass) {
+ IniStates <- IniStates[seq_len(NState)]
+ }
+ } else {
+ IniStates <- as.double(rep(0.0, NState))
+ }
+
+
##check_Outputs_Cal_and_Sim
-
- ##Outputs_all
- Outputs_all <- NULL;
- if(identical(FUN_MOD,RunModel_GR4H)){
- Outputs_all <- c(Outputs_all,"PotEvap","Precip","Prod","AE","Perc","PR","Q9","Q1","Rout","Exch","AExch","QR","QD","Qsim"); }
- if(identical(FUN_MOD,RunModel_GR4J) | identical(FUN_MOD,RunModel_CemaNeigeGR4J)){
- Outputs_all <- c(Outputs_all,"PotEvap", "Precip", "Prod", "Pn", "Ps", "AE", "Perc", "PR", "Q9", "Q1", "Rout", "Exch",
- "AExch1", "AExch2", "AExch", "QR", "QD", "Qsim"); }
- if(identical(FUN_MOD,RunModel_GR5J) | identical(FUN_MOD,RunModel_CemaNeigeGR5J)){
- Outputs_all <- c(Outputs_all,"PotEvap", "Precip", "Prod", "Pn", "Ps", "AE", "Perc", "PR", "Q9", "Q1", "Rout", "Exch",
- "AExch1", "AExch2", "AExch", "QR", "QD", "Qsim"); }
- if(identical(FUN_MOD,RunModel_GR6J) | identical(FUN_MOD,RunModel_CemaNeigeGR6J)){
- Outputs_all <- c(Outputs_all,"PotEvap", "Precip", "Prod", "Pn", "Ps", "AE", "Perc", "PR", "Q9", "Q1", "Rout", "Exch",
- "AExch1", "AExch2", "AExch", "QR", "QRExp", "Exp", "QD", "Qsim"); }
- if(identical(FUN_MOD,RunModel_GR2M)){
- Outputs_all <- c(Outputs_all,"PotEvap", "Precip", "AE", "Pn", "Perc", "PR", "Exch", "Prod", "Rout", "Qsim"); }
- if(identical(FUN_MOD,RunModel_GR1A)){
- Outputs_all <- c(Outputs_all,"PotEvap","Precip","Qsim"); }
- if("CemaNeige" %in% ObjectClass){
- Outputs_all <- c(Outputs_all,"Pliq","Psol","SnowPack","ThermalState","Gratio","PotMelt","Melt","PliqAndMelt", "Temp"); }
-
- ##check_Outputs_Sim
- if(!is.vector( Outputs_Sim)){ stop("Outputs_Sim must be a vector of characters \n"); return(NULL); }
- if(!is.character(Outputs_Sim)){ stop("Outputs_Sim must be a vector of characters \n"); return(NULL); }
- if(sum(is.na(Outputs_Sim))!=0){ stop("Outputs_Sim must not contain NA \n"); return(NULL); }
- if("all" %in% Outputs_Sim){ Outputs_Sim <- c("DatesR",Outputs_all,"StateEnd"); }
- Test <- which(Outputs_Sim %in% c("DatesR",Outputs_all,"StateEnd") == FALSE); if(length(Test)!=0){
- stop(paste("Outputs_Sim is incorrectly defined: ",paste(Outputs_Sim[Test],collapse=", ")," not found \n",sep="")); return(NULL); }
- Outputs_Sim <- Outputs_Sim[!duplicated(Outputs_Sim)];
-
- ##check_Outputs_Cal
- if(is.null(Outputs_Cal)){
- if("GR" %in% ObjectClass ){ Outputs_Cal <- c("Qsim"); }
- if("CemaNeige" %in% ObjectClass ){ Outputs_Cal <- c("all"); }
- if("GR" %in% ObjectClass & "CemaNeige" %in% ObjectClass){ Outputs_Cal <- c("PliqAndMelt","Qsim"); }
+
+ ##Outputs_all
+ Outputs_all <- NULL
+ if (identical(FUN_MOD,RunModel_GR4H)) {
+ Outputs_all <- c(Outputs_all,"PotEvap","Precip","Prod","AE","Perc","PR","Q9","Q1","Rout","Exch","AExch","QR","QD","Qsim")
+ }
+ if (identical(FUN_MOD,RunModel_GR4J) | identical(FUN_MOD,RunModel_CemaNeigeGR4J)) {
+ Outputs_all <- c(Outputs_all,"PotEvap", "Precip", "Prod", "Pn", "Ps", "AE", "Perc", "PR", "Q9", "Q1", "Rout", "Exch",
+ "AExch1", "AExch2", "AExch", "QR", "QD", "Qsim")
+ }
+ if (identical(FUN_MOD,RunModel_GR5J) | identical(FUN_MOD,RunModel_CemaNeigeGR5J)) {
+ Outputs_all <- c(Outputs_all,"PotEvap", "Precip", "Prod", "Pn", "Ps", "AE", "Perc", "PR", "Q9", "Q1", "Rout", "Exch",
+ "AExch1", "AExch2", "AExch", "QR", "QD", "Qsim")
+ }
+ if (identical(FUN_MOD,RunModel_GR6J) | identical(FUN_MOD,RunModel_CemaNeigeGR6J)) {
+ Outputs_all <- c(Outputs_all,"PotEvap", "Precip", "Prod", "Pn", "Ps", "AE", "Perc", "PR", "Q9", "Q1", "Rout", "Exch",
+ "AExch1", "AExch2", "AExch", "QR", "QRExp", "Exp", "QD", "Qsim")
+ }
+ if (identical(FUN_MOD,RunModel_GR2M)) {
+ Outputs_all <- c(Outputs_all,"PotEvap", "Precip", "AE", "Pn", "Perc", "PR", "Exch", "Prod", "Rout", "Qsim")
+ }
+ if (identical(FUN_MOD,RunModel_GR1A)) {
+ Outputs_all <- c(Outputs_all,"PotEvap","Precip","Qsim")
+ }
+ if ("CemaNeige" %in% ObjectClass) {
+ Outputs_all <- c(Outputs_all,"Pliq","Psol","SnowPack","ThermalState","Gratio","PotMelt","Melt","PliqAndMelt", "Temp")
+ }
+
+ ##check_Outputs_Sim
+ if (!is.vector(Outputs_Sim)) {
+ stop("Outputs_Sim must be a vector of characters \n")
+ return(NULL)
+ }
+ if (!is.character(Outputs_Sim)) {
+ stop("Outputs_Sim must be a vector of characters \n")
+ return(NULL)
+ }
+ if (sum(is.na(Outputs_Sim)) != 0) {
+ stop("Outputs_Sim must not contain NA \n")
+ return(NULL)
+ }
+ if ("all" %in% Outputs_Sim) {
+ Outputs_Sim <- c("DatesR", Outputs_all, "StateEnd")
+ }
+ Test <- which(Outputs_Sim %in% c("DatesR", Outputs_all, "StateEnd") == FALSE)
+ if (length(Test) != 0) {
+ stop(paste0( "Outputs_Sim is incorrectly defined: ",
+ paste(Outputs_Sim[Test], collapse = ", "), " not found \n"))
+ return(NULL)
+
+ }
+ Outputs_Sim <- Outputs_Sim[!duplicated(Outputs_Sim)]
+
+
+ ##check_Outputs_Cal
+ if (is.null(Outputs_Cal)) {
+ if ("GR" %in% ObjectClass) {
+ Outputs_Cal <- c("Qsim")
+ }
+ if ("CemaNeige" %in% ObjectClass) {
+ Outputs_Cal <- c("all")
+ }
+ if ("GR" %in% ObjectClass &
+ "CemaNeige" %in% ObjectClass) {
+ Outputs_Cal <- c("PliqAndMelt", "Qsim")
+ }
+ } else {
+ if (!is.vector(Outputs_Cal)) {
+ stop("Outputs_Cal must be a vector of characters \n")
+ return(NULL)
+ }
+ if (!is.character(Outputs_Cal)) {
+ stop("Outputs_Cal must be a vector of characters \n")
+ return(NULL)
+ }
+ if (sum(is.na(Outputs_Cal)) != 0) {
+ stop("Outputs_Cal must not contain NA \n")
+ return(NULL)
+ }
+ }
+ if ("all" %in% Outputs_Cal) {
+ Outputs_Cal <- c("DatesR", Outputs_all, "StateEnd")
+
+ }
+ Test <-
+ which(Outputs_Cal %in% c("DatesR", Outputs_all, "StateEnd") == FALSE)
+ if (length(Test) != 0) {
+ stop(paste0("Outputs_Cal is incorrectly defined: ",
+ paste(Outputs_Cal[Test], collapse = ", "), " not found \n"))
+ return(NULL)
+
+ }
+ Outputs_Cal <- Outputs_Cal[!duplicated(Outputs_Cal)]
+
+
+
+ ##check_MeanAnSolidPrecip
+ if ("CemaNeige" %in% ObjectClass & is.null(MeanAnSolidPrecip)) {
+ NLayers <- length(InputsModel$LayerPrecip)
+ SolidPrecip <- NULL
+ for (iLayer in 1:NLayers) {
+ if (iLayer == 1) {
+ SolidPrecip <-
+ InputsModel$LayerFracSolidPrecip[[1]] * InputsModel$LayerPrecip[[iLayer]] /
+ NLayers
} else {
- if(!is.vector( Outputs_Cal)){ stop("Outputs_Cal must be a vector of characters \n"); return(NULL); }
- if(!is.character(Outputs_Cal)){ stop("Outputs_Cal must be a vector of characters \n"); return(NULL); }
- if(sum(is.na(Outputs_Cal))!=0){ stop("Outputs_Cal must not contain NA \n"); return(NULL); }
+ SolidPrecip <- SolidPrecip + InputsModel$LayerFracSolidPrecip[[iLayer]] * InputsModel$LayerPrecip[[iLayer]] / NLayers
}
- if("all" %in% Outputs_Cal){ Outputs_Cal <- c("DatesR",Outputs_all,"StateEnd"); }
- Test <- which(Outputs_Cal %in% c("DatesR",Outputs_all,"StateEnd") == FALSE); if(length(Test)!=0){
- stop(paste("Outputs_Cal is incorrectly defined: ",paste(Outputs_Cal[Test],collapse=", ")," not found \n",sep="")); return(NULL); }
- Outputs_Cal <- Outputs_Cal[!duplicated(Outputs_Cal)];
-
-
- ##check_MeanAnSolidPrecip
- if("CemaNeige" %in% ObjectClass & is.null(MeanAnSolidPrecip)){
- NLayers <- length(InputsModel$LayerPrecip);
- SolidPrecip <- NULL; for(iLayer in 1:NLayers){
- if(iLayer==1){ SolidPrecip <- InputsModel$LayerFracSolidPrecip[[1]]*InputsModel$LayerPrecip[[iLayer]]/NLayers;
- } else { SolidPrecip <- SolidPrecip + InputsModel$LayerFracSolidPrecip[[iLayer]]*InputsModel$LayerPrecip[[iLayer]]/NLayers; } }
- Factor <- NULL;
- if(inherits(InputsModel,"hourly" )){ Factor <- 365.25*24; }
- if(inherits(InputsModel,"daily" )){ Factor <- 365.25; }
- if(inherits(InputsModel,"monthly")){ Factor <- 12; }
- if(inherits(InputsModel,"yearly" )){ Factor <- 1; }
- if(is.null(Factor)){ stop("InputsModel must be of class 'hourly', 'daily', 'monthly' or 'yearly' \n"); return(NULL); }
- MeanAnSolidPrecip <- rep(mean(SolidPrecip)*Factor,NLayers); ### default value: same Gseuil for all layers
- if(verbose){ warning("\t MeanAnSolidPrecip not defined -> it was automatically set to c(",paste(round(MeanAnSolidPrecip),collapse=","),") \n"); }
- }
- if("CemaNeige" %in% ObjectClass & !is.null(MeanAnSolidPrecip)){
- if(!is.vector( MeanAnSolidPrecip) ){ stop(paste("MeanAnSolidPrecip must be a vector of numeric values \n",sep="")); return(NULL); }
- if(!is.numeric(MeanAnSolidPrecip) ){ stop(paste("MeanAnSolidPrecip must be a vector of numeric values \n",sep="")); return(NULL); }
- if(length(MeanAnSolidPrecip)!=NLayers){ stop(paste("MeanAnSolidPrecip must be a numeric vector of length ",NLayers," \n",sep="")); return(NULL); }
}
-
-
+ Factor <- NULL
+ if (inherits(InputsModel, "hourly")) {
+ Factor <- 365.25 * 24
+ }
+ if (inherits(InputsModel, "daily")) {
+ Factor <- 365.25
+ }
+ if (inherits(InputsModel, "monthly")) {
+ Factor <- 12
+ }
+ if (inherits(InputsModel, "yearly")) {
+ Factor <- 1
+ }
+ if (is.null(Factor)) {
+ stop("InputsModel must be of class 'hourly', 'daily', 'monthly' or 'yearly' \n")
+ return(NULL)
+ }
+ MeanAnSolidPrecip <- rep(mean(SolidPrecip) * Factor, NLayers)
+ ### default value: same Gseuil for all layers
+ if (verbose) {
+ warning("\t MeanAnSolidPrecip not defined -> it was automatically set to c(",
+ paste(round(MeanAnSolidPrecip), collapse = ","), ") \n")
+ }
+ }
+ if ("CemaNeige" %in% ObjectClass & !is.null(MeanAnSolidPrecip)) {
+ if (!is.vector(MeanAnSolidPrecip)) {
+ stop(paste0("MeanAnSolidPrecip must be a vector of numeric values \n"))
+ return(NULL)
+ }
+ if (!is.numeric(MeanAnSolidPrecip)) {
+ stop(paste0("MeanAnSolidPrecip must be a vector of numeric values \n"))
+ return(NULL)
+ }
+ if (length(MeanAnSolidPrecip) != NLayers) {
+ stop(paste0("MeanAnSolidPrecip must be a numeric vector of length ", NLayers, " \n"))
+ return(NULL)
+ }
+ }
+
+
##check_PliqAndMelt
- if("GR" %in% ObjectClass & "CemaNeige" %in% ObjectClass){
- if("PliqAndMelt" %in% Outputs_Cal == FALSE & "all" %in% Outputs_Cal == FALSE){
- WTxt <- NULL;
- WTxt <- paste(WTxt,"\t PliqAndMelt was not defined in Outputs_Cal but is needed to feed the hydrological model with the snow modele outputs \n",sep="");
- WTxt <- paste(WTxt,"\t -> it was automatically added \n",sep="");
- if(!is.null(WTxt) & verbose){ warning(WTxt); }
- Outputs_Cal <- c(Outputs_Cal,"PliqAndMelt"); }
- if("PliqAndMelt" %in% Outputs_Sim == FALSE & "all" %in% Outputs_Sim == FALSE){
- WTxt <- NULL;
- WTxt <- paste(WTxt,"\t PliqAndMelt was not defined in Outputs_Sim but is needed to feed the hydrological model with the snow modele outputs \n",sep="");
- WTxt <- paste(WTxt,"\t -> it was automatically added \n",sep="");
- if(!is.null(WTxt) & verbose){ warning(WTxt); }
- Outputs_Sim <- c(Outputs_Sim,"PliqAndMelt"); }
+ if ("GR" %in% ObjectClass & "CemaNeige" %in% ObjectClass) {
+ if ("PliqAndMelt" %in% Outputs_Cal == FALSE & "all" %in% Outputs_Cal == FALSE) {
+ WTxt <- NULL
+ WTxt <- paste0(WTxt, "\t PliqAndMelt was not defined in Outputs_Cal but is needed to feed the hydrological model with the snow modele outputs \n")
+ WTxt <- paste0(WTxt, "\t -> it was automatically added \n")
+ if (!is.null(WTxt) & verbose) {
+ warning(WTxt)
+ }
+ Outputs_Cal <- c(Outputs_Cal, "PliqAndMelt")
}
-
-
+ if ("PliqAndMelt" %in% Outputs_Sim == FALSE & "all" %in% Outputs_Sim == FALSE) {
+ WTxt <- NULL
+ WTxt <- paste0(WTxt, "\t PliqAndMelt was not defined in Outputs_Sim but is needed to feed the hydrological model with the snow modele outputs \n")
+ WTxt <- paste0(WTxt, "\t -> it was automatically added \n")
+ if (!is.null(WTxt) & verbose) {
+ warning(WTxt)
+ }
+ Outputs_Sim <- c(Outputs_Sim, "PliqAndMelt")
+ }
+ }
+
+
##Create_RunOptions
- RunOptions <- list(IndPeriod_WarmUp=IndPeriod_WarmUp,IndPeriod_Run=IndPeriod_Run,IniStates=IniStates,IniResLevels=IniResLevels,
- Outputs_Cal=Outputs_Cal,Outputs_Sim=Outputs_Sim);
- if("CemaNeige" %in% ObjectClass){
- RunOptions <- c(RunOptions,list(MeanAnSolidPrecip=MeanAnSolidPrecip)); }
- class(RunOptions) <- c("RunOptions",ObjectClass);
- return(RunOptions);
-
-
+ RunOptions <- list(IndPeriod_WarmUp = IndPeriod_WarmUp,
+ IndPeriod_Run = IndPeriod_Run,
+ IniStates = IniStates,
+ IniResLevels = IniResLevels,
+ Outputs_Cal = Outputs_Cal,
+ Outputs_Sim = Outputs_Sim)
+
+ if ("CemaNeige" %in% ObjectClass) {
+ RunOptions <-
+ c(RunOptions, list(MeanAnSolidPrecip = MeanAnSolidPrecip))
+ }
+ class(RunOptions) <- c("RunOptions", ObjectClass)
+
+ return(RunOptions)
+
+
}
--
GitLab