Utils.R 6.22 KB
Newer Older
1

2
3
4
5
6
7
8
9
10
11
12
13
## =================================================================================
## function to check
## =================================================================================

# .onLoad <- function(libname, pkgname){
#   if (requireNamespace("airGRteaching", quietly = TRUE)) {
#     if (packageVersion("airGRteaching") %in% package_version(c("0.2.0.9", "0.2.2.2", "0.2.3.2"))) {
#       packageStartupMessage("In order to be compatible with the present version of 'airGR', please update your version of the 'airGRteaching' package.")
#     }
#   }
# }

14
15


16
17
18
19
20
21
22
23
24
25
26
27
## =================================================================================
## function to extract model features
## =================================================================================

## table of feature models
.FeatModels <- function() {
  path <- system.file("modelsFeatures/FeatModelsGR.csv", package = "airGR")
  read.table(path, header = TRUE, sep = ";")
}


## function to extract model features
28
.GetFeatModel <- function(FUN_MOD, DatesR) {
29
  FeatMod <- .FeatModels()
30
  NameFunMod <- ifelse(test = FeatMod$Pkg %in% "airGR",
31
32
33
34
35
36
37
38
39
                       yes  = paste("RunModel", FeatMod$NameMod, sep = "_"),
                       no   = FeatMod$NameMod)
  FunMod <- lapply(NameFunMod, FUN = get)
  IdMod <- which(sapply(FunMod, FUN = function(x) identical(FUN_MOD, x)))
  if (length(IdMod) < 1) {
    stop("'FUN_MOD' must be one of ", paste(NameFunMod, collapse = ", "))
  } else {
    res <- as.list(FeatMod[IdMod, ])
    res$NameFunMod <- NameFunMod[IdMod]
40
41
42
43
44
45
46
47
48
49
    DiffTimeStep <- as.numeric(difftime(DatesR[length(DatesR)],
                                        DatesR[length(DatesR)-1],
                                        units = "secs"))
    if (is.na(res$TimeUnit)) {
      if (any(DiffTimeStep %in% 3600:3601)) { # 3601: leap second
        res$TimeUnit <- "hourly"
      } else {
        res$TimeUnit <- "daily"
      }
    }
50
51
    res$TimeStep <- switch(res$TimeUnit,
                           hourly  =       1,
52
53
54
                           daily   =       1 * 24,
                           monthly =   28:31 * 24,
                           yearly  = 365:366 * 24)
55
56
57
    res$TimeStep <- res$TimeStep * 3600
    res$Class <- c(res$TimeUnit, res$Class)
    if (grepl("CemaNeige", res$NameFunMod)) {
58
59
60
      res$Class <- unique(c(res$Class, "CemaNeige"))

    }
61
    if (all(DiffTimeStep != res$TimeStep)) {
62
      stop("the time step of the model inputs must be ", res$TimeUnit, "\n")
63
64
65
66
67
68
69
    }
    return(res)
  }
}



70
71
72
73
74
## =================================================================================
## function to manage Fortran outputs
## =================================================================================

.FortranOutputs <- function(GR = NULL, isCN = FALSE) {
75

76
77
  outGR <- NULL
  outCN <- NULL
78

79
80
81
82
83
84
85
  if (is.null(GR)) {
    GR <- ""
  }
  if (GR == "GR1A") {
    outGR <- c("PotEvap", "Precip",
               "Qsim")
  } else if (GR == "GR2M") {
86
    outGR <- c("PotEvap", "Precip", "Prod", "Pn", "Ps",
87
88
               "AE",
               "Perc", "PR",
89
90
               "Rout",
               "AExch",
91
               "Qsim")
92
93
  } else if (GR == "GR5H") {
    outGR <- c("PotEvap", "Precip", "Interc", "Prod", "Pn", "Ps",
94
               "AE", "EI", "ES",
95
96
               "Perc", "PR",
               "Q9", "Q1",
97
               "Rout", "Exch",
98
99
               "AExch1", "AExch2",
               "AExch", "QR",
100
101
               "QD",
               "Qsim")
102
  } else if (GR %in% c("GR4J", "GR5J", "GR4H")) {
103
104
105
106
    outGR <- c("PotEvap", "Precip", "Prod", "Pn", "Ps",
               "AE",
               "Perc", "PR",
               "Q9", "Q1",
107
               "Rout", "Exch",
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
               "AExch1", "AExch2",
               "AExch", "QR",
               "QD",
               "Qsim")
  } else if (GR == "GR6J") {
    outGR <- c("PotEvap", "Precip", "Prod", "Pn", "Ps",
               "AE",
               "Perc", "PR",
               "Q9", "Q1",
               "Rout", "Exch",
               "AExch1", "AExch2",
               "AExch", "QR",
               "QRExp", "Exp",
               "QD",
               "Qsim")
  }
  if (isCN) {
125
126
127
    outCN <- c("Pliq", "Psol",
               "SnowPack", "ThermalState", "Gratio",
               "PotMelt", "Melt", "PliqAndMelt", "Temp",
128
129
               "Gthreshold", "Glocalmax")
  }
130

131
  res <- list(GR = outGR, CN = outCN)
132

133
}
134
135
136
137
138
139
140
141
142
143
144
145



## =================================================================================
## functions to extract parts of InputsModel or OutputsModel objects
## =================================================================================

## InputsModel

.ExtractInputsModel <- function(x, i) {
  res <- lapply(x, function(x) {
    if (is.matrix(x)) {
146
      res0 <- x[i, , drop = FALSE]
147
148
149
150
151
    }
    if (is.vector(x) | inherits(x, "POSIXt")) {
      res0 <- x[i]
    }
    if (is.list(x) & !inherits(x, "POSIXt")) {
152
153
154
155
156
      if (inherits(x, "OutputsModel")) {
        res0 <- .ExtractOutputsModel(x = x, i = i)
      } else {
        res0 <- .ExtractInputsModel(x = x, i = i)
      }
157
158
159
160
161
162
    }
    return(res0)
  })
  if (!is.null(x$ZLayers)) {
    res$ZLayers <- x$ZLayers
  }
163
164
165
166
  if (inherits(x, "SD")) {
    res$LengthHydro <- x$LengthHydro
    res$BasinAreas  <- x$BasinAreas
  }
167
168
169
170
171
172
173
174
  class(res) <- class(x)
  res
}

'[.InputsModel' <- function(x, i) {
  if (!inherits(x, "InputsModel")) {
    stop("'x' must be of class 'InputsModel'")
  }
175
176
177
178
  if (is.factor(i)) {
    i <- as.character(i)
  }
  if (is.numeric(i)) {
179
    .ExtractInputsModel(x, i)
180
  } else {
181
    NextMethod()
182
  }
183
184
185
}


186
## OutputsModel
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203

.ExtractOutputsModel <- function(x, i) {
  res <- lapply(x, function(x) {
    if (is.matrix(x)  && length(dim(x)) == 2L) {
      res0 <- x[i, ]
    }
    if (is.array(x) && length(dim(x)) == 3L) {
      res0 <- x[i, , ]
    }
    if (is.vector(x) | inherits(x, "POSIXt")) {
      res0 <- x[i]
    }
    if (is.list(x) & !inherits(x, "POSIXt")) {
      res0 <- .ExtractOutputsModel(x = x, i = i)
    }
    return(res0)
  })
204
205
  if (!is.null(x$StateEnd)) {
    res$StateEnd <- x$StateEnd
206
207
208
209
210
  }
  class(res) <- class(x)
  res
}

211
212
213
214
215
216
217
218
219
220
221
222
223
# '[.OutputsModel' <- function(x, i) {
#   if (!inherits(x, "OutputsModel")) {
#     stop("'x' must be of class 'OutputsModel'")
#   }
#   if (is.factor(i)) {
#     i <- as.character(i)
#   }
#   if (is.numeric(i)) {
#     .ExtractOutputsModel(x, i)
#   } else {
#     NextMethod()
#   }
# }