CreateIniStates.R 7.3 KB
Newer Older
1
CreateIniStates <- function(FUN_MOD, InputsModel,
2
                            ProdStore = 350, RoutStore = 90, ExpStore = NULL,
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
                            UH1 = NULL, UH2 = NULL,
                            GCemaNeigeLayers = NULL, eTGCemaNeigeLayers = NULL,
                            verbose = TRUE) {
  
  
  ObjectClass <- NULL
  
  UH1n <- 20L
  UH2n <- UH1n * 2L
  
  
  ## 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)) {
    stop("'RunModel_GR1A' does not require 'IniStates' object")
  }
  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 'CreateIniStates'")
    return(NULL)
  }
  
  ## check InputsModel
  if (!inherits(InputsModel, "InputsModel")) {
    stop("'InputsModel' must be of class 'InputsModel'")
    return(NULL)
  }
  if ("GR" %in% ObjectClass & !inherits(InputsModel, "GR")) {
    stop("'InputsModel' must be of class 'GR'")
    return(NULL)
  }
  if ("CemaNeige" %in% ObjectClass &
      !inherits(InputsModel, "CemaNeige")) {
59
    stop("'InputsModel' must be of class 'CemaNeige'")
60
61
62
63
64
    return(NULL)
  }
  
  
  ## check states
65
66
67
  if (any(eTGCemaNeigeLayers > 0)) {
    stop("Positive values are not allowed for 'eTGCemaNeigeLayers'")
  }  
68
  
69
70
71
72
73
  if (identical(FUN_MOD, RunModel_GR6J) | identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
    if (is.null(ExpStore)) {
      stop("'RunModel_*GR6J' need an 'ExpStore' value")
      return(NULL)
    }
74
75
  } else if (!is.null(ExpStore)) {
    if (verbose) {
76
      warning(sprintf("'%s' does not require 'ExpStore'. Value set to NA", as.character(substitute(FUN_MOD))))
77
    }
78
79
80
    ExpStore <- Inf
  }
  
81
  if (identical(FUN_MOD, RunModel_GR2M)) {
82
    if (!is.null(UH1)) {
83
      if (verbose) {
84
        warning(sprintf("'%s' does not require 'UH1'. Values set to NA", as.character(substitute(FUN_MOD))))
85
      }
86
87
88
      UH1 <- rep(Inf, UH1n)
    }
    if (!is.null(UH2)) {
89
      if (verbose) {
90
        warning(sprintf("'%s' does not require 'UH2'. Values set to NA", as.character(substitute(FUN_MOD))))
91
      }
92
93
94
95
      UH2 <- rep(Inf, UH2n)
    }
  }
  
96
97
  if ((identical(FUN_MOD, RunModel_GR5J) | identical(FUN_MOD, RunModel_CemaNeigeGR5J)) & !is.null(UH1)) {
    if (verbose) {
98
      warning(sprintf("'%s' does not require 'UH1'. Values set to NA", as.character(substitute(FUN_MOD))))
99
    }
100
101
    UH1 <- rep(Inf, UH1n)
  }
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
 
  if ("CemaNeige" %in% ObjectClass & ! "GR" %in% ObjectClass) {
    if (!is.null(ProdStore)) {
      if (verbose) {
        warning(sprintf("'%s' does not require 'ProdStore'. Values set to NA", as.character(substitute(FUN_MOD))))
      }
    }
    ProdStore <- Inf
    if (!is.null(RoutStore)) {
      if (verbose) {
        warning(sprintf("'%s' does not require 'RoutStore'. Values set to NA", as.character(substitute(FUN_MOD))))
      }
    }
    RoutStore <- Inf
    if (!is.null(ExpStore)) {
      if (verbose) {
        warning(sprintf("'%s' does not require 'ExpStore'. Values set to NA", as.character(substitute(FUN_MOD))))
      }
    }
    ExpStore <- Inf
    if (!is.null(UH1)) {
      if (verbose) {
        warning(sprintf("'%s' does not require 'UH1'. Values set to NA", as.character(substitute(FUN_MOD))))
      }
    }
    UH1 <- rep(Inf, UH1n)
    if (!is.null(UH2)) {
      if (verbose) {
        warning(sprintf("'%s' does not require 'UH2'. Values set to NA", as.character(substitute(FUN_MOD))))
      }
    }
    UH2 <- rep(Inf, UH2n)
  }
