Inundation exchange algorithm
Andreas Angourakis
25 May, 2021
library(barplot3d)## Warning: package 'barplot3d' was built under R version 3.6.3library(rgl)## Warning: package 'rgl' was built under R version 3.6.3library(grid)
library(gridExtra)## Warning: package 'gridExtra' was built under R version 3.6.3library(png)After the introduction of river water flow (and sea water, if there are elevations are below sea level) and also solving runoff exchanges, it is possible that some downflow patches hold enough surface water for them to be higher than neighbours, in terms of elevation plus average surface water depth. This will happen specially when the value assigned to riverWaterPerFlowAccumulation is relatively high (much greater than 1E-4 mm / flow accumulation units). High values of flow_riverAccumulationAtStart used in the land model to generate the terrain will also make this situation more frequent. The inundation exchange algorithm redistribute the excess of surface water in each land unit with such excess to their lowest neighbours, in terms of elevation plus surface water depth. To do that, for each land unit with excess, the surface water of the entire Moore neighbourhood is aggregated, divided into arbitrarily small parts, which are added to the current lowest land unit within the neighbourhood, including the central land unit. The small parts’ dimension (errorToleranceThreshold) serves also has a threshold criterium below which differences between land unit heights are deemed negligible.
Functions
source("source/inundationExchange.R")solveInundationExchange## function (elevation, surfaceWater, errorToleranceThreshold = 1,
## maxIterations = 1e+05)
## {
## patchesWithExcess <- getPatchesWithExcessWater(elevation = elevation,
## surfaceWater = surfaceWater, errorToleranceThreshold = errorToleranceThreshold)
## while (maxIterations > 0 & any(patchesWithExcess)) {
## indexesOfPatchesWithExcess <- which(patchesWithExcess,
## arr.ind = TRUE)
## thisPatch <- indexesOfPatchesWithExcess[sample(nrow(indexesOfPatchesWithExcess),
## 1), ]
## neighborhood <- getMooreNeighborhood(x = thisPatch[1],
## y = thisPatch[2], xmin = 1, ymin = 1, xmax = nrow(surfaceWater),
## ymax = ncol(surfaceWater))
## sumNeighborhoodWaterDepth <- sum(getPatchValuesFromMatrix(patchesCoordinates = neighborhood,
## matrixOfValues = surfaceWater))/1000
## surfaceWater <- setPatchValuesFromMatrix(patchesCoordinates = neighborhood,
## newValues = rep(0, nrow(neighborhood)), matrixOfValues = surfaceWater)
## for (i in 1:round(sumNeighborhoodWaterDepth/errorToleranceThreshold)) {
## lowestPatchInNeighborhood <- getLowestPatchInNeighborhood(neighborhood = neighborhood,
## elevation = elevation, surfaceWater = surfaceWater)
## surfaceWater[lowestPatchInNeighborhood[1], lowestPatchInNeighborhood[2]] <- surfaceWater[lowestPatchInNeighborhood[1],
## lowestPatchInNeighborhood[2]] + errorToleranceThreshold *
## 1000
## }
## patchesWithExcess <- getPatchesWithExcessWater(elevation = elevation,
## surfaceWater = surfaceWater, errorToleranceThreshold = errorToleranceThreshold)
## patchesWithExcess[thisPatch[1], thisPatch[2]] <- FALSE
## extendedNeighborhood <- neighborhood
## for (i in 1:nrow(neighborhood)) {
## extendedNeighborhood <- rbind(extendedNeighborhood,
## getMooreNeighborhood(x = neighborhood[i, 1],
## y = neighborhood[i, 2], xmin = 1, ymin = 1,
## xmax = nrow(elevation), ymax = ncol(elevation)))
## }
## extendedNeighborhood <- unique(extendedNeighborhood)
## for (i in 1:nrow(extendedNeighborhood)) {
## patchesWithExcess[extendedNeighborhood[i, 1], extendedNeighborhood[i,
## 2]] <- hasExcessWater(patchCoordinates = extendedNeighborhood[i,
## ], elevation = elevation, surfaceWater = surfaceWater,
## errorToleranceThreshold = errorToleranceThreshold)
## }
## maxIterations = maxIterations - 1
## }
## return(surfaceWater)
## }getPatchesWithExcessWater## function (elevation, surfaceWater, errorToleranceThreshold)
## {
## patchesWithExcess <- matrix(rep(FALSE, length(elevation)),
## nrow = nrow(elevation), ncol = ncol(elevation), byrow = T)
## for (i in 1:nrow(patchesWithExcess)) {
## for (j in 1:ncol(patchesWithExcess)) {
## patchesWithExcess[i, j] <- (hasExcessWater(patchCoordinates = c(i,
## j), elevation = elevation, surfaceWater = surfaceWater,
## errorToleranceThreshold = errorToleranceThreshold))
## }
## }
## return(patchesWithExcess)
## }hasExcessWater## function (patchCoordinates, elevation, surfaceWater, errorToleranceThreshold)
## {
## neighborhood <- getMooreNeighborhood(x = patchCoordinates[1],
## y = patchCoordinates[2], xmin = 1, ymin = 1, xmax = nrow(surfaceWater),
## ymax = ncol(surfaceWater))
## neighborhoodHeights <- getHeights(patchesCoordinates = neighborhood,
## elevation = elevation, surfaceWater = surfaceWater)
## return((surfaceWater[patchCoordinates[1], patchCoordinates[2]] >
## 0) && any(neighborhoodHeights[1] - neighborhoodHeights >
## errorToleranceThreshold))
## }getHeights## function (patchesCoordinates, elevation, surfaceWater)
## {
## heights <- c()
## for (i in 1:nrow(patchesCoordinates)) {
## heights <- c(heights, elevation[patchesCoordinates[i,
## 1], patchesCoordinates[i, 2]] + surfaceWater[patchesCoordinates[i,
## 1], patchesCoordinates[i, 2]]/1000)
## }
## return(heights)
## }getMooreNeighborhood## function (x, y, xmin, xmax, ymin, ymax)
## {
## xCords <- c(x)
## yCords <- c(y)
## for (i in -1:1) {
## if (x + i >= xmin && x + i <= xmax) {
## for (j in -1:1) {
## if (y + j >= ymin & y + j <= ymax & !(i == 0 &
## j == 0)) {
## xCords <- c(xCords, x + i)
## yCords <- c(yCords, y + j)
## }
## }
## }
## }
## return(cbind(x = xCords, y = yCords))
## }getPatchValuesFromMatrix## function (patchesCoordinates, matrixOfValues)
## {
## values <- c()
## for (i in 1:nrow(patchesCoordinates)) {
## values <- c(values, matrixOfValues[patchesCoordinates[i,
## 1], patchesCoordinates[i, 2]])
## }
## return(values)
## }setPatchValuesFromMatrix## function (patchesCoordinates, newValues, matrixOfValues)
## {
## for (i in 1:nrow(patchesCoordinates)) {
## matrixOfValues[patchesCoordinates[i, 1], patchesCoordinates[i,
## 2]] <- newValues[i]
## }
## return(matrixOfValues)
## }getLowestPatchInNeighborhood## function (neighborhood, elevation, surfaceWater)
## {
## heights <- getHeights(patchesCoordinates = neighborhood,
## elevation = elevation, surfaceWater = surfaceWater)
## lowestPatch <- 1
## for (i in 1:nrow(neighborhood)) {
## if (heights[i] < heights[lowestPatch]) {
## lowestPatch <- i
## }
## }
## return(neighborhood[lowestPatch, ])
## }Setting up an example in R
Input: elevation
To illustrate the inundation algorithm, we only require elevation, not flow direction and accumulation. Note that elevation values would be typically expressed in metres, though here we use values between 0 and 1 to ease the graphical representation (thus the scalling transformations used later on plots).
elevation <- matrix( c(0.8, 0.6, 0.5, 0.6, 1,
0.7, 0.52, 0.45, 0.65, 0.8,
0.5, 0.3, 0.4, 0.5, 0.6,
0.3, 0.2, 0.25, 0.4, 0.5,
0.25, 0.15, 0.21, 0.35, 0.38),
nrow = 5, ncol = 5, byrow = T)
elevationGradient <- 100 + (155 * ((elevation - min(elevation)) / (max(elevation) - min(elevation) + 1E-6)))
inputdataColours <- rgb((elevationGradient - 100) / 255,
(elevationGradient / 255),
0)# plot in rgl device
barplot3d(rows = 5, cols = 5,
z = elevation,
scalexy = 1,
gap = 0.01,
alpha = 0.4,
theta = 40, phi = 30,
topcolors = inputdataColours,
xlabels = 1:5, ylabels = 1:5,
#xsub = "rows", ysub = "columns", zsub = "elevation"
gridlines = F
)
# save snapshot
par3d(windowRect = c(20, 30, 800, 800))
snapshot3d("flowAccumulationOrder_plot1.png")knitr::include_graphics("flowAccumulationOrder_plot1.png")
Execution
Initialise surface water layer as a large amount concentrated at the lowest land unit:
surfaceWater <- matrix( rep(0 , 25), nrow = 5, ncol = 5, byrow = T)
indexOfLowestPatch <- (1:length(elevation))[which.min(elevation)] - 1
surfaceWater[(indexOfLowestPatch %% ncol(surfaceWater)) + 1,
(indexOfLowestPatch %/% ncol(surfaceWater)) + 1] <- 1000Plot surface water levels before inundation exchange:
surfaceWaterColour <- rgb(0.2, 0.4, 0.7)
# plot in rgl device
barplot3d(rows = 5, cols = 5,
z = elevation,
scalexy = 1,
gap = 0.01,
alpha = 0.4,
theta = 40, phi = 30,
topcolors = inputdataColours,
xlabels = 1:5, ylabels = 1:5, zlabels = FALSE,
#xsub = "rows", ysub = "columns", zsub = "elevation"
gridlines = FALSE
)
waterCube <- cube3d(color = surfaceWaterColour, alpha = 0.5)
for (x in 1:dim(elevation)[1])
{
for (z in 1:dim(elevation)[2])
{
if (surfaceWater[x, z] > 0)
{
thisWaterCube <- waterCube %>%
scale3d(0.5, surfaceWater[x, z] / 1000, 0.5) %>%
translate3d(x + 0.5, elevation[x, z] + surfaceWater[x, z] / 1000, -1 * z - 0.5)
shade3d(thisWaterCube)
points3d(t(thisWaterCube$vb), size=5, color = surfaceWaterColour)
for (i in 1:6)
lines3d(t(thisWaterCube$vb)[thisWaterCube$ib[,i],], color = surfaceWaterColour)
}
}
}
# save snapshot
par3d(windowRect = c(20, 30, 800, 800))
snapshot3d("inundationExchange_plot1.png")knitr::include_graphics("inundationExchange_plot1.png")
rgl.close()Execute one iteration of the inundation exchange algorithm:
surfaceWater <- solveInundationExchange(elevation = elevation,
surfaceWater = surfaceWater,
errorToleranceThreshold = 0.01,
maxIterations = 1000) For better performance, errorToleranceThreshold must be set in a sensible scale compare to elevation values (here, these are values between 0 and 1, instead of actual metres). If this parameter and the grid is too small, the while loop can get stuck and maxIterations will be exhausted (execution takes much longer)—thus, here we also decrease maxIterations. Because the scale of water depth (mm) is purposely exagerated, the differences between patches will appear far greater in this example.
Plot surface water levels after runoff exchange:
surfaceWaterColour <- rgb(0.2, 0.4, 0.7)
# plot in rgl device
barplot3d(rows = 5, cols = 5,
z = elevation,
scalexy = 1,
gap = 0.01,
alpha = 0.4,
theta = 40, phi = 30,
topcolors = inputdataColours,
xlabels = 1:5, ylabels = 1:5, zlabels = FALSE,
#xsub = "rows", ysub = "columns", zsub = "elevation"
gridlines = FALSE
)
waterCube <- cube3d(color = surfaceWaterColour, alpha = 0.5)
for (x in 1:dim(elevation)[1])
{
for (z in 1:dim(elevation)[2])
{
if (surfaceWater[x, z] > 0)
{
thisWaterCube <- waterCube %>%
scale3d(0.5, surfaceWater[x, z] / 1000, 0.5) %>%
translate3d(x + 0.5, elevation[x, z] + surfaceWater[x, z] / 1000, -1 * z - 0.5)
shade3d(thisWaterCube)
points3d(t(thisWaterCube$vb), size=5, color = surfaceWaterColour)
for (i in 1:6)
lines3d(t(thisWaterCube$vb)[thisWaterCube$ib[,i],], color = surfaceWaterColour)
}
}
}
# save snapshot
par3d(windowRect = c(20, 30, 800, 800))
snapshot3d("inundationExchange_plot2.png")knitr::include_graphics("inundationExchange_plot2.png")
rgl.close()