Newer
Older
Delaigue Olivier
committed
CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = FALSE,
ProdStore = 350, RoutStore = 90, ExpStore = NULL, IntStore = NULL,
unknown
committed
UH1 = NULL, UH2 = NULL,
GCemaNeigeLayers = NULL, eTGCemaNeigeLayers = NULL,
Delaigue Olivier
committed
GthrCemaNeigeLayers = NULL, GlocmaxCemaNeigeLayers = NULL,
unknown
committed
verbose = TRUE) {
unknown
committed
ObjectClass <- NULL
unknown
committed
UH1n <- 20L
UH2n <- UH1n * 2L
FUN_MOD <- match.fun(FUN_MOD)
FeatFUN_MOD <- .GetFeatModel(FUN_MOD = FUN_MOD, DatesR = InputsModel$DatesR)
ObjectClass <- FeatFUN_MOD$Class
if (!"CemaNeige" %in% ObjectClass & IsHyst) {
stop("'IsHyst' cannot be TRUE if CemaNeige is not used in 'FUN_MOD'")
unknown
committed
}
if (!(identical(FUN_MOD, RunModel_GR5H) | identical(FUN_MOD, RunModel_CemaNeigeGR5H)) & IsIntStore) {
stop("'IsIntStore' cannot be TRUE if GR5H is not used in 'FUN_MOD'")
}
unknown
committed
## check InputsModel
if (!inherits(InputsModel, "InputsModel")) {
stop("'InputsModel' must be of class 'InputsModel'")
}
if ("GR" %in% ObjectClass & !inherits(InputsModel, "GR")) {
stop("'InputsModel' must be of class 'GR'")
}
if ("CemaNeige" %in% ObjectClass &
!inherits(InputsModel, "CemaNeige")) {
stop("'InputsModel' must be of class 'CemaNeige'")
unknown
committed
}
unknown
committed
## check states
if (any(eTGCemaNeigeLayers > 0)) {
stop("Positive values are not allowed for 'eTGCemaNeigeLayers'")
unknown
committed
if (identical(FUN_MOD, RunModel_GR6J) | identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
if (is.null(ExpStore)) {
stop("'RunModel_*GR6J' need an 'ExpStore' value")
}
unknown
committed
} else if (!is.null(ExpStore)) {
if (verbose) {
warning(sprintf("'%s' does not require 'ExpStore'. Value set to NA", FeatFUN_MOD$NameFunMod))
unknown
committed
}
unknown
committed
ExpStore <- Inf
}
unknown
committed
if (identical(FUN_MOD, RunModel_GR2M)) {
unknown
committed
if (!is.null(UH1)) {
unknown
committed
if (verbose) {
warning(sprintf("'%s' does not require 'UH1'. Values set to NA", FeatFUN_MOD$NameFunMod))
unknown
committed
}
unknown
committed
UH1 <- rep(Inf, UH1n)
}
if (!is.null(UH2)) {
unknown
committed
if (verbose) {
warning(sprintf("'%s' does not require 'UH2'. Values set to NA", FeatFUN_MOD$NameFunMod))
unknown
committed
}
unknown
committed
UH2 <- rep(Inf, UH2n)
}
}
unknown
committed
if ((identical(FUN_MOD, RunModel_GR5J) | identical(FUN_MOD, RunModel_CemaNeigeGR5J)) & !is.null(UH1)) {
if (verbose) {
warning(sprintf("'%s' does not require 'UH1'. Values set to NA", FeatFUN_MOD$NameFunMod))
unknown
committed
}
unknown
committed
UH1 <- rep(Inf, UH1n)
Delaigue Olivier
committed
if ((!identical(FUN_MOD, RunModel_GR5H) | identical(FUN_MOD, RunModel_CemaNeigeGR5H)) & !is.null(IntStore)) {
if (verbose) {
warning(sprintf("'%s' does not require 'IntStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
IntStore <- Inf
unknown
committed
}
if ("CemaNeige" %in% ObjectClass & ! "GR" %in% ObjectClass) {
if (!is.null(ProdStore)) {
if (verbose) {
warning(sprintf("'%s' does not require 'ProdStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
ProdStore <- Inf
if (!is.null(RoutStore)) {
if (verbose) {
warning(sprintf("'%s' does not require 'RoutStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
RoutStore <- Inf
if (!is.null(ExpStore)) {
if (verbose) {
warning(sprintf("'%s' does not require 'ExpStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
ExpStore <- Inf
if (!is.null(IntStore)) {
if (verbose) {
warning(sprintf("'%s' does not require 'IntStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
IntStore <- Inf
if (!is.null(UH1)) {
if (verbose) {
warning(sprintf("'%s' does not require 'UH1'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
UH1 <- rep(Inf, UH1n)
if (!is.null(UH2)) {
if (verbose) {
warning(sprintf("'%s' does not require 'UH2'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
UH2 <- rep(Inf, UH2n)
}
stop(sprintf("'%s' need values for 'IntStore'", FeatFUN_MOD$NameFunMod))
}
if ("CemaNeige" %in% ObjectClass & !IsHyst &
unknown
committed
(is.null(GCemaNeigeLayers) | is.null(eTGCemaNeigeLayers))) {
stop(sprintf("'%s' need values for 'GCemaNeigeLayers' and 'GCemaNeigeLayers'", FeatFUN_MOD$NameFunMod))
if ("CemaNeige" %in% ObjectClass & IsHyst &
(is.null(GCemaNeigeLayers) | is.null(eTGCemaNeigeLayers) |
is.null(GthrCemaNeigeLayers) | is.null(GlocmaxCemaNeigeLayers))) {
stop(sprintf("'%s' need values for 'GCemaNeigeLayers', 'GCemaNeigeLayers', 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'", FeatFUN_MOD$NameFunMod))
if ("CemaNeige" %in% ObjectClass & !IsHyst &
(!is.null(GthrCemaNeigeLayers) | !is.null(GlocmaxCemaNeigeLayers))) {
if (verbose) {
warning(sprintf("'%s' does not require 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
GthrCemaNeigeLayers <- Inf
unknown
committed
}
(!is.null(GCemaNeigeLayers) | !is.null(eTGCemaNeigeLayers) | !is.null(GthrCemaNeigeLayers) | !is.null(GlocmaxCemaNeigeLayers))) {
unknown
committed
if (verbose) {
warning(sprintf("'%s' does not require 'GCemaNeigeLayers' 'GCemaNeigeLayers', 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'. Values set to NA", FeatFUN_MOD$NameFunMod))
unknown
committed
}
GCemaNeigeLayers <- Inf
eTGCemaNeigeLayers <- Inf
GthrCemaNeigeLayers <- Inf
unknown
committed
}
unknown
committed
## set states
unknown
committed
NLayers <- length(InputsModel$LayerPrecip)
} else {
NLayers <- 1
}
unknown
committed
## manage NULL values
if (is.null(ExpStore)) {
unknown
committed
}
if (is.null(IntStore)) {
}
unknown
committed
if (is.null(UH1)) {
if ("hourly" %in% ObjectClass) {
k <- 24
} else {
k <- 1
}
Delaigue Olivier
committed
UH1 <- rep(Inf, UH1n * k)
unknown
committed
}
if (is.null(UH2)) {
if ("hourly" %in% ObjectClass) {
k <- 24
} else {
k <- 1
}
Delaigue Olivier
committed
UH2 <- rep(Inf, UH2n * k)
unknown
committed
}
if (is.null(GCemaNeigeLayers)) {
GCemaNeigeLayers <- rep(Inf, NLayers)
}
if (is.null(eTGCemaNeigeLayers)) {
eTGCemaNeigeLayers <- rep(Inf, NLayers)
Delaigue Olivier
committed
if (is.null(GthrCemaNeigeLayers)) {
Delaigue Olivier
committed
GthrCemaNeigeLayers <- rep(Inf, NLayers)
}
Delaigue Olivier
committed
if (any(is.infinite(GthrCemaNeigeLayers))) {
Delaigue Olivier
committed
GthrCemaNeigeLayers <- rep(Inf, NLayers)
}
if (is.null(GlocmaxCemaNeigeLayers)) {
Delaigue Olivier
committed
GlocmaxCemaNeigeLayers <- rep(Inf, NLayers)
}
Delaigue Olivier
committed
if (any(is.infinite(GlocmaxCemaNeigeLayers))) {
Delaigue Olivier
committed
GlocmaxCemaNeigeLayers <- rep(Inf, NLayers)
# check negative values
if (any(ProdStore < 0) | any(RoutStore < 0) | any(IntStore < 0) |
any(UH1 < 0) | any(UH2 < 0) |
any(GCemaNeigeLayers < 0)) {
stop("Negative values are not allowed for any of 'ProdStore', 'RoutStore', 'IntStore', 'UH1', 'UH2', 'GCemaNeigeLayers'")
unknown
committed
## check length
if (!is.numeric(ProdStore) || length(ProdStore) != 1L) {
stop("'ProdStore' must be numeric of length one")
}
if (!is.numeric(RoutStore) || length(RoutStore) != 1L) {
stop("'RoutStore' must be numeric of length one")
}
if (!is.numeric(ExpStore) || length(ExpStore) != 1L) {
stop("'ExpStore' must be numeric of length one")
}
if (!is.numeric(IntStore) || length(IntStore) != 1L) {
stop("'IntStore' must be numeric of length one")
}
Delaigue Olivier
committed
if ( "hourly" %in% ObjectClass & (!is.numeric(UH1) || length(UH1) != UH1n * 24)) {
unknown
committed
stop(sprintf("'UH1' must be numeric of length 480 (%i * 24)", UH1n))
}
Delaigue Olivier
committed
if (!"hourly" %in% ObjectClass & (!is.numeric(UH1) || length(UH1) != UH1n)) {
unknown
committed
stop(sprintf("'UH1' must be numeric of length %i", UH1n))
}
Delaigue Olivier
committed
if ( "hourly" %in% ObjectClass & (!is.numeric(UH2) || length(UH2) != UH2n * 24)) {
unknown
committed
stop(sprintf("'UH2' must be numeric of length 960 (%i * 24)", UH2n))
}
Delaigue Olivier
committed
if (!"hourly" %in% ObjectClass & (!is.numeric(UH2) || length(UH2) != UH2n)) {
unknown
committed
stop(sprintf("'UH2' must be numeric of length %i (2 * %i)", UH2n, UH1n))
}
if (!is.numeric(GCemaNeigeLayers) || length(GCemaNeigeLayers) != NLayers) {
stop(sprintf("'GCemaNeigeLayers' must be numeric of length %i", NLayers))
}
if (!is.numeric(eTGCemaNeigeLayers) || length(eTGCemaNeigeLayers) != NLayers) {
stop(sprintf("'eTGCemaNeigeLayers' must be numeric of length %i", NLayers))
}
if (IsHyst) {
if (!is.numeric(GthrCemaNeigeLayers) || length(GthrCemaNeigeLayers) != NLayers) {
stop(sprintf("'eTGCemaNeigeLayers' must be numeric of length %i", NLayers))
}
if (!is.numeric(GlocmaxCemaNeigeLayers) || length(GlocmaxCemaNeigeLayers) != NLayers) {
stop(sprintf("'eTGCemaNeigeLayers' must be numeric of length %i", NLayers))
}
}
if (!is.null(SD)) {
if (!inherits(InputsModel, "SD")) {
stop("'SD' argument provided and 'InputsModel' is not of class 'SD'")
}
stop("'SD' argument must be a list")
}
lapply(SD, function(x) {
if (!is.numeric(x)) stop("Each item of 'SD' list argument must be numeric")
if (length(SD) != length(InputsModel$LengthHydro)) {
stop("Number of items of 'SD' list argument must be the same as the number of upstream connections",
sprintf(" (%i required, found %i)", length(InputsModel$LengthHydro), length(SD)))
}
}
## format output
IniStates <- list(Store = list(Prod = ProdStore, Rout = RoutStore, Exp = ExpStore, Int = IntStore),
unknown
committed
UH = list(UH1 = UH1, UH2 = UH2),
Delaigue Olivier
committed
CemaNeigeLayers = list(G = GCemaNeigeLayers, eTG = eTGCemaNeigeLayers,
Gthr = GthrCemaNeigeLayers, Glocmax = GlocmaxCemaNeigeLayers))
unknown
committed
IniStatesNA <- unlist(IniStates)
IniStatesNA[is.infinite(IniStatesNA)] <- NA
IniStatesNA <- relist(IniStatesNA, skeleton = IniStates)
IniStatesNA$SD <- SD
}
unknown
committed
class(IniStatesNA) <- c("IniStates", ObjectClass)
class(IniStatesNA) <- c(class(IniStatesNA), "hysteresis")
}
class(IniStatesNA) <- c(class(IniStatesNA), "interception")
}
unknown
committed
return(IniStatesNA)