From 0ada9d716bfee17bb6edeb80df8791b7fb6c07d2 Mon Sep 17 00:00:00 2001 From: Dorchies David <david.dorchies@inrae.fr> Date: Wed, 16 Jun 2021 16:07:09 +0200 Subject: [PATCH] feat: use .GetOutputsModel for all RunModel functions + bug correction on DatesR item of .GetOutputsModel Refs #129 --- R/RunModel_CemaNeigeGR4H.R | 58 ++++-------------- R/RunModel_CemaNeigeGR4J.R | 118 ++++++++++++++----------------------- R/RunModel_CemaNeigeGR5H.R | 97 ++++++++++-------------------- R/RunModel_CemaNeigeGR5J.R | 106 ++++++++++++--------------------- R/RunModel_CemaNeigeGR6J.R | 60 +++++-------------- R/RunModel_GR1A.R | 40 +++---------- R/RunModel_GR2M.R | 40 +++---------- R/RunModel_GR4H.R | 41 +++---------- R/RunModel_GR4J.R | 16 ++--- R/RunModel_GR5H.R | 44 +++----------- R/RunModel_GR5J.R | 83 +++++++++----------------- R/RunModel_GR6J.R | 83 +++++++++----------------- R/UtilsRunModel.R | 4 +- 13 files changed, 230 insertions(+), 560 deletions(-) diff --git a/R/RunModel_CemaNeigeGR4H.R b/R/RunModel_CemaNeigeGR4H.R index bda65ddb..377c9cce 100644 --- a/R/RunModel_CemaNeigeGR4H.R +++ b/R/RunModel_CemaNeigeGR4H.R @@ -6,7 +6,6 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) { NParam <- ifelse(test = IsHyst, yes = 8L, no = 6L) NParamCN <- NParam - 4L NStates <- 4L - FortranOutputs <- .FortranOutputs(GR = "GR4H", isCN = TRUE) ## Arguments check @@ -76,9 +75,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 +115,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 +141,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 +185,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] + RESULTS$Outputs[, which(RunOptions$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") - } - return(OutputsModel) - + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries, + CemaNeigeLayers) } diff --git a/R/RunModel_CemaNeigeGR4J.R b/R/RunModel_CemaNeigeGR4J.R index 6ff79a43..69a38667 100644 --- a/R/RunModel_CemaNeigeGR4J.R +++ b/R/RunModel_CemaNeigeGR4J.R @@ -1,14 +1,13 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) { - - + + ## Initialization of variables IsHyst <- inherits(RunOptions, "hysteresis") NParam <- ifelse(test = IsHyst, yes = 8L, no = 6L) NParamCN <- NParam - 4L NStates <- 4L - FortranOutputs <- .FortranOutputs(GR = "GR4J", isCN = TRUE) - - + + ## Arguments check if (!inherits(InputsModel, "InputsModel")) { stop("'InputsModel' must be of class 'InputsModel'") @@ -38,7 +37,7 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) { stop(paste("'Param' must be a vector of length", NParam, "and contain no NA")) } Param <- as.double(Param) - + Param_X1X3_threshold <- 1e-2 Param_X4_threshold <- 0.5 @@ -53,8 +52,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,20 +70,20 @@ 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) { if (!IsHyst) { @@ -92,7 +91,7 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) { } else { StateStartCemaNeige <- RunOptions$IniStates[(7 + 20 + 40) + c(iLayer, iLayer+NLayers, iLayer+2*NLayers, iLayer+3*NLayers)] } - RESULTS <- .Fortran("frun_cemaneige", PACKAGE = "airGR", + RESULTS <- .Fortran("frun_cemaneige", PACKAGE = "airGR", ## inputs LInputs = LInputSeries, ### length of input and output series InputsPrecip = InputsModel$LayerPrecip[[iLayer]][IndPeriod1], ### input series of total precipitation [mm/d] @@ -106,16 +105,16 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) { IsHyst = as.integer(IsHyst), ### use of hysteresis NOutputs = as.integer(length(IndOutputsCemaNeige)), ### number of output series IndOutputs = IndOutputsCemaNeige, ### indices of output series - ## outputs + ## outputs Outputs = matrix(as.double(-99e9), nrow = LInputSeries, ncol = length(IndOutputsCemaNeige)), ### output series [mm, mm/d or degC] StateEnd = rep(as.double(-99e9), as.integer(NStates)) ### state variables at the end of the model run ) RESULTS$Outputs[RESULTS$Outputs <= -99e8] <- NA RESULTS$StateEnd[RESULTS$StateEnd <= -99e8] <- NA - + ## 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 @@ -136,24 +135,24 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) { NameCemaNeigeLayers <- NULL CatchMeltAndPliq <- InputsModel$Precip[IndPeriod1] } - - - + + + ## 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 if (!is.null(RunOptions$IniResLevels)) { RunOptions$IniStates[1] <- RunOptions$IniResLevels[1] * ParamMod[1] ### production store level (mm) RunOptions$IniStates[2] <- RunOptions$IniResLevels[2] * ParamMod[3] ### routing store level (mm) } - + ## Call GR model Fortan - RESULTS <- .Fortran("frun_gr4j", PACKAGE = "airGR", + RESULTS <- .Fortran("frun_gr4j", PACKAGE = "airGR", ## inputs LInputs = LInputSeries, ### length of input and output series InputsPrecip = CatchMeltAndPliq, ### input series of total precipitation [mm/d] @@ -164,7 +163,7 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) { StateStart = RunOptions$IniStates[1:NStatesMod], ### state variables used when the model run starts NOutputs = as.integer(length(IndOutputsMod)), ### number of output series IndOutputs = IndOutputsMod, ### indices of output series - ## outputs + ## outputs Outputs = matrix(as.double(-99e9), nrow = LInputSeries, ncol = length(IndOutputsMod)), ### output series [mm or mm/d] StateEnd = rep(as.double(-99e9), NStatesMod) ### state variables at the end of the model run ) @@ -173,57 +172,26 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) { if (ExportStateEnd) { RESULTS$StateEnd[-3L] <- ifelse(RESULTS$StateEnd[-3L] < 0, 0, RESULTS$StateEnd[-3L]) ### remove negative values except for the ExpStore location idNStates <- seq_len(NStates*NLayers) %% NStates - RESULTS$StateEnd <- CreateIniStates(FUN_MOD = RunModel_CemaNeigeGR4J, InputsModel = InputsModel, IsHyst = IsHyst, - ProdStore = RESULTS$StateEnd[1L], RoutStore = RESULTS$StateEnd[2L], ExpStore = NULL, + RESULTS$StateEnd <- CreateIniStates(FUN_MOD = RunModel_CemaNeigeGR4J, InputsModel = InputsModel, IsHyst = IsHyst, + ProdStore = RESULTS$StateEnd[1L], RoutStore = RESULTS$StateEnd[2L], ExpStore = NULL, UH1 = RESULTS$StateEnd[(1:20) + 7], - UH2 = RESULTS$StateEnd[(1:40) + (7+20)], - GCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 1]], - eTGCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 2]], - GthrCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 3]], - GlocmaxCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 0]], + UH2 = RESULTS$StateEnd[(1:40) + (7+20)], + GCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 1]], + eTGCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 2]], + GthrCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 3]], + GlocmaxCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 0]], verbose = FALSE) } - + if (inherits(RunOptions, "CemaNeige") & "Precip" %in% RunOptions$Outputs_Sim) { - RESULTS$Outputs[, which(FortranOutputs$GR[IndOutputsMod] == "Precip")] <- InputsModel$Precip[IndPeriod1] + RESULTS$Outputs[, which(RunOptions$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", "daily", "GR", "CemaNeige") - if (IsHyst) { - class(OutputsModel) <- c(class(OutputsModel), "hysteresis") - } - return(OutputsModel) - + + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries, + CemaNeigeLayers) } diff --git a/R/RunModel_CemaNeigeGR5H.R b/R/RunModel_CemaNeigeGR5H.R index 0a4995fb..8499e2ba 100644 --- a/R/RunModel_CemaNeigeGR5H.R +++ b/R/RunModel_CemaNeigeGR5H.R @@ -1,20 +1,19 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) { - - + + ## Initialization of variables IsHyst <- inherits(RunOptions, "hysteresis") NParam <- ifelse(test = IsHyst, yes = 9L, no = 7L) NParamCN <- NParam - 5L NStates <- 4L - FortranOutputs <- .FortranOutputs(GR = "GR5H", isCN = TRUE) IsIntStore <- inherits(RunOptions, "interception") if (IsIntStore) { Imax <- RunOptions$Imax } else { Imax <- -99 } - - + + ## Arguments check if (!inherits(InputsModel, "InputsModel")) { stop("'InputsModel' must be of class 'InputsModel'") @@ -44,8 +43,8 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) { stop(paste("'Param' must be a vector of length", NParam, "and contain no NA")) } Param <- as.double(Param) - - + + Param_X1X3_threshold <- 1e-2 Param_X4_threshold <- 0.5 if (Param[1L] < Param_X1X3_threshold) { @@ -59,8 +58,8 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) { if (Param[4L] < Param_X4_threshold) { warning(sprintf("Param[4] (X4: unit hydrograph time constant [h]) < %.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 @@ -73,24 +72,24 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) { ParamMod <- Param[1:NParamMod] NLayers <- length(InputsModel$LayerPrecip) NStatesMod <- as.integer(length(RunOptions$IniStates) - NStates * NLayers) - + ## 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) { @@ -113,16 +112,16 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) { IsHyst = as.integer(IsHyst), ### use of hysteresis NOutputs = as.integer(length(IndOutputsCemaNeige)), ### number of output series IndOutputs = IndOutputsCemaNeige, ### indices of output series - ## outputs + ## outputs Outputs = matrix(as.double(-99e9), nrow = LInputSeries, ncol = length(IndOutputsCemaNeige)), ### output series [mm, mm/h or degC] StateEnd = rep(as.double(-99e9), as.integer(NStates)) ### state variables at the end of the model run ) RESULTS$Outputs[RESULTS$Outputs <= -99e8] <- NA RESULTS$StateEnd[RESULTS$StateEnd <= -99e8] <- NA - + ## 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 @@ -148,9 +147,9 @@ RunModel_CemaNeigeGR5H <- 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 @@ -191,54 +190,20 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) { UH2 = RESULTS$StateEnd[(1:(40*24)) + (7+20*24)], GCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 1]], eTGCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 2]], - GthrCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 3]], + GthrCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 3]], GlocmaxCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 0]], verbose = FALSE) } - + if (inherits(RunOptions, "CemaNeige") & "Precip" %in% RunOptions$Outputs_Sim) { - RESULTS$Outputs[, which(FortranOutputs$GR[IndOutputsMod] == "Precip")] <- InputsModel$Precip[IndPeriod1] + RESULTS$Outputs[, which(RunOptions$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") - } - if (IsIntStore) { - class(OutputsModel) <- c(class(OutputsModel), "interception") - } - return(OutputsModel) - + + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries, + CemaNeigeLayers) } diff --git a/R/RunModel_CemaNeigeGR5J.R b/R/RunModel_CemaNeigeGR5J.R index a8dabc3c..9999d143 100644 --- a/R/RunModel_CemaNeigeGR5J.R +++ b/R/RunModel_CemaNeigeGR5J.R @@ -1,14 +1,13 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) { - - + + ## Initialization of variables IsHyst <- inherits(RunOptions, "hysteresis") NParam <- ifelse(test = IsHyst, yes = 9L, no = 7L) NParamCN <- NParam - 5L NStates <- 4L - FortranOutputs <- .FortranOutputs(GR = "GR5J", isCN = TRUE) - - + + ## Arguments check if (!inherits(InputsModel, "InputsModel")) { stop("'InputsModel' must be of class 'InputsModel'") @@ -38,8 +37,8 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) { stop(paste("'Param' must be a vector of length", NParam, "and contain no NA")) } Param <- as.double(Param) - - + + Param_X1X3_threshold <- 1e-2 Param_X4_threshold <- 0.5 if (Param[1L] < Param_X1X3_threshold) { @@ -53,8 +52,8 @@ RunModel_CemaNeigeGR5J <- 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 @@ -69,20 +68,20 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) { NStatesMod <- as.integer(length(RunOptions$IniStates) - NStates * NLayers) 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) { if (!IsHyst) { @@ -104,16 +103,16 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) { IsHyst = as.integer(IsHyst), ### use of hysteresis NOutputs = as.integer(length(IndOutputsCemaNeige)), ### number of output series IndOutputs = IndOutputsCemaNeige, ### indices of output series - ## outputs + ## outputs Outputs = matrix(as.double(-99e9), nrow = LInputSeries, ncol = length(IndOutputsCemaNeige)), ### output series [mm, mm/d or degC] StateEnd = rep(as.double(-99e9), as.integer(NStates)) ### state variables at the end of the model run ) RESULTS$Outputs[RESULTS$Outputs <= -99e8] <- NA RESULTS$StateEnd[RESULTS$StateEnd <= -99e8] <- NA - + ## 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 @@ -134,22 +133,22 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) { NameCemaNeigeLayers <- NULL CatchMeltAndPliq <- InputsModel$Precip[IndPeriod1] } - - - + + + ## 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 if (!is.null(RunOptions$IniResLevels)) { RunOptions$IniStates[1] <- RunOptions$IniResLevels[1] * ParamMod[1] ### production store level (mm) RunOptions$IniStates[2] <- RunOptions$IniResLevels[2] * ParamMod[3] ### routing store level (mm) } - + ## Call GR model Fortan RESULTS <- .Fortran("frun_gr5j", PACKAGE = "airGR", ## inputs @@ -162,7 +161,7 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) { StateStart = RunOptions$IniStates[1:NStatesMod], ### state variables used when the model run starts NOutputs = as.integer(length(IndOutputsMod)), ### number of output series IndOutputs = IndOutputsMod, ### indices of output series - ## outputs + ## outputs Outputs = matrix(as.double(-99e9), nrow = LInputSeries, ncol = length(IndOutputsMod)), ### output series [mm or mm/d] StateEnd = rep(as.double(-99e9), NStatesMod) ### state variables at the end of the model run ) @@ -177,51 +176,20 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) { UH2 = RESULTS$StateEnd[(1:40) + (7+20)], GCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 1]], eTGCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 2]], - GthrCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 3]], + GthrCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 3]], GlocmaxCemaNeigeLayers = CemaNeigeStateEnd[seq_len(NStates*NLayers)[idNStates == 0]], verbose = FALSE) } - + 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", "daily", "GR", "CemaNeige") - if (IsHyst) { - class(OutputsModel) <- c(class(OutputsModel), "hysteresis") - } - return(OutputsModel) - + RESULTS$Outputs[, which(RunOptions$FortranOutputs$GR[IndOutputsMod] == "Precip")] <- + InputsModel$Precip[IndPeriod1] + } + + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries, + CemaNeigeLayers) } diff --git a/R/RunModel_CemaNeigeGR6J.R b/R/RunModel_CemaNeigeGR6J.R index 48859cb0..c6cda9fc 100644 --- a/R/RunModel_CemaNeigeGR6J.R +++ b/R/RunModel_CemaNeigeGR6J.R @@ -6,7 +6,6 @@ RunModel_CemaNeigeGR6J <- function(InputsModel, RunOptions, Param) { NParam <- ifelse(test = IsHyst, yes = 10L, no = 8L) NParamCN <- NParam - 6L NStates <- 4L - FortranOutputs <- .FortranOutputs(GR = "GR6J", isCN = TRUE) ## Arguments check @@ -78,9 +77,9 @@ RunModel_CemaNeigeGR6J <- 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 @@ -117,7 +116,7 @@ RunModel_CemaNeigeGR6J <- 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 @@ -143,9 +142,9 @@ RunModel_CemaNeigeGR6J <- 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 @@ -188,46 +187,15 @@ RunModel_CemaNeigeGR6J <- 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", "daily", "GR", "CemaNeige") - if (IsHyst) { - class(OutputsModel) <- c(class(OutputsModel), "hysteresis") - } - return(OutputsModel) + RESULTS$Outputs[, which(RunOptions$FortranOutputs$GR[IndOutputsMod] == "Precip")] <- + InputsModel$Precip[IndPeriod1] + } + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries, + CemaNeigeLayers) } diff --git a/R/RunModel_GR1A.R b/R/RunModel_GR1A.R index 620965f0..64f1eb80 100644 --- a/R/RunModel_GR1A.R +++ b/R/RunModel_GR1A.R @@ -3,7 +3,6 @@ RunModel_GR1A <- function(InputsModel, RunOptions, Param) { ## Initialization of variables NParam <- 1 - FortranOutputs <- .FortranOutputs(GR = "GR1A")$GR ## Arguments check @@ -38,9 +37,9 @@ RunModel_GR1A <- function(InputsModel, RunOptions, Param) { IndPeriod1 <- c(RunOptions$IndPeriod_WarmUp, RunOptions$IndPeriod_Run) LInputSeries <- as.integer(length(IndPeriod1)) if ("all" %in% RunOptions$Outputs_Sim) { - IndOutputs <- as.integer(1:length(FortranOutputs)) + IndOutputs <- as.integer(1:length(RunOptions$FortranOutputs$GR)) } else { - IndOutputs <- which(FortranOutputs %in% RunOptions$Outputs_Sim) + IndOutputs <- which(RunOptions$FortranOutputs$GR %in% RunOptions$Outputs_Sim) } @@ -69,34 +68,9 @@ RunModel_GR1A <- function(InputsModel, RunOptions, Param) { RESULTS$Outputs[RESULTS$Outputs <= -99e8] <- NA RESULTS$StateEnd[RESULTS$StateEnd <= -99e8] <- NA - ## Output data preparation - ## OutputsModel only - if (!ExportDatesR & !ExportStateEnd) { - OutputsModel <- lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]) - names(OutputsModel) <- FortranOutputs[IndOutputs] - } - ## 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])) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs]) - } - ## OutputsModel and StateEnd only - if (!ExportDatesR & ExportStateEnd) { - OutputsModel <- c(lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c(FortranOutputs[IndOutputs], "StateEnd") - } - ## DatesR and OutputsModel and StateEnd - if ((ExportDatesR & ExportStateEnd) | "all" %in% RunOptions$Outputs_Sim) { - OutputsModel <- c(list(InputsModel$DatesR[RunOptions$IndPeriod_Run]), - lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs], "StateEnd") - } - - ## End - class(OutputsModel) <- c("OutputsModel", "yearly", "GR") - return(OutputsModel) - + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries) } diff --git a/R/RunModel_GR2M.R b/R/RunModel_GR2M.R index e0261695..3d06d300 100644 --- a/R/RunModel_GR2M.R +++ b/R/RunModel_GR2M.R @@ -3,7 +3,6 @@ RunModel_GR2M <- function(InputsModel, RunOptions, Param) { ## Initialization of variables NParam <- 2 - FortranOutputs <- .FortranOutputs(GR = "GR2M")$GR ## Arguments check @@ -47,9 +46,9 @@ RunModel_GR2M <- function(InputsModel, RunOptions, Param) { IndPeriod1 <- c(RunOptions$IndPeriod_WarmUp, RunOptions$IndPeriod_Run) LInputSeries <- as.integer(length(IndPeriod1)) if ("all" %in% RunOptions$Outputs_Sim) { - IndOutputs <- as.integer(1:length(FortranOutputs)) + IndOutputs <- as.integer(1:length(RunOptions$FortranOutputs$GR)) } else { - IndOutputs <- which(FortranOutputs %in% RunOptions$Outputs_Sim) + IndOutputs <- which(RunOptions$FortranOutputs$GR %in% RunOptions$Outputs_Sim) } ## Output data preparation @@ -91,34 +90,9 @@ RunModel_GR2M <- function(InputsModel, RunOptions, Param) { } ## Output data preparation - ## OutputsModel only - if (!ExportDatesR & !ExportStateEnd) { - OutputsModel <- lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]) - names(OutputsModel) <- FortranOutputs[IndOutputs] - } - ## 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])) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs]) - } - ## OutputsModel and StateEnd only - if (!ExportDatesR & ExportStateEnd) { - OutputsModel <- c(lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c(FortranOutputs[IndOutputs], "StateEnd") - } - ## DatesR and OutputsModel and StateEnd - if ((ExportDatesR & ExportStateEnd) | "all" %in% RunOptions$Outputs_Sim) { - OutputsModel <- c(list(InputsModel$DatesR[RunOptions$IndPeriod_Run]), - lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs], "StateEnd") - } - - ## End - rm(RESULTS) - class(OutputsModel) <- c("OutputsModel", "monthly", "GR") - return(OutputsModel) - + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries) } diff --git a/R/RunModel_GR4H.R b/R/RunModel_GR4H.R index 69beb4b0..70cf93f3 100644 --- a/R/RunModel_GR4H.R +++ b/R/RunModel_GR4H.R @@ -3,7 +3,6 @@ RunModel_GR4H <- function(InputsModel, RunOptions, Param) { ## Initialization of variables NParam <- 4 - FortranOutputs <- .FortranOutputs(GR = "GR4H")$GR ## Arguments check @@ -52,9 +51,9 @@ RunModel_GR4H <- function(InputsModel, RunOptions, Param) { IndPeriod1 <- c(RunOptions$IndPeriod_WarmUp, RunOptions$IndPeriod_Run) LInputSeries <- as.integer(length(IndPeriod1)) if ("all" %in% RunOptions$Outputs_Sim) { - IndOutputs <- as.integer(1:length(FortranOutputs)) + IndOutputs <- as.integer(1:length(RunOptions$FortranOutputs$GR)) } else { - IndOutputs <- which(FortranOutputs %in% RunOptions$Outputs_Sim) + IndOutputs <- which(RunOptions$FortranOutputs$GR %in% RunOptions$Outputs_Sim) } ## Output data preparation @@ -96,35 +95,9 @@ RunModel_GR4H <- function(InputsModel, RunOptions, Param) { verbose = FALSE) } - ## Output data preparation - ## OutputsModel only - if (!ExportDatesR & !ExportStateEnd) { - OutputsModel <- lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]) - names(OutputsModel) <- FortranOutputs[IndOutputs] - } - ## 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])) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs]) - } - ## OutputsModel and StateEnd only - if (!ExportDatesR & ExportStateEnd) { - OutputsModel <- c(lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c(FortranOutputs[IndOutputs], "StateEnd") - } - ## DatesR and OutputsModel and StateEnd - if ((ExportDatesR & ExportStateEnd) | "all" %in% RunOptions$Outputs_Sim) { - OutputsModel <- c(list(InputsModel$DatesR[RunOptions$IndPeriod_Run]), - lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs], "StateEnd") - } - - ## End - rm(RESULTS) - class(OutputsModel) <- c("OutputsModel", "hourly", "GR") - return(OutputsModel) - + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries) } diff --git a/R/RunModel_GR4J.R b/R/RunModel_GR4J.R index c3b3dbd8..23a0e1b8 100644 --- a/R/RunModel_GR4J.R +++ b/R/RunModel_GR4J.R @@ -89,15 +89,9 @@ RunModel_GR4J <- function(InputsModel, RunOptions, Param) { verbose = FALSE) } - ## Output data preparation - OutputsModel <- .GetOutputsModel(InputsModel, - RunOptions, - RESULTS, - LInputSeries) - - ## End - rm(RESULTS) - class(OutputsModel) <- c("OutputsModel", "daily", "GR") - return(OutputsModel) - + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries) } diff --git a/R/RunModel_GR5H.R b/R/RunModel_GR5H.R index 58ea098a..e743caa3 100644 --- a/R/RunModel_GR5H.R +++ b/R/RunModel_GR5H.R @@ -3,7 +3,6 @@ RunModel_GR5H <- function(InputsModel, RunOptions, Param) { ## Initialization of variables NParam <- 5 - FortranOutputs <- .FortranOutputs(GR = "GR5H")$GR IsIntStore <- inherits(RunOptions, "interception") if (IsIntStore) { Imax <- RunOptions$Imax @@ -58,9 +57,9 @@ RunModel_GR5H <- function(InputsModel, RunOptions, Param) { IndPeriod1 <- c(RunOptions$IndPeriod_WarmUp, RunOptions$IndPeriod_Run) LInputSeries <- as.integer(length(IndPeriod1)) if ("all" %in% RunOptions$Outputs_Sim) { - IndOutputs <- as.integer(1:length(FortranOutputs)) + IndOutputs <- as.integer(1:length(RunOptions$FortranOutputs$GR)) } else { - IndOutputs <- which(FortranOutputs %in% RunOptions$Outputs_Sim) + IndOutputs <- which(RunOptions$FortranOutputs$GR %in% RunOptions$Outputs_Sim) } ## Output data preparation @@ -107,38 +106,9 @@ RunModel_GR5H <- function(InputsModel, RunOptions, Param) { verbose = FALSE) } - ## Output data preparation - ## OutputsModel only - if (!ExportDatesR & !ExportStateEnd) { - OutputsModel <- lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]) - names(OutputsModel) <- FortranOutputs[IndOutputs] - } - ## 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])) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs]) - } - ## OutputsModel and StateEnd only - if (!ExportDatesR & ExportStateEnd) { - OutputsModel <- c(lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c(FortranOutputs[IndOutputs], "StateEnd") - } - ## DatesR and OutputsModel and StateEnd - if ((ExportDatesR & ExportStateEnd) | "all" %in% RunOptions$Outputs_Sim) { - OutputsModel <- c(list(InputsModel$DatesR[RunOptions$IndPeriod_Run]), - lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs], "StateEnd") - } - - ## End - rm(RESULTS) - class(OutputsModel) <- c("OutputsModel", "hourly", "GR") - if (IsIntStore) { - class(OutputsModel) <- c(class(OutputsModel), "interception") - } - return(OutputsModel) - + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries) } diff --git a/R/RunModel_GR5J.R b/R/RunModel_GR5J.R index fa5f83ac..e809a58e 100644 --- a/R/RunModel_GR5J.R +++ b/R/RunModel_GR5J.R @@ -1,27 +1,26 @@ RunModel_GR5J <- function(InputsModel, RunOptions, Param) { - - + + ## Initialization of variables NParam <- 5 - FortranOutputs <- .FortranOutputs(GR = "GR5J")$GR - - + + ## 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(RunOptions, "RunOptions")) { stop("'RunOptions' must be of class 'RunOptions'") - } + } if (!inherits(RunOptions, "GR")) { stop("'RunOptions' must be of class 'GR'") - } + } if (!is.vector(Param) | !is.numeric(Param)) { stop("'Param' must be a numeric vector") } @@ -29,7 +28,7 @@ RunModel_GR5J <- function(InputsModel, RunOptions, Param) { stop(paste("'Param' must be a vector of length", NParam, "and contain no NA")) } Param <- as.double(Param) - + Param_X1X3_threshold <- 1e-2 Param_X4_threshold <- 0.5 if (Param[1L] < Param_X1X3_threshold) { @@ -43,8 +42,8 @@ RunModel_GR5J <- 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 @@ -52,24 +51,24 @@ RunModel_GR5J <- function(InputsModel, RunOptions, Param) { IndPeriod1 <- c(RunOptions$IndPeriod_WarmUp, RunOptions$IndPeriod_Run) LInputSeries <- as.integer(length(IndPeriod1)) if ("all" %in% RunOptions$Outputs_Sim) { - IndOutputs <- as.integer(1:length(FortranOutputs)) + IndOutputs <- as.integer(1:length(RunOptions$FortranOutputs$GR)) } else { - IndOutputs <- which(FortranOutputs %in% RunOptions$Outputs_Sim) + IndOutputs <- which(RunOptions$FortranOutputs$GR %in% RunOptions$Outputs_Sim) } - + ## Output data preparation IndPeriod2 <- (length(RunOptions$IndPeriod_WarmUp)+1):LInputSeries ExportDatesR <- "DatesR" %in% RunOptions$Outputs_Sim ExportStateEnd <- "StateEnd" %in% RunOptions$Outputs_Sim - + ## Use of IniResLevels if (!is.null(RunOptions$IniResLevels)) { RunOptions$IniStates[1] <- RunOptions$IniResLevels[1] * Param[1] ### production store level (mm) RunOptions$IniStates[2] <- RunOptions$IniResLevels[2] * Param[3] ### routing store level (mm) } - + ## Call GR model Fortan - RESULTS <- .Fortran("frun_gr5j", PACKAGE = "airGR", + RESULTS <- .Fortran("frun_gr5j", PACKAGE = "airGR", ## inputs LInputs = LInputSeries, ### length of input and output series InputsPrecip = InputsModel$Precip[IndPeriod1], ### input series of total precipitation [mm/d] @@ -88,43 +87,17 @@ RunModel_GR5J <- function(InputsModel, RunOptions, Param) { RESULTS$StateEnd[RESULTS$StateEnd <= -99e8] <- NA if (ExportStateEnd) { RESULTS$StateEnd[-3L] <- ifelse(RESULTS$StateEnd[-3L] < 0, 0, RESULTS$StateEnd[-3L]) ### remove negative values except for the ExpStore location - RESULTS$StateEnd <- CreateIniStates(FUN_MOD = RunModel_GR5J, InputsModel = InputsModel, - ProdStore = RESULTS$StateEnd[1L], RoutStore = RESULTS$StateEnd[2L], ExpStore = NULL, + RESULTS$StateEnd <- CreateIniStates(FUN_MOD = RunModel_GR5J, InputsModel = InputsModel, + ProdStore = RESULTS$StateEnd[1L], RoutStore = RESULTS$StateEnd[2L], ExpStore = NULL, UH1 = NULL, - UH2 = RESULTS$StateEnd[(1:40) + (7+20)], - GCemaNeigeLayers = NULL, eTGCemaNeigeLayers = NULL, + UH2 = RESULTS$StateEnd[(1:40) + (7+20)], + GCemaNeigeLayers = NULL, eTGCemaNeigeLayers = NULL, verbose = FALSE) } - - ## Output data preparation - ## OutputsModel only - if (!ExportDatesR & !ExportStateEnd) { - OutputsModel <- lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]) - names(OutputsModel) <- FortranOutputs[IndOutputs] - } - ## 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])) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs]) - } - ## OutputsModel and StateEnd only - if (!ExportDatesR & ExportStateEnd) { - OutputsModel <- c(lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c(FortranOutputs[IndOutputs], "StateEnd") - } - ## DatesR and OutputsModel and StateEnd - if ((ExportDatesR & ExportStateEnd) | "all" %in% RunOptions$Outputs_Sim) { - OutputsModel <- c(list(InputsModel$DatesR[RunOptions$IndPeriod_Run]), - lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs], "StateEnd") - } - - ## End - rm(RESULTS) - class(OutputsModel) <- c("OutputsModel", "daily", "GR") - return(OutputsModel) - + + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries) } diff --git a/R/RunModel_GR6J.R b/R/RunModel_GR6J.R index 572511f7..6eee6810 100644 --- a/R/RunModel_GR6J.R +++ b/R/RunModel_GR6J.R @@ -1,27 +1,26 @@ RunModel_GR6J <- function(InputsModel, RunOptions, Param) { - - + + ## Initialization of variables NParam <- 6 - FortranOutputs <- .FortranOutputs(GR = "GR6J")$GR - - + + ## 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(RunOptions, "RunOptions")) { stop("'RunOptions' must be of class 'RunOptions'") - } + } if (!inherits(RunOptions, "GR")) { stop("'RunOptions' must be of class 'GR'") - } + } if (!is.vector(Param) | !is.numeric(Param)) { stop("'Param' must be a numeric vector") } @@ -29,7 +28,7 @@ RunModel_GR6J <- function(InputsModel, RunOptions, Param) { stop(paste("'Param' must be a vector of length", NParam, "and contain no NA")) } Param <- as.double(Param) - + Param_X1X3X6_threshold <- 1e-2 Param_X4_threshold <- 0.5 if (Param[1L] < Param_X1X3X6_threshold) { @@ -47,8 +46,8 @@ RunModel_GR6J <- function(InputsModel, RunOptions, Param) { if (Param[6L] < Param_X1X3X6_threshold) { warning(sprintf("Param[6] (X6: coefficient for emptying exponential store [mm]) < %.2f\n X6 set to %.2f", Param_X1X3X6_threshold, Param_X1X3X6_threshold)) Param[6L] <- Param_X1X3X6_threshold - } - + } + ## Input data preparation if (identical(RunOptions$IndPeriod_WarmUp, 0L)) { RunOptions$IndPeriod_WarmUp <- NULL @@ -56,25 +55,25 @@ RunModel_GR6J <- function(InputsModel, RunOptions, Param) { IndPeriod1 <- c(RunOptions$IndPeriod_WarmUp, RunOptions$IndPeriod_Run) LInputSeries <- as.integer(length(IndPeriod1)) if ("all" %in% RunOptions$Outputs_Sim) { - IndOutputs <- as.integer(1:length(FortranOutputs)) + IndOutputs <- as.integer(1:length(RunOptions$FortranOutputs$GR)) } else { - IndOutputs <- which(FortranOutputs %in% RunOptions$Outputs_Sim) + IndOutputs <- which(RunOptions$FortranOutputs$GR %in% RunOptions$Outputs_Sim) } - + ## Output data preparation IndPeriod2 <- (length(RunOptions$IndPeriod_WarmUp)+1):LInputSeries ExportDatesR <- "DatesR" %in% RunOptions$Outputs_Sim ExportStateEnd <- "StateEnd" %in% RunOptions$Outputs_Sim - + ## Use of IniResLevels if (!is.null(RunOptions$IniResLevels)) { RunOptions$IniStates[1] <- RunOptions$IniResLevels[1] * Param[1] ### production store level (mm) RunOptions$IniStates[2] <- RunOptions$IniResLevels[2] * Param[3] ### routing store level (mm) RunOptions$IniStates[3] <- RunOptions$IniResLevels[3] ### exponential store level (mm) } - + ## Call GR model Fortan - RESULTS <- .Fortran("frun_gr6j", PACKAGE = "airGR", + RESULTS <- .Fortran("frun_gr6j", PACKAGE = "airGR", ## inputs LInputs = LInputSeries, ### length of input and output series InputsPrecip = InputsModel$Precip[IndPeriod1], ### input series of total precipitation [mm/d] @@ -93,43 +92,17 @@ RunModel_GR6J <- function(InputsModel, RunOptions, Param) { RESULTS$StateEnd[RESULTS$StateEnd <= -99e8] <- NA if (ExportStateEnd) { RESULTS$StateEnd[-3L] <- ifelse(RESULTS$StateEnd[-3L] < 0, 0, RESULTS$StateEnd[-3L]) ### remove negative values except for the ExpStore location - RESULTS$StateEnd <- CreateIniStates(FUN_MOD = RunModel_GR6J, InputsModel = InputsModel, - ProdStore = RESULTS$StateEnd[1L], RoutStore = RESULTS$StateEnd[2L], ExpStore = RESULTS$StateEnd[3L], + RESULTS$StateEnd <- CreateIniStates(FUN_MOD = RunModel_GR6J, InputsModel = InputsModel, + ProdStore = RESULTS$StateEnd[1L], RoutStore = RESULTS$StateEnd[2L], ExpStore = RESULTS$StateEnd[3L], UH1 = RESULTS$StateEnd[(1:20) + 7], - UH2 = RESULTS$StateEnd[(1:40) + (7+20)], - GCemaNeigeLayers = NULL, eTGCemaNeigeLayers = NULL, + UH2 = RESULTS$StateEnd[(1:40) + (7+20)], + GCemaNeigeLayers = NULL, eTGCemaNeigeLayers = NULL, verbose = FALSE) } - - ## Output data preparation - ## OutputsModel only - if (!ExportDatesR & !ExportStateEnd) { - OutputsModel <- lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]) - names(OutputsModel) <- FortranOutputs[IndOutputs] - } - ## 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])) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs]) - } - ## OutputsModel and StateEnd only - if (!ExportDatesR & ExportStateEnd) { - OutputsModel <- c(lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c(FortranOutputs[IndOutputs], "StateEnd") - } - ## DatesR and OutputsModel and StateEnd - if ((ExportDatesR & ExportStateEnd) | "all" %in% RunOptions$Outputs_Sim) { - OutputsModel <- c(list(InputsModel$DatesR[RunOptions$IndPeriod_Run]), - lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]), - list(RESULTS$StateEnd)) - names(OutputsModel) <- c("DatesR", FortranOutputs[IndOutputs], "StateEnd") - } - - ## End - rm(RESULTS) - class(OutputsModel) <- c("OutputsModel", "daily", "GR") - return(OutputsModel) - + + ## OutputsModel generation + .GetOutputsModel(InputsModel, + RunOptions, + RESULTS, + LInputSeries) } diff --git a/R/UtilsRunModel.R b/R/UtilsRunModel.R index fb0d4524..49b50dfe 100644 --- a/R/UtilsRunModel.R +++ b/R/UtilsRunModel.R @@ -27,7 +27,7 @@ OutputsModel <- list() if("DatesR" %in% RunOptions$Outputs_Sim) { - OutputsModel$DatesR <- list(InputsModel$DatesR[RunOptions$IndPeriod_Run]) + OutputsModel$DatesR <- InputsModel$DatesR[RunOptions$IndPeriod_Run] } seqOutputs <- seq_len(RESULTS$NOutputs) @@ -44,5 +44,7 @@ OutputsModel$StateEnd <- RESULTS$StateEnd } + class(OutputsModel) <- c("OutputsModel", class(RunOptions)[-1]) + return(OutputsModel) } -- GitLab