/
flood2.R
352 lines (318 loc) · 13.3 KB
/
flood2.R
1
2
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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
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
135
136
137
138
139
140
141
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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
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
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
#' @name flood2
#' @rdname flood2
#'
#' @title Function to compute flood extent or flood duration \code{SpatRaster}
#' along the German federal waterways Elbe and Rhine using the 1d water level
#' algorithm \code{hyd1d::waterLevelFlood2()}
#'
#' @description Computes flood extent, if \code{length(seq)} equals 1, or flood
#' duration for the active floodplains along the German federal waterways Elbe
#' and Rhine based on 1d water levels computed by
#' \code{\link[hyd1d]{waterLevelFlood2}} provided by package \pkg{hyd1d} in
#' analogy to the INFORM 3 module 'Flut2'.
#'
#' @param x has to by type \code{SpatRaster} and has to include both input
#' layers \code{csa} (cross section areas) and \code{dem} (digital
#' elevation model). To compute water levels along the River Elbe, \code{x}
#' has to be in the coordinate reference system
#' \href{https://spatialreference.org/ref/epsg/etrs89-utm-zone-33n/}{ETRS 1989 UTM 33N},
#' for the River Rhine in
#' \href{https://spatialreference.org/ref/epsg/etrs89-utm-zone-32n/}{ETRS 1989 UTM 32N}.
#' Other coordinate reference systems are not permitted.
#' @param seq has to be type \code{c("POSIXct", "POSIXt")} or \code{Date} and
#' have a length larger than 0. Values of \code{seq} must be in the
#' temporal range between 1960-01-01 and yesterday (\code{Sys.Date() - 1}).
#' Internally \code{waterLevelFlood2()} uses
#' \code{\link[hyd1d]{getGaugingDataW}} to obtain daily water level
#' information from \code{\link[hyd1d]{df.gauging_data}}.
#' @param filename supplies an optional output filename and has to be type
#' \code{character}.
#' @param \dots additional arguments as for \code{\link[terra]{writeRaster}}.
#'
#' @return \code{SpatRaster} object with flood duration in the range of
#' \code{[0, length(seq)]}.
#'
#' @details For every time step provided in \code{seq}, \code{flood2()} computes
#' a 1d water level using \code{\link[hyd1d]{waterLevelFlood2}} along the
#' requested river section. This 1d water level is transfered to a \code{wl}
#' (water level) raster layer, which is in fact a copy of the \code{csa}
#' (cross section areas) layer, and then compared to the \code{dem}
#' (digital elevation model) layer. Where the \code{wl} layer is
#' higher than the \code{dem}, layer flood duration is increased by 1.
#'
#' @seealso \code{\link[hyd1d]{df.gauging_data}},
#' \code{\link[hyd1d]{getGaugingDataW}},
#' \code{\link[hyd1d]{waterLevelFlood2}},
#' \code{\link[terra]{writeRaster}},
#' \code{\link[terra]{terraOptions}}
#'
#' @references
#' \insertRef{rosenzweig_inform_2011}{hydflood}
#'
#' @examples \donttest{
#' options("hydflood.datadir" = tempdir())
#' library(hydflood)
#'
#' # import the raster data and create a raster stack
#' c <- st_crs("EPSG:25833")
#' e <- ext(309000, 310000, 5749000, 5750000)
#' x <- hydSpatRaster(ext = e, crs = c)
#'
#' # create a temporal sequence
#' seq <- seq(as.Date("2016-12-01"), as.Date("2016-12-31"), by = "day")
#'
#' # compute a flood duration
#' fd <- flood2(x = x, seq = seq)
#' }
#'
#' @export
#'
flood2 <- function(x, seq, filename = '', ...) {
options("rgdal_show_exportToProj4_warnings" = "none")
#####
# check requirements
##
# vector and function to catch error messages
errors <- character()
l <- function(errors) {as.character(length(errors) + 1)}
## x
if (missing(x)) {
errors <- c(errors, paste0("Error ", l(errors), ": The 'x' ",
"argument has to be supplied."))
} else {
# class
if (!inherits(x, "SpatRaster")) {
errors <- c(errors, paste0("Error ", l(errors), ": 'x' must be ",
"type 'SpatRaster'."))
}
if (!all(c("dem", "csa") %in% names(x))) {
errors <- c(errors, paste0("Error ", l(errors), ": 'names(x)' must",
" be 'dem' and 'csa'."))
}
}
if (l(errors) != "1") {
stop(paste0(errors, collapse="\n "))
}
# crs
if (! isUTM32(x) & !isUTM33(x)) {
errors <- c(errors, paste0("Error ", l(errors), ": The projection",
" of x must be either 'ETRS 1989 UTM 32",
"N' or 'ETRS 1989 UTM 33N'."))
} else {
if (isUTM32(x)) {
river <- "Rhine"
} else if (isUTM33(x)) {
river <- "Elbe"
} else {
stop(errors)
}
}
# check position
sf.ext <- rasterextent2polygon(x)
if (exists("river")) {
af <- sf.af(name = river)
if (! (nrow(af[sf.ext,]) > 0)) {
errors <- c(errors, paste0("Error ", l(errors), ": The selected 'e",
"xt' does NOT overlap with the active f",
"loodplain of River ", river, "."))
}
}
if (l(errors) != "1") {
stop(paste0(errors, collapse="\n "))
}
## seq
if (missing(seq)) {
errors <- c(errors, paste0("Error ", l(errors), ": The 'seq' ",
"argument has to be supplied."))
} else {
# class
if (!inherits(seq, "Date") &
!all(c(inherits(seq, "POSIXct"), inherits(seq, "POSIXt")))) {
errors <- c(errors, paste0("Error ", l(errors), ": 'seq' must be",
" either type 'Date' or c('POSIXct', 'P",
"OSIXt')."))
}
# length
if (length(seq) < 1L) {
errors <- c(errors, paste0("Error ", l(errors), ": 'seq' must ha",
"ve length larger 0."))
}
# NA and possible range
if (any(is.na(seq))) {
errors <- c(errors, paste0("Error ", l(errors), ": 'seq' or elem",
"ents of it must not be NA."))
} else {
time_min <- trunc(Sys.time() - as.difftime(31, units = "days"),
units = "days")
if (all(c(inherits(seq, "POSIXct"), inherits(seq, "POSIXt")))) {
if (any(seq < time_min)) {
errors <- c(errors, paste0("Error ", l(errors), ": Values ",
"of 'seq' must be between ",
format(time_min, "%Y-%m-%d"),
" 00:00:00 and now, if type of ",
"'seq' is c('POSIXct', 'POSIXt'",
")."))
}
type_date <- FALSE
}
if (inherits(seq, "Date")) {
if (any(seq < as.Date("1960-01-01")) |
any(seq > Sys.Date() - 1)) {
errors <- c(errors, paste0("Error ", l(errors), ": Val",
"ues of 'seq' must be betwe",
"en 1960-01-01 and yesterda",
"y."))
}
type_date <- TRUE
}
}
}
## filename
if (! missing(filename)) {
if (!inherits(filename, "character")) {
errors <- c(errors, paste0("Error ", l(errors), ": 'filename' must",
" be type 'character'."))
}
if (length(filename) != 1) {
errors <- c(errors, paste0("Error ", l(errors), ": 'filename' must",
" have length 1."))
}
}
#####
# error messages
if (l(errors) != "1") {
stop(paste0(errors, collapse="\n "))
}
#####
# preprocessing
#####
# individual raster needed for the processing
csa <- raster::raster(x$csa)
dem <- raster::raster(x$dem)
# out template
out <- raster::raster(csa)
# describe out's data attributes
attributes <- out@data@attributes
attributes <- append(attributes, paste0("flood duration computed by hydflo",
"od::flood2() for the following t",
"emporal sequence with length ",
length(seq), ":"))
attributes <- append(attributes, seq)
out@data@attributes <- attributes
# water level template
waterlevel <- raster::raster(dem)
# initialize the WaterLevelDataFrame
station_int <- na.omit(as.integer(terra::unique(x$csa)$csa))
wldf_initial <- hyd1d::WaterLevelDataFrame(river = river,
time = as.POSIXct(NA),
station_int = station_int)
# check memory requirements
big <- ! raster::canProcessInMemory(out, 4)
filename <- raster::trim(filename)
if (big & filename == '') {
filename <- raster::rasterTmpFile()
}
if (filename != '') {
out <- terra::writeStart(out, filename, ...)
todisk <- TRUE
} else {
vv <- matrix(ncol = nrow(out), nrow = ncol(out))
todisk <- FALSE
}
#####
# processing
##
# compute all water levels through a loop over all time steps
wldfs <- vector(mode = "list", length = length(seq))
j <- 1
for (i in seq) {
if (type_date) {
time <- as.POSIXct(format(as.Date(i, as.Date("1970-01-01")),
"%Y-%m-%d"), tz = "CET")
} else {
time <- as.POSIXct(i, origin = "1970-01-01 00:00:00")
}
wldf <- wldf_initial
setTime(wldf) <- time
wldfs[[j]] <- hyd1d::waterLevelFlood2(wldf)
j <- j + 1
}
##
# raster processing
bs <- raster::blockSize(csa)
pb <- raster::pbCreate(bs$n, ...)
if (todisk) {
for (i in 1:bs$n) {
# vectorize cross section areas (integer)
v_csa <- raster::getValues(csa, row = bs$row[i], nrows = bs$nrows[i])
# get unique stations for the csa subset
v_stations <- stats::na.omit(unique(v_csa))
# copy v_csa to v_fd to create a template results vector with the
# same size and type
v_fd <- rep(0, length(v_csa))
# vectorize digital elevation model (numeric)
v_dem <- raster::getValues(dem, row = bs$row[i], nrows = bs$nrows[i])
# copy v_dem to v_fwl to create a template vector with the same
# size and type
v_wl <- rep(-999, length(v_csa))
# handle NA's
id_na <- is.na(v_csa) | is.na(v_dem)
id_nona <- !id_na
# loop over all time steps
for (j in 1:length(seq)) {
# transfer the water level info to v_wl
for (a_station in v_stations) {
v_wl[v_csa == a_station] <-
wldfs[[j]]$w[wldfs[[j]]$station_int == a_station]
}
# compare the water level raster to the dem
v_fd[id_nona][v_dem[id_nona] < v_wl[id_nona]] <-
v_fd[id_nona][v_dem[id_nona] < v_wl[id_nona]] + 1
}
# transfer NA's
v_fd[id_na] <- NA
# write the resulting flood durations into out
out <- terra::writeValues(out, v_fd, start = bs$row[i],
nrows = bs$nrows[i])
raster::pbStep(pb, i)
}
out <- terra::writeStop(out)
} else {
for (i in 1:bs$n) {
# vectorize cross section areas (integer)
v_csa <- raster::getValues(csa, row = bs$row[i], nrows = bs$nrows[i])
# get unique stations for the csa subset
v_stations <- stats::na.omit(unique(v_csa))
# copy v_csa to v_fd to create a template results vector with the
# same size and type
v_fd <- rep(0, length(v_csa))
# vectorize digital elevation model (numeric)
v_dem <- raster::getValues(dem, row = bs$row[i], nrows = bs$nrows[i])
# copy v_dem to v_fwl to create a template vector with the same
# size and type
v_wl <- rep(-999, length(v_csa))
# handle NA's
id_na <- is.na(v_csa) | is.na(v_dem)
id_nona <- !id_na
# loop over all time steps
for (j in 1:length(seq)) {
# transfer the water level info to v_wl
for (a_station in v_stations) {
v_wl[v_csa == a_station] <-
wldfs[[j]]$w[wldfs[[j]]$station_int == a_station]
}
# compare the water level raster to the dem
v_fd[id_nona][v_dem[id_nona] < v_wl[id_nona]] <-
v_fd[id_nona][v_dem[id_nona] < v_wl[id_nona]] + 1
}
# transfer NA's
v_fd[id_na] <- NA
cols <- bs$row[i]:(bs$row[i] + bs$nrows[i]-1)
vv[,cols] <- matrix(v_fd, nrow = out@ncols)
raster::pbStep(pb, i)
}
out <- raster::setValues(out, as.vector(vv))
}
raster::pbClose(pb)
return(terra::rast(out))
}