135
136
137
138
139
140
  if("CemaNeige" %in% ObjectClass &
     (is.null(GCemaNeigeLayers) | is.null(eTGCemaNeigeLayers))) {
    stop("'RunModel_CemaNeigeGR*' need values for 'GCemaNeigeLayers' and 'GCemaNeigeLayers'")
    return(NULL)
  }
  if(!"CemaNeige" %in% ObjectClass &
141
142
     (!is.null(GCemaNeigeLayers) | !is.null(eTGCemaNeigeLayers))) {
    if (verbose) {
143
      warning(sprintf("'%s' does not require 'GCemaNeigeLayers' and 'GCemaNeigeLayers'. Values set to NA", as.character(substitute(FUN_MOD))))
144
    }
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
    GCemaNeigeLayers   <- Inf
    eTGCemaNeigeLayers <- Inf
  }
  
  
  ## set states
  if("CemaNeige" %in% ObjectClass) {
    NLayers <- length(InputsModel$LayerPrecip)
  } else {
    NLayers <- 1
  }
  
  
  ## manage NULL values
  if (is.null(ExpStore)) {
    ExpStore <- Inf 
  }
  if (is.null(UH1)) {
    if ("hourly"  %in% ObjectClass) {
      k <- 24
    } else {
      k <- 1
    }
168
    UH1 <- rep(Inf, UH1n * k)
169
170
171
172
173
174
175
  }
  if (is.null(UH2)) {
    if ("hourly"  %in% ObjectClass) {
      k <- 24
    } else {
      k <- 1
    }
176
    UH2 <- rep(Inf, UH2n * k)
177
178
179
180
181
182
  }
  if (is.null(GCemaNeigeLayers)) {
    GCemaNeigeLayers <- rep(Inf, NLayers)
  }
  if (is.null(eTGCemaNeigeLayers)) {
    eTGCemaNeigeLayers <- rep(Inf, NLayers)
183
184
185
186
187
188
189
190
191
  }
  
  
  # check negative values
  if (any(ProdStore < 0) | any(RoutStore < 0) |
      any(UH1 < 0) | any(UH2 < 0) |
      any(GCemaNeigeLayers < 0)) {
    stop("Negative values are not allowed for any of 'ProdStore', 'RoutStore', 'UH1', 'UH2', 'GCemaNeigeLayers'")
  }
192
193
194
195
  
  
  ## check length
  if (!is.numeric(ProdStore) || length(ProdStore) != 1L) {
196
    print(ProdStore)
197
198
199
200
201
202
203
204
    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")
  }
205
  if ( "hourly" %in% ObjectClass & (!is.numeric(UH1) || length(UH1) != UH1n * 24)) {
206
207
    stop(sprintf("'UH1' must be numeric of length 480 (%i * 24)", UH1n))
  }
208
  if (!"hourly" %in% ObjectClass & (!is.numeric(UH1) || length(UH1) != UH1n)) {
209
210
    stop(sprintf("'UH1' must be numeric of length %i", UH1n))
  }
211
  if ( "hourly" %in% ObjectClass & (!is.numeric(UH2) || length(UH2) != UH2n * 24)) {
212
213
    stop(sprintf("'UH2' must be numeric of length 960 (%i * 24)", UH2n))
  }
214
  if (!"hourly" %in% ObjectClass & (!is.numeric(UH2) || length(UH2) != UH2n)) {
215
216
217
218
219
220
221
222
223
    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))
  }
  
224
225

  ## format output
226
227
228
229
230
231
232
233
234
235
236
237
  IniStates <- list(Store = list(Prod = ProdStore, Rout = RoutStore, Exp = ExpStore),
                    UH = list(UH1 = UH1, UH2 = UH2),
                    CemaNeigeLayers = list(G = GCemaNeigeLayers, eTG = eTGCemaNeigeLayers))
  IniStatesNA <- unlist(IniStates)
  IniStatesNA[is.infinite(IniStatesNA)] <- NA
  IniStatesNA <- relist(IniStatesNA, skeleton = IniStates)
  
  class(IniStatesNA) <- c("IniStates", ObjectClass)
  return(IniStatesNA)
  
  
}