CreateCalibOptions.R 12.3 KB
Newer Older
1
2
3
4
5
6
7
8
9
CreateCalibOptions <- function(FUN_MOD,
                               FUN_CALIB = Calibration_Michel,
                               FUN_TRANSFO = NULL,
                               FixedParam = NULL,
                               SearchRanges = NULL,
                               StartParamList = NULL,
                               StartParamDistrib = NULL) {
  
  ObjectClass <- NULL
10
    
11
12
    FUN_MOD     <- match.fun(FUN_MOD)
    FUN_CALIB   <- match.fun(FUN_CALIB)
13
14
15
    if(!is.null(FUN_TRANSFO)) {
      FUN_TRANSFO <- match.fun(FUN_TRANSFO)
    }
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
59
60
    
    ##check_FUN_MOD
    BOOL <- FALSE
    
    if (identical(FUN_MOD, RunModel_GR4H)) {
      ObjectClass <- c(ObjectClass, "GR4H")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_GR4J)) {
      ObjectClass <- c(ObjectClass, "GR4J")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_GR5J)) {
      ObjectClass <- c(ObjectClass, "GR5J")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_GR6J)) {
      ObjectClass <- c(ObjectClass, "GR6J")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_GR2M)) {
      ObjectClass <- c(ObjectClass, "GR2M")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_GR1A)) {
      ObjectClass <- c(ObjectClass, "GR1A")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_CemaNeige)) {
      ObjectClass <- c(ObjectClass, "CemaNeige")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_CemaNeigeGR4J)) {
      ObjectClass <- c(ObjectClass, "CemaNeigeGR4J")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_CemaNeigeGR5J)) {
      ObjectClass <- c(ObjectClass, "CemaNeigeGR5J")
      BOOL <- TRUE
    }
    if (identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
      ObjectClass <- c(ObjectClass, "CemaNeigeGR6J")
      BOOL <- TRUE
    }
    if (!BOOL) {
61
      stop("incorrect FUN_MOD for use in CreateCalibOptions")
62
63
64
65
66
67
68
69
70
71
72
      return(NULL)
    }
    
    ##check_FUN_CALIB
    BOOL <- FALSE
    
    if (identical(FUN_CALIB, Calibration_Michel)) {
      ObjectClass <- c(ObjectClass, "HBAN")
      BOOL <- TRUE
    }
    if (!BOOL) {
73
      stop("incorrect FUN_CALIB for use in CreateCalibOptions")
74
75
76
77
78
79
      return(NULL)
      
    }
    
    ##check_FUN_TRANSFO
    if (is.null(FUN_TRANSFO)) {
Delaigue Olivier's avatar
Delaigue Olivier committed
80
      ##_set_FUN1
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
      if (identical(FUN_MOD, RunModel_GR4H)) {
        FUN1 <- TransfoParam_GR4H
      }
      if (identical(FUN_MOD, RunModel_GR4J) |
          identical(FUN_MOD, RunModel_CemaNeigeGR4J)) {
        FUN1 <- TransfoParam_GR4J
      }
      if (identical(FUN_MOD, RunModel_GR5J) |
          identical(FUN_MOD, RunModel_CemaNeigeGR5J)) {
        FUN1 <- TransfoParam_GR5J
      }
      if (identical(FUN_MOD, RunModel_GR6J) |
          identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
        FUN1 <- TransfoParam_GR6J
      }
      if (identical(FUN_MOD, RunModel_GR2M)) {
        FUN1 <- TransfoParam_GR2M
      }
      if (identical(FUN_MOD, RunModel_GR1A)) {
        FUN1 <- TransfoParam_GR1A
      }
102
103
104
105
106
107
	  if (identical(FUN_MOD, RunModel_CemaNeige)) {
        if (inherits(FUN_MOD, "hysteresis")) {
          FUN1 <- TransfoParam_CemaNeigeHyst
        } else {
          FUN1 <- TransfoParam_CemaNeige
        }
108
109
      }
      if (is.null(FUN1)) {
110
        stop("FUN1 was not found")
111
112
        return(NULL)
      }
Delaigue Olivier's avatar
Delaigue Olivier committed
113
      ##_set_FUN2
114
115
      FUN2 <- TransfoParam_CemaNeige
      
Delaigue Olivier's avatar
Delaigue Olivier committed
116
      ##_set_FUN_TRANSFO
117
118
      if (sum(ObjectClass %in% c("GR4H", "GR4J", "GR5J", "GR6J", "GR2M", "GR1A", "CemaNeige")) > 0) {
        FUN_TRANSFO <- FUN1
Delaigue Olivier's avatar
Delaigue Olivier committed
119
      } else {
120
121
122
123
124
125
126
127
128
        FUN_TRANSFO <- function(ParamIn, Direction) {
          Bool <- is.matrix(ParamIn)
          if (Bool == FALSE) {
            ParamIn <- rbind(ParamIn)
          }
          ParamOut <- NA * ParamIn
          NParam   <- ncol(ParamIn)
          if (NParam <= 3) {
            ParamOut[, 1:(NParam - 2)] <- FUN1(cbind(ParamIn[, 1:(NParam - 2)]), Direction)
Delaigue Olivier's avatar
Delaigue Olivier committed
129
          } else {
130
131
132
133
134
135
136
            ParamOut[, 1:(NParam - 2)] <- FUN1(ParamIn[, 1:(NParam - 2)], Direction)
          }
          ParamOut[, (NParam - 1):NParam] <- FUN2(ParamIn[, (NParam - 1):NParam], Direction)
          if (Bool == FALSE) {
            ParamOut <- ParamOut[1, ]
          }
          return(ParamOut)
Delaigue Olivier's avatar
Delaigue Olivier committed
137
138
139
        }
      }
    }
140
    if (is.null(FUN_TRANSFO)) {
141
      stop("FUN_TRANSFO was not found")
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
      return(NULL)
    }
    
    ##NParam
    if ("GR4H" %in% ObjectClass) {
      NParam <- 4
    }
    if ("GR4J" %in% ObjectClass) {
      NParam <- 4
    }
    if ("GR5J" %in% ObjectClass) {
      NParam <- 5
    }
    if ("GR6J" %in% ObjectClass) {
      NParam <- 6
    }
    if ("GR2M" %in% ObjectClass) {
      NParam <- 2
    }
    if ("GR1A" %in% ObjectClass) {
      NParam <- 1
    }
    if ("CemaNeige" %in% ObjectClass) {
      NParam <- 2
    }
    if ("CemaNeigeGR4J" %in% ObjectClass) {
      NParam <- 6
    }
    if ("CemaNeigeGR5J" %in% ObjectClass) {
      NParam <- 7
    }
    if ("CemaNeigeGR6J" %in% ObjectClass) {
      NParam <- 8
    }
176
177
178
179
	if (inherits(FUN_MOD, "hysteresis")) {
	  NParam <- NParam + 2
	}

180
181
182
183
    
    ##check_FixedParam
    if (is.null(FixedParam)) {
      FixedParam <- rep(NA, NParam)
Delaigue Olivier's avatar
Delaigue Olivier committed
184
    } else {
185
      if (!is.vector(FixedParam)) {
186
        stop("FixedParam must be a vector")
187
188
      }
      if (length(FixedParam) != NParam) {
189
        stop("Incompatibility between FixedParam length and FUN_MOD")
190
      }
191
      if (all(!is.na(FixedParam))) {
192
        stop("At least one parameter must be not set (NA)")
193
      }
194
      if (all(is.na(FixedParam))) {
195
        warning("You have not set any parameter in \"FixedParam\"")
196
      }
197
198
199
200
201
202
203
204
205
    }
    
    ##check_SearchRanges
    if (is.null(SearchRanges)) {
      ParamT <-  matrix(c(rep(-9.99, NParam), rep(+9.99, NParam)),
                        ncol = NParam, byrow = TRUE)
      
      SearchRanges <- TransfoParam(ParamIn = ParamT, Direction = "TR", FUN_TRANSFO = FUN_TRANSFO)
      
Delaigue Olivier's avatar
Delaigue Olivier committed
206
    } else {
207
      if (!is.matrix(SearchRanges)) {
208
        stop("SearchRanges must be a matrix")
209
210
      }
      if (!is.numeric(SearchRanges)) {
211
        stop("SearchRanges must be a matrix of numeric values")
212
213
      }
      if (sum(is.na(SearchRanges)) != 0) {
214
        stop("SearchRanges must not include NA values")
215
216
      }
      if (nrow(SearchRanges) != 2) {
217
        stop("SearchRanges must have 2 rows")
218
219
      }
      if (ncol(SearchRanges) != NParam) {
220
        stop("Incompatibility between SearchRanges ncol and FUN_MOD")
221
222
223
224
225
226
227
228
      }
    }
    
    ##check_StartParamList_and_StartParamDistrib__default_values
    if (("HBAN"  %in% ObjectClass & is.null(StartParamList) & is.null(StartParamDistrib))) {
      if ("GR4H" %in% ObjectClass) {
        ParamT <- matrix(c(+5.12, -1.18, +4.34, -9.69,
                           +5.58, -0.85, +4.74, -9.47,
229
                           +6.01, -0.50, +5.14, -8.87), ncol = 4,  byrow = TRUE)
230
231
232
233
      }
      if ("GR4J" %in% ObjectClass) {
        ParamT <- matrix(c(+5.13, -1.60, +3.03, -9.05,
                           +5.51, -0.61, +3.74, -8.51,
234
                           +6.07, -0.02, +4.42, -8.06),  ncol = 4, byrow = TRUE)
235
236
237
238
      }
      if ("GR5J" %in% ObjectClass) {
        ParamT <- matrix(c(+5.17, -1.13, +3.08, -9.37, -7.45,
                           +5.55, -0.46, +3.75, -9.09, -4.69,
239
                           +6.10, -0.11, +4.43, -8.60, -0.66), ncol = 5, byrow = TRUE)
240
241
242
243
244
        
      }
      if ("GR6J" %in% ObjectClass) {
        ParamT <- matrix(c(+3.60, -1.00, +3.30, -9.10, -0.90, +3.00,
                           +3.90, -0.50, +4.10, -8.70, +0.10, +4.00,
245
                           +4.50, +0.50, +5.00, -8.10, +1.10, +5.00), ncol = 6, byrow = TRUE)
246
247
248
249
      }
      if ("GR2M" %in% ObjectClass) {
        ParamT <- matrix(c(+5.03, -7.15,
                           +5.22, -6.74,
250
                           +5.85, -6.37), ncol = 2, byrow = TRUE)
251
252
253
254
      }
      if ("GR1A" %in% ObjectClass) {
        ParamT <- matrix(c(-1.69,
                           -0.38,
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
                           +1.39), ncol = 1, byrow = TRUE)
      }
# 	  if (inherits(FUN_MOD, "hysteresis")) {
#         if ("CemaNeige" %in% ObjectClass) {
#           ParamT <- matrix(c(-9.96, +6.63, -9.08, -6.99,
#                              -9.14, +6.90, -8.00, -3.20,
#                              +4.10, +7.21, -6.40, +9.99), ncol = NParam, byrow = TRUE)
#         }
#         if ("CemaNeigeGR4J" %in% ObjectClass) {
#           ParamT <- matrix(c(+5.13, -1.60, +3.03, -9.05, -9.96, +6.63, -9.08, -6.99,
#                              +5.51, -0.61, +3.74, -8.51, -9.14, +6.90, -8.00, -3.20,
#                              +6.07, -0.02, +4.42, -8.06, +4.10, +7.21, -6.40, +9.99), ncol = NParam, byrow = TRUE)
#         }
#         if ("CemaNeigeGR5J" %in% ObjectClass) {
#           ParamT <- matrix(c(+5.17, -1.13, +3.08, -9.37, -7.45, -9.96, +6.63, -9.08, -6.99,
#                              +5.55, -0.46, +3.75, -9.09, -4.69, -9.14, +6.90, -8.00, -3.20,
#                              +6.10, -0.11, +4.43, -8.60, -0.66, +4.10, +7.21, -6.40, +9.99), ncol = NParam, byrow = TRUE)
#         }
#         if ("CemaNeigeGR6J" %in% ObjectClass) {
#           ParamT <- matrix(c(+3.60, -1.00, +3.30, -9.10, -0.90, +3.00, -9.96, +6.63, -9.08, -6.99,
#                              +3.90, -0.50, +4.10, -8.70, +0.10, +4.00, -9.14, +6.90, -8.00, -3.20,
#                              +4.50, +0.50, +5.00, -8.10, +1.10, +5.00, +4.10, +7.21, -6.40, +9.99), ncol = NParam, byrow = TRUE)
#         }
# 	  } else {
        if ("CemaNeige" %in% ObjectClass) {
          ParamT <- matrix(c(-9.96, +6.63,
                             -9.14, +6.90,
                             +4.10, +7.21), ncol = 2, byrow = TRUE)
        }
        if ("CemaNeigeGR4J" %in% ObjectClass) {
          ParamT <- matrix(c(+5.13, -1.60, +3.03, -9.05, -9.96, +6.63,
                             +5.51, -0.61, +3.74, -8.51, -9.14, +6.90,
                             +6.07, -0.02, +4.42, -8.06, +4.10, +7.21), ncol = 6, byrow = TRUE)
        }
        if ("CemaNeigeGR5J" %in% ObjectClass) {
          ParamT <- matrix(c(+5.17, -1.13, +3.08, -9.37, -7.45, -9.96, +6.63,
                             +5.55, -0.46, +3.75, -9.09, -4.69, -9.14, +6.90,
                             +6.10, -0.11, +4.43, -8.60, -0.66, +4.10, +7.21), ncol = 7, byrow = TRUE)
        }
        if ("CemaNeigeGR6J" %in% ObjectClass) {
          ParamT <- matrix(c(+3.60, -1.00, +3.30, -9.10, -0.90, +3.00, -9.96, +6.63,
                             +3.90, -0.50, +4.10, -8.70, +0.10, +4.00, -9.14, +6.90,
                             +4.50, +0.50, +5.00, -8.10, +1.10, +5.00, +4.10, +7.21), ncol = 8, byrow = TRUE)
        }
	  # }
      if (inherits(FUN_MOD, "hysteresis")) {
        ParamTHyst <- matrix(c(-9.08, -6.99,
                               -8.00, -3.20,
                               -6.40, +9.99), ncol = 2, byrow = TRUE)
        ParamT <- cbind(ParamT, ParamTHyst)
305
306
307
308
309
310
311
312
313
314
      }
      
      StartParamList    <- NULL
      StartParamDistrib <- TransfoParam(ParamIn = ParamT, Direction = "TR", FUN_TRANSFO = FUN_TRANSFO)
      
    }
    
    ##check_StartParamList_and_StartParamDistrib__format
    if ("HBAN" %in% ObjectClass & !is.null(StartParamList)) {
      if (!is.matrix(StartParamList)) {
315
        stop("StartParamList must be a matrix")
316
317
      }
      if (!is.numeric(StartParamList)) {
318
        stop("StartParamList must be a matrix of numeric values")
319
320
      }
      if (sum(is.na(StartParamList)) != 0) {
321
        stop("StartParamList must not include NA values")
322
323
      }
      if (ncol(StartParamList) != NParam) {
324
        stop("Incompatibility between StartParamList ncol and FUN_MOD")
325
326
327
328
      }
    }
    if ("HBAN" %in% ObjectClass & !is.null(StartParamDistrib)) {
      if (!is.matrix(StartParamDistrib)) {
329
        stop("StartParamDistrib must be a matrix")
330
331
      }
      if (!is.numeric(StartParamDistrib[1, ])) {
332
        stop("StartParamDistrib must be a matrix of numeric values")
333
334
      }
      if (sum(is.na(StartParamDistrib[1, ])) != 0) {
335
        stop("StartParamDistrib must not include NA values on the first line")
336
337
      }
      if (ncol(StartParamDistrib) != NParam) {
338
        stop("Incompatibility between StartParamDistrib ncol and FUN_MOD")
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
      }
    }
    
    
    ##Create_CalibOptions
    CalibOptions <- list(FixedParam = FixedParam, SearchRanges = SearchRanges)
    
    if (!is.null(StartParamList)) {
      CalibOptions <- c(CalibOptions, list(StartParamList = StartParamList))
    }
    if (!is.null(StartParamDistrib)) {
      CalibOptions <- c(CalibOptions, list(StartParamDistrib = StartParamDistrib))
    }
    class(CalibOptions) <- c("CalibOptions", ObjectClass)
    
    return(CalibOptions)
    
  }