Estimacion de la vulnerabilidad mediante analisis morfometrico
Luis Mejia
2024-06-04
Curso: Modelos matematicos en hidrologia Postgrado: Maestria en recursos hidricos - UNALM Referencia: Portuguez-Maurtua, M.;Arumi, J.L.; Stehr, A.; Lagos, O.; Chávarri- Velarde, E.; Rivera-Ruiz, D.Mapping of Areas Vulnerable to Flash Floods by Means of Morphometric Analysis with Weighting Criteria Applied. Water 2023, 15, 1053. https://doi.org/10.3390/w15061053
Importacion de librerias
psych para el correlograma, dplyr para el manejo de datos, openxlsx para leer excels, gridExtra y grid para convertir df en imagenes.
library(psych)## Warning: package 'psych' was built under R version 4.3.3library(dplyr)##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(openxlsx)## Warning: package 'openxlsx' was built under R version 4.3.3library(gridExtra)## Warning: package 'gridExtra' was built under R version 4.3.3##
## Attaching package: 'gridExtra'## The following object is masked from 'package:dplyr':
##
## combinelibrary(grid)Lectura del excel con los parametros geomorfologicos
## R Rr Dd Fs Cr Tr As Er Ff Sf
## SB1 948 483.633 0.402 0.110 0.301 0.115 32.209 0.720 0.408 2.453
## SB2 1138 468.700 0.372 0.117 0.320 0.134 41.156 0.713 0.399 2.504
## SB3 1176 483.501 0.345 0.071 0.267 0.068 46.934 0.670 0.353 2.836
## SB4 1787 290.094 0.380 0.079 0.266 0.100 40.018 0.580 0.264 3.781
## SB5 1845 297.424 0.428 0.114 0.281 0.152 41.620 0.574 0.259 3.864
## SB6 1177 499.149 0.404 0.242 0.286 0.267 49.144 0.783 0.482 2.076
## SB7 1327 413.209 0.380 0.150 0.249 0.196 44.698 0.817 0.524 1.910
## SB8 1304 546.804 0.344 0.090 0.313 0.082 50.364 0.670 0.353 2.835
## SB9 1747 508.211 0.368 0.072 0.310 0.073 54.880 0.712 0.398 2.514
## SB10 1057 500.000 0.372 0.153 0.346 0.172 46.417 0.719 0.406 2.466
## SB11 2894 377.940 0.392 0.097 0.330 0.196 52.368 1.078 0.913 1.095
## SB12 1787 526.358 0.364 0.178 0.270 0.205 49.388 0.892 0.625 1.600
## SB13 1857 707.076 0.434 0.218 0.265 0.225 54.855 1.070 0.899 1.113
## SB14 1567 1552.961 0.353 0.100 0.286 0.048 53.455 1.176 1.085 0.921
## SB15 1380 2880.392 0.387 0.219 0.263 0.068 49.369 1.577 1.952 0.512
## SB16 1153 3316.176 0.746 0.498 0.392 0.125 74.172 1.176 1.087 0.920
## SB17 1052 647.922 0.408 0.165 0.305 0.141 41.824 0.759 0.453 2.208
## SB18 1995 358.714 0.399 0.221 0.322 0.353 39.221 0.805 0.508 1.967
## SB19 2326 426.911 0.366 0.143 0.347 0.178 61.247 0.686 0.369 2.706
## SB20 1795 692.932 0.394 0.298 0.322 0.262 55.480 0.811 0.517 1.934
## SB21 2772 459.253 0.369 0.132 0.366 0.186 57.257 0.810 0.516 1.938
## SB22 2719 522.087 0.385 0.165 0.329 0.227 57.582 1.168 1.072 0.933
## SB23 2077 182.656 0.394 0.163 0.212 0.301 47.434 0.526 0.217 4.599
## SB24 857 3733.913 1.069 0.980 0.266 0.144 72.454 0.991 0.771 1.297
## SB25 2774 308.788 0.430 0.153 0.261 0.169 45.957 0.555 0.242 4.129
## SB26 2752 885.859 0.415 0.220 0.268 0.205 69.755 1.216 1.161 0.861
## SB27 2330 523.682 0.384 0.152 0.294 0.179 52.704 0.863 0.585 1.708
## SB28 3439 307.938 0.353 0.142 0.309 0.302 63.290 0.954 0.714 1.400
## SB29 3062 311.551 0.481 0.068 0.202 0.057 58.834 0.480 0.181 5.530
## SB30 2983 344.126 0.366 0.143 0.283 0.150 59.659 0.566 0.252 3.972
## SB31 3148 368.380 0.416 0.269 0.290 0.262 55.902 0.561 0.248 4.039
## SB32 2403 893.820 0.364 0.135 0.337 0.134 61.121 1.287 1.301 0.769
## SB33 2903 294.530 0.437 0.204 0.303 0.329 61.984 0.903 0.640 1.562
## SB34 1035 575.055 0.340 0.153 0.329 0.142 44.510 0.708 0.394 2.539
## SB35 1063 615.556 0.360 0.182 0.371 0.194 48.287 0.819 0.526 1.900
## SB36 2647 579.123 0.290 0.171 0.351 0.169 61.097 0.771 0.466 2.145
## SB37 2217 569.767 0.484 0.130 0.326 0.100 70.699 0.902 0.639 1.565
## SB38 2020 345.593 0.432 0.209 0.322 0.253 59.934 1.006 0.794 1.259
## SB39 2381 472.632 0.481 0.180 0.305 0.198 55.557 1.050 0.866 1.155
## SB40 3136 415.426 0.366 0.104 0.317 0.115 60.394 0.700 0.385 2.595
## SB41 1448 1000.433 0.491 0.211 0.215 0.104 55.976 1.842 2.665 0.375Matriz de ranking preliminar
Creacion de la matriz preliminar mediante bucles con for (x2). Los 7 primeros parametros tienen una relacion directa y las 3 ultimas inversa.
rank <- matrix(data = NA,
nrow = nrow(x),
ncol = ncol(x),
dimnames = list(rownames(x), colnames(x)))
for (n in 1:7) { #orden descendente 7 primeros parametros
for (i in 1:nrow(x)) {
arreglo <- x %>% arrange(desc(x[,n])) %>% mutate(orden = c(1:nrow(x)))
filtro <- arreglo$orden == i
rank[rownames(arreglo[filtro,]) == rownames(rank),n] <- i
}
}
for (n in 8:10) { #orden ascendente 3 ultimos parametros
for (i in 1:nrow(x)) {
arreglo <- x %>% arrange((x[,n])) %>% mutate(orden = c(1:nrow(x)))
filtro <- arreglo$orden == i
rank[rownames(arreglo[filtro,]) == rownames(rank[,]),n] <- i
}
}
rank## R Rr Dd Fs Cr Tr As Er Ff Sf
## SB1 40 22 16 33 23 31 41 16 16 26
## SB2 35 25 26 31 15 28 38 14 14 28
## SB3 33 23 38 40 32 38 31 8 8 34
## SB4 24 40 24 38 33 34 39 7 7 35
## SB5 22 38 11 32 29 23 37 6 6 36
## SB6 32 21 15 5 26 5 28 19 19 23
## SB7 30 29 25 24 38 14 34 23 23 19
## SB8 31 15 39 37 17 36 25 9 9 33
## SB9 26 19 29 39 18 37 20 13 13 29
## SB10 37 20 27 20 6 20 32 15 15 27
## SB11 7 30 20 36 8 15 24 34 34 8
## SB12 25 16 33 15 30 11 26 26 26 16
## SB13 21 8 8 9 35 10 21 33 33 9
## SB14 27 4 36 35 27 41 22 36 36 6
## SB15 29 3 21 8 36 39 27 40 40 2
## SB16 34 2 2 2 1 30 1 37 37 5
## SB17 38 10 14 17 20 27 36 17 17 25
## SB18 20 32 17 6 12 1 40 20 20 22
## SB19 16 27 30 25 5 19 7 10 10 32
## SB20 23 9 18 3 13 6 19 22 22 20
## SB21 9 26 28 29 3 17 15 21 21 21
## SB22 11 18 22 18 9 9 14 35 35 7
## SB23 18 41 19 19 40 4 30 2 2 40
## SB24 41 1 1 1 34 25 2 30 30 12
## SB25 8 36 10 21 37 21 33 3 3 39
## SB26 10 7 13 7 31 12 4 38 38 4
## SB27 15 17 23 23 24 18 23 25 25 17
## SB28 1 37 37 27 19 3 5 29 29 13
## SB29 4 35 5 41 41 40 13 1 1 41
## SB30 5 34 31 26 28 24 12 5 5 37
## SB31 2 31 12 4 25 7 17 4 4 38
## SB32 13 6 34 28 7 29 8 39 39 3
## SB33 6 39 7 12 22 2 6 28 28 14
## SB34 39 13 40 22 10 26 35 12 12 30
## SB35 36 11 35 13 2 16 29 24 24 18
## SB36 12 12 41 16 4 22 9 18 18 24
## SB37 17 14 4 30 11 35 3 27 27 15
## SB38 19 33 9 11 14 8 11 31 31 11
## SB39 14 24 6 14 21 13 18 32 32 10
## SB40 3 28 32 34 16 32 10 11 11 31
## SB41 28 5 3 10 39 33 16 41 41 1Correlograma
Creacion del correlograma entre los parametros geomorfologicos.
cor <- round(cor(rank, use = "everything", method = "pearson"),3)
corPlot(cor, colors = TRUE,
main = paste0("Correlograma de parametros de la subcuenca"," ",cuenca),
digits = 3)
cor## R Rr Dd Fs Cr Tr As Er Ff Sf
## R 1.000 -0.490 0.043 -0.115 -0.006 0.321 0.488 0.061 0.061 -0.061
## Rr -0.490 1.000 -0.009 0.361 0.170 -0.328 0.228 -0.608 -0.608 0.608
## Dd 0.043 -0.009 1.000 0.452 -0.323 0.153 0.191 -0.210 -0.210 0.210
## Fs -0.115 0.361 0.452 1.000 0.010 0.562 0.223 -0.420 -0.420 0.420
## Cr -0.006 0.170 -0.323 0.010 1.000 0.113 0.217 -0.160 -0.160 0.160
## Tr 0.321 -0.328 0.153 0.562 0.113 1.000 0.060 -0.113 -0.113 0.113
## As 0.488 0.228 0.191 0.223 0.217 0.060 1.000 -0.404 -0.404 0.404
## Er 0.061 -0.608 -0.210 -0.420 -0.160 -0.113 -0.404 1.000 1.000 -1.000
## Ff 0.061 -0.608 -0.210 -0.420 -0.160 -0.113 -0.404 1.000 1.000 -1.000
## Sf -0.061 0.608 0.210 0.420 0.160 0.113 0.404 -1.000 -1.000 1.000Weighted Sum Analysis
Calculo de la correlacion parcial, total, pesos y matriz WSA_cp.
cor_sum <- t(data.frame(colSums(cor)))
cor_sum## R Rr Dd Fs Cr Tr As Er Ff Sf
## colSums.cor. 1.302 0.324 1.297 2.073 1.021 1.768 2.003 -0.854 -0.854 0.854cor_total <- round(rowSums(cor_sum),3)
cor_total## colSums.cor.
## 8.934weight <- round(cor_sum/cor_total,3)
weight## R Rr Dd Fs Cr Tr As Er Ff Sf
## colSums.cor. 0.146 0.036 0.145 0.232 0.114 0.198 0.224 -0.096 -0.096 0.096WSA_cp <- matrix(data = NA,
nrow = nrow(x),
ncol = ncol(x),
dimnames = list(rownames(x),colnames(x)))
for (n in 1:ncol(x)) {
WSA_cp[,n] <- round(rank[,n]*weight[,n],2)
}
WSA_cp <- data.frame(WSA_cp)
WSA_cp## R Rr Dd Fs Cr Tr As Er Ff Sf
## SB1 5.84 0.79 2.32 7.66 2.62 6.14 9.18 -1.54 -1.54 2.50
## SB2 5.11 0.90 3.77 7.19 1.71 5.54 8.51 -1.34 -1.34 2.69
## SB3 4.82 0.83 5.51 9.28 3.65 7.52 6.94 -0.77 -0.77 3.26
## SB4 3.50 1.44 3.48 8.82 3.76 6.73 8.74 -0.67 -0.67 3.36
## SB5 3.21 1.37 1.59 7.42 3.31 4.55 8.29 -0.58 -0.58 3.46
## SB6 4.67 0.76 2.17 1.16 2.96 0.99 6.27 -1.82 -1.82 2.21
## SB7 4.38 1.04 3.62 5.57 4.33 2.77 7.62 -2.21 -2.21 1.82
## SB8 4.53 0.54 5.65 8.58 1.94 7.13 5.60 -0.86 -0.86 3.17
## SB9 3.80 0.68 4.20 9.05 2.05 7.33 4.48 -1.25 -1.25 2.78
## SB10 5.40 0.72 3.91 4.64 0.68 3.96 7.17 -1.44 -1.44 2.59
## SB11 1.02 1.08 2.90 8.35 0.91 2.97 5.38 -3.26 -3.26 0.77
## SB12 3.65 0.58 4.78 3.48 3.42 2.18 5.82 -2.50 -2.50 1.54
## SB13 3.07 0.29 1.16 2.09 3.99 1.98 4.70 -3.17 -3.17 0.86
## SB14 3.94 0.14 5.22 8.12 3.08 8.12 4.93 -3.46 -3.46 0.58
## SB15 4.23 0.11 3.04 1.86 4.10 7.72 6.05 -3.84 -3.84 0.19
## SB16 4.96 0.07 0.29 0.46 0.11 5.94 0.22 -3.55 -3.55 0.48
## SB17 5.55 0.36 2.03 3.94 2.28 5.35 8.06 -1.63 -1.63 2.40
## SB18 2.92 1.15 2.46 1.39 1.37 0.20 8.96 -1.92 -1.92 2.11
## SB19 2.34 0.97 4.35 5.80 0.57 3.76 1.57 -0.96 -0.96 3.07
## SB20 3.36 0.32 2.61 0.70 1.48 1.19 4.26 -2.11 -2.11 1.92
## SB21 1.31 0.94 4.06 6.73 0.34 3.37 3.36 -2.02 -2.02 2.02
## SB22 1.61 0.65 3.19 4.18 1.03 1.78 3.14 -3.36 -3.36 0.67
## SB23 2.63 1.48 2.76 4.41 4.56 0.79 6.72 -0.19 -0.19 3.84
## SB24 5.99 0.04 0.14 0.23 3.88 4.95 0.45 -2.88 -2.88 1.15
## SB25 1.17 1.30 1.45 4.87 4.22 4.16 7.39 -0.29 -0.29 3.74
## SB26 1.46 0.25 1.88 1.62 3.53 2.38 0.90 -3.65 -3.65 0.38
## SB27 2.19 0.61 3.34 5.34 2.74 3.56 5.15 -2.40 -2.40 1.63
## SB28 0.15 1.33 5.36 6.26 2.17 0.59 1.12 -2.78 -2.78 1.25
## SB29 0.58 1.26 0.72 9.51 4.67 7.92 2.91 -0.10 -0.10 3.94
## SB30 0.73 1.22 4.50 6.03 3.19 4.75 2.69 -0.48 -0.48 3.55
## SB31 0.29 1.12 1.74 0.93 2.85 1.39 3.81 -0.38 -0.38 3.65
## SB32 1.90 0.22 4.93 6.50 0.80 5.74 1.79 -3.74 -3.74 0.29
## SB33 0.88 1.40 1.01 2.78 2.51 0.40 1.34 -2.69 -2.69 1.34
## SB34 5.69 0.47 5.80 5.10 1.14 5.15 7.84 -1.15 -1.15 2.88
## SB35 5.26 0.40 5.07 3.02 0.23 3.17 6.50 -2.30 -2.30 1.73
## SB36 1.75 0.43 5.94 3.71 0.46 4.36 2.02 -1.73 -1.73 2.30
## SB37 2.48 0.50 0.58 6.96 1.25 6.93 0.67 -2.59 -2.59 1.44
## SB38 2.77 1.19 1.30 2.55 1.60 1.58 2.46 -2.98 -2.98 1.06
## SB39 2.04 0.86 0.87 3.25 2.39 2.57 4.03 -3.07 -3.07 0.96
## SB40 0.44 1.01 4.64 7.89 1.82 6.34 2.24 -1.06 -1.06 2.98
## SB41 4.09 0.18 0.43 2.32 4.45 6.53 3.58 -3.94 -3.94 0.10Matriz de ranking final
Calculo de la correlacion parcial, total, pesos y matriz WSA_cp.
sub_basin <- as.numeric(substr(rownames(x),3,4))
WSA_cp_plus <- rowSums(WSA_cp[,1:7])
WSA_cp_minus <- rowSums(WSA_cp[,8:10])
priority <- WSA_cp_plus - WSA_cp_minus
areas <- read.xlsx(xlsxFile = "params.xlsx", sheet = "areas", rowNames = TRUE)
area_p <- round(areas[,1]/colSums(areas),2)
df_final <- data.frame(sub_basin,WSA_cp_plus,WSA_cp_minus,priority,area_p)
df_final <- df_final %>% arrange(desc(df_final[,4])) %>% mutate(priority_level = nrow(x):1)
df_final <- df_final %>% arrange(df_final[,1])
df_final <- df_final %>% mutate(priority_type =
case_when(priority > 33.76 ~ "Poor",
between(priority, 27.63, 33.76) ~ "Low",
between(priority, 21.50, 27.63) ~ "Medium",
between(priority, 15.37, 21.50) ~ "High",
between(priority, 9.24, 15.37) ~ "Very high"))
df_final## sub_basin WSA_cp_plus WSA_cp_minus priority area_p priority_level
## SB1 1 34.55 -0.58 35.13 0.02 39
## SB2 2 32.73 0.01 32.72 0.02 36
## SB3 3 38.55 1.72 36.83 0.02 40
## SB4 4 36.47 2.02 34.45 0.03 37
## SB5 5 29.74 2.30 27.44 0.03 27
## SB6 6 18.98 -1.43 20.41 0.02 12
## SB7 7 29.33 -2.60 31.93 0.04 34
## SB8 8 33.97 1.45 32.52 0.01 35
## SB9 9 31.59 0.28 31.31 0.02 33
## SB10 10 26.48 -0.29 26.77 0.02 25
## SB11 11 22.61 -5.75 28.36 0.07 28
## SB12 12 23.91 -3.46 27.37 0.03 26
## SB13 13 17.28 -5.48 22.76 0.02 19
## SB14 14 33.55 -6.34 39.89 0.00 41
## SB15 15 27.11 -7.49 34.60 0.00 38
## SB16 16 12.05 -6.62 18.67 0.00 6
## SB17 17 27.57 -0.86 28.43 0.01 29
## SB18 18 18.45 -1.73 20.18 0.04 10
## SB19 19 19.36 1.15 18.21 0.02 4
## SB20 20 13.92 -2.30 16.22 0.01 3
## SB21 21 20.11 -2.02 22.13 0.03 18
## SB22 22 15.58 -6.05 21.63 0.03 17
## SB23 23 23.35 3.46 19.89 0.09 9
## SB24 24 15.68 -4.61 20.29 0.00 11
## SB25 25 24.56 3.16 21.40 0.03 16
## SB26 26 12.02 -6.92 18.94 0.02 7
## SB27 27 22.93 -3.17 26.10 0.03 23
## SB28 28 16.98 -4.31 21.29 0.08 15
## SB29 29 27.57 3.74 23.83 0.02 22
## SB30 30 23.11 2.59 20.52 0.02 13
## SB31 31 12.13 2.89 9.24 0.02 1
## SB32 32 21.88 -7.19 29.07 0.02 30
## SB33 33 10.32 -4.04 14.36 0.05 2
## SB34 34 31.19 0.58 30.61 0.01 32
## SB35 35 23.65 -2.87 26.52 0.02 24
## SB36 36 18.67 -1.16 19.83 0.02 8
## SB37 37 19.37 -3.74 23.11 0.01 20
## SB38 38 13.45 -4.90 18.35 0.02 5
## SB39 39 16.01 -5.18 21.19 0.02 14
## SB40 40 24.38 0.86 23.52 0.02 21
## SB41 41 21.58 -7.78 29.36 0.01 31
## priority_type
## SB1 Poor
## SB2 Low
## SB3 Poor
## SB4 Poor
## SB5 Medium
## SB6 High
## SB7 Low
## SB8 Low
## SB9 Low
## SB10 Medium
## SB11 Low
## SB12 Medium
## SB13 Medium
## SB14 Poor
## SB15 Poor
## SB16 High
## SB17 Low
## SB18 High
## SB19 High
## SB20 High
## SB21 Medium
## SB22 Medium
## SB23 High
## SB24 High
## SB25 High
## SB26 High
## SB27 Medium
## SB28 High
## SB29 Medium
## SB30 High
## SB31 Very high
## SB32 Low
## SB33 Very high
## SB34 Low
## SB35 Medium
## SB36 High
## SB37 Medium
## SB38 High
## SB39 High
## SB40 Medium
## SB41 Lowdf_final %>% group_by(priority_type) %>% count()## # A tibble: 5 × 2
## # Groups: priority_type [5]
## priority_type n
## <chr> <int>
## 1 High 14
## 2 Low 9
## 3 Medium 11
## 4 Poor 5
## 5 Very high 2