对嵌套列表使用查找 table
Use a lookup table with a nested list
您好，我有一堆关于 streamflow(Q) 的水文数据，我想对其进行标准化。数据存储在一个大的 嵌套 table 中，布局如下所示，我需要保留 :
Flowtestlist <- list(list("910" = data.frame( Q=c(650, 720, 550, 580, 800)),
"950" = data.frame( Q=c(550, 770, 520, 540, 790))),
list ("910" = data.frame( Q=c(450, 620, 750, 580, 800)),
"950" = data.frame( Q=c(650, 750, 580, 520, 890))))
我有级别 [[1]] 和 [[2]]，实际上，我有 9 个级别，这些也是型号。在每个模型中，我有 18 个子流域，编号为 910、950、1012、1087 等（在上面的示例中，为简单起见，只有两个子流域 910、950）。子流域包含有关流量 (Q) 的数据。
还有一个查询 table:
test_model <- c(1,1,2,2)
test_subbasin <- c(910,950,910,950)
Q_mean <- c(870,765,823,689)
FlowtestDF <- data.frame(test_model, test_subbasin, Q_mean)
此数据框包括每个模型和子流域参考期的流量平均值 (Q_mean)。我想从嵌套的 table 中取出每个 Q 并在查找 table 中找到匹配的型号和子流域并将其划分以获得标准化的流量 Q_st.
fun_st <- function(x, y=FlowtestDF) {
x$Q_st <- x$Q/y$Q_mean
x <- x
}
testresult <- lapply(Flowtestlist, lapply, fun_st)
没用。据我了解，该函数无法在查找 table（模型和子流域）中找到所需数字的适当位置。我怎样才能做到这一点，同时保持数据的嵌套 table 结构？
library(tidyr)
extr <- function(x){
a <- data.frame(x)
names(a) <- names(x)
a$test_model <- parent.frame()$i
a <- pivot_longer(a,setdiff(names(a),'test_model'),names_to = 'test_subbasin',values_to = 'Q')
a
}
to_df <- lapply(Flowtestlist,extr)
df <- do.call(rbind,to_df)
with_lookup <- merge(df,FlowtestDF,by =c('test_model','test_subbasin'))
with_lookup$Q_st <- with_lookup$Q/with_lookup$Q_mean
with_lookup
输出；
test_model test_subbasin Q Q_mean Q_st
<int> <chr> <dbl> <dbl> <dbl>
1 1 910 650 870 0.747
2 1 910 720 870 0.828
3 1 910 550 870 0.632
4 1 910 580 870 0.667
5 1 910 800 870 0.920
6 1 950 550 765 0.719
7 1 950 770 765 1.01
8 1 950 520 765 0.680
9 1 950 540 765 0.706
10 1 950 790 765 1.03
11 2 910 450 823 0.547
12 2 910 620 823 0.753
13 2 910 750 823 0.911
14 2 910 580 823 0.705
15 2 910 800 823 0.972
16 2 950 650 689 0.943
17 2 950 750 689 1.09
18 2 950 580 689 0.842
19 2 950 520 689 0.755
20 2 950 890 689 1.29
下面将导出所需的输出...
df <- data.frame(test_subbasin = unlist(Flowtestlist), ref = names(unlist(Flowtestlist)))
df$Q_st <- df$test_subbasin / FlowtestDF$Q_mean[match(gsub("\..*", "", df$ref), FlowtestDF$test_subbasin)]
df
# test_subbasin ref Q_st
# 1 650 910.Q1 0.7471264
# 2 720 910.Q2 0.8275862
# 3 550 910.Q3 0.6321839
# 4 580 910.Q4 0.6666667
# 5 800 910.Q5 0.9195402
# 6 550 950.Q1 0.7189542
# 7 770 950.Q2 1.0065359
# 8 520 950.Q3 0.6797386
# 9 540 950.Q4 0.7058824
# 10 790 950.Q5 1.0326797
# 11 450 910.Q1 0.5172414
# 12 620 910.Q2 0.7126437
# 13 750 910.Q3 0.8620690
# 14 580 910.Q4 0.6666667
# 15 800 910.Q5 0.9195402
# 16 650 950.Q1 0.8496732
# 17 750 950.Q2 0.9803922
# 18 580 950.Q3 0.7581699
# 19 520 950.Q4 0.6797386
# 20 890 950.Q5 1.1633987
你在找这个吗？
Map(\(x, y) lapply(y[match(x$test_subbasin, names(y))], \(i) i / x$Q_mean),
split(FlowtestDF, FlowtestDF$test_model),
Flowtestlist)
# $`1`
# $`1`$`910`
# Q
# 1 0.7471264
# 2 0.9411765
# 3 0.6321839
# 4 0.7581699
# 5 0.9195402
#
# $`1`$`950`
# Q
# 1 0.6321839
# 2 1.0065359
# 3 0.5977011
# 4 0.7058824
# 5 0.9080460
#
#
# $`2`
# $`2`$`910`
# Q
# 1 0.5467801
# 2 0.8998549
# 3 0.9113001
# 4 0.8417997
# 5 0.9720535
#
# $`2`$`950`
# Q
# 1 0.7897934
# 2 1.0885341
# 3 0.7047388
# 4 0.7547170
# 5 1.0814095
注意：如果您（仍在）使用 R<4.1，而不是例如\(x, y) 使用 function(x, y).
如果数据位于平面数据框中，则处理起来会更容易。如果出于某种原因您必须将数据框保持在嵌套结构中，您可以再次拆分它。
library(dplyr)
library(purrr)
map_df(Flowtestlist, ~bind_rows(., .id = 'test_subbasin'), .id = 'test_model') %>%
type.convert(as.is = TRUE) %>%
left_join(FlowtestDF, by = c('test_subbasin', 'test_model')) %>%
mutate(Q_st = Q/Q_mean) %>%
split(.$test_model) %>%
map(~.x %>% select(Q, Q_st) %>% split(.x$test_subbasin))
#$`1`
#$`1`$`910`
# Q Q_st
#1 650 0.7471264
#2 720 0.8275862
#3 550 0.6321839
#4 580 0.6666667
#5 800 0.9195402
#$`1`$`950`
# Q Q_st
#6 550 0.7189542
#7 770 1.0065359
#8 520 0.6797386
#9 540 0.7058824
#10 790 1.0326797
#$`2`
#$`2`$`910`
# Q Q_st
#11 450 0.5467801
#12 620 0.7533414
#13 750 0.9113001
#14 580 0.7047388
#15 800 0.9720535
#$`2`$`950`
# Q Q_st
#16 650 0.9433962
#17 750 1.0885341
#18 580 0.8417997
#19 520 0.7547170
#20 890 1.2917271
您好，我有一堆关于 streamflow(Q) 的水文数据，我想对其进行标准化。数据存储在一个大的 嵌套 table 中，布局如下所示，我需要保留 :
Flowtestlist <- list(list("910" = data.frame( Q=c(650, 720, 550, 580, 800)),
"950" = data.frame( Q=c(550, 770, 520, 540, 790))),
list ("910" = data.frame( Q=c(450, 620, 750, 580, 800)),
"950" = data.frame( Q=c(650, 750, 580, 520, 890))))
我有级别 [[1]] 和 [[2]]，实际上，我有 9 个级别，这些也是型号。在每个模型中，我有 18 个子流域，编号为 910、950、1012、1087 等（在上面的示例中，为简单起见，只有两个子流域 910、950）。子流域包含有关流量 (Q) 的数据。
还有一个查询 table:
test_model <- c(1,1,2,2)
test_subbasin <- c(910,950,910,950)
Q_mean <- c(870,765,823,689)
FlowtestDF <- data.frame(test_model, test_subbasin, Q_mean)
此数据框包括每个模型和子流域参考期的流量平均值 (Q_mean)。我想从嵌套的 table 中取出每个 Q 并在查找 table 中找到匹配的型号和子流域并将其划分以获得标准化的流量 Q_st.
fun_st <- function(x, y=FlowtestDF) {
x$Q_st <- x$Q/y$Q_mean
x <- x
}
testresult <- lapply(Flowtestlist, lapply, fun_st)
没用。据我了解，该函数无法在查找 table（模型和子流域）中找到所需数字的适当位置。我怎样才能做到这一点，同时保持数据的嵌套 table 结构？
library(tidyr)
extr <- function(x){
a <- data.frame(x)
names(a) <- names(x)
a$test_model <- parent.frame()$i
a <- pivot_longer(a,setdiff(names(a),'test_model'),names_to = 'test_subbasin',values_to = 'Q')
a
}
to_df <- lapply(Flowtestlist,extr)
df <- do.call(rbind,to_df)
with_lookup <- merge(df,FlowtestDF,by =c('test_model','test_subbasin'))
with_lookup$Q_st <- with_lookup$Q/with_lookup$Q_mean
with_lookup
输出；
test_model test_subbasin Q Q_mean Q_st
<int> <chr> <dbl> <dbl> <dbl>
1 1 910 650 870 0.747
2 1 910 720 870 0.828
3 1 910 550 870 0.632
4 1 910 580 870 0.667
5 1 910 800 870 0.920
6 1 950 550 765 0.719
7 1 950 770 765 1.01
8 1 950 520 765 0.680
9 1 950 540 765 0.706
10 1 950 790 765 1.03
11 2 910 450 823 0.547
12 2 910 620 823 0.753
13 2 910 750 823 0.911
14 2 910 580 823 0.705
15 2 910 800 823 0.972
16 2 950 650 689 0.943
17 2 950 750 689 1.09
18 2 950 580 689 0.842
19 2 950 520 689 0.755
20 2 950 890 689 1.29
下面将导出所需的输出...
df <- data.frame(test_subbasin = unlist(Flowtestlist), ref = names(unlist(Flowtestlist)))
df$Q_st <- df$test_subbasin / FlowtestDF$Q_mean[match(gsub("\..*", "", df$ref), FlowtestDF$test_subbasin)]
df
# test_subbasin ref Q_st
# 1 650 910.Q1 0.7471264
# 2 720 910.Q2 0.8275862
# 3 550 910.Q3 0.6321839
# 4 580 910.Q4 0.6666667
# 5 800 910.Q5 0.9195402
# 6 550 950.Q1 0.7189542
# 7 770 950.Q2 1.0065359
# 8 520 950.Q3 0.6797386
# 9 540 950.Q4 0.7058824
# 10 790 950.Q5 1.0326797
# 11 450 910.Q1 0.5172414
# 12 620 910.Q2 0.7126437
# 13 750 910.Q3 0.8620690
# 14 580 910.Q4 0.6666667
# 15 800 910.Q5 0.9195402
# 16 650 950.Q1 0.8496732
# 17 750 950.Q2 0.9803922
# 18 580 950.Q3 0.7581699
# 19 520 950.Q4 0.6797386
# 20 890 950.Q5 1.1633987
你在找这个吗？
Map(\(x, y) lapply(y[match(x$test_subbasin, names(y))], \(i) i / x$Q_mean),
split(FlowtestDF, FlowtestDF$test_model),
Flowtestlist)
# $`1`
# $`1`$`910`
# Q
# 1 0.7471264
# 2 0.9411765
# 3 0.6321839
# 4 0.7581699
# 5 0.9195402
#
# $`1`$`950`
# Q
# 1 0.6321839
# 2 1.0065359
# 3 0.5977011
# 4 0.7058824
# 5 0.9080460
#
#
# $`2`
# $`2`$`910`
# Q
# 1 0.5467801
# 2 0.8998549
# 3 0.9113001
# 4 0.8417997
# 5 0.9720535
#
# $`2`$`950`
# Q
# 1 0.7897934
# 2 1.0885341
# 3 0.7047388
# 4 0.7547170
# 5 1.0814095
注意：如果您（仍在）使用 R<4.1，而不是例如\(x, y) 使用 function(x, y).
如果数据位于平面数据框中，则处理起来会更容易。如果出于某种原因您必须将数据框保持在嵌套结构中，您可以再次拆分它。
library(dplyr)
library(purrr)
map_df(Flowtestlist, ~bind_rows(., .id = 'test_subbasin'), .id = 'test_model') %>%
type.convert(as.is = TRUE) %>%
left_join(FlowtestDF, by = c('test_subbasin', 'test_model')) %>%
mutate(Q_st = Q/Q_mean) %>%
split(.$test_model) %>%
map(~.x %>% select(Q, Q_st) %>% split(.x$test_subbasin))
#$`1`
#$`1`$`910`
# Q Q_st
#1 650 0.7471264
#2 720 0.8275862
#3 550 0.6321839
#4 580 0.6666667
#5 800 0.9195402
#$`1`$`950`
# Q Q_st
#6 550 0.7189542
#7 770 1.0065359
#8 520 0.6797386
#9 540 0.7058824
#10 790 1.0326797
#$`2`
#$`2`$`910`
# Q Q_st
#11 450 0.5467801
#12 620 0.7533414
#13 750 0.9113001
#14 580 0.7047388
#15 800 0.9720535
#$`2`$`950`
# Q Q_st
#16 650 0.9433962
#17 750 1.0885341
#18 580 0.8417997
#19 520 0.7547170
#20 890 1.2917271