Use a lookup table with a nested list

user_14539337 0
Viewed 113

Hi I have a bunch of hydrological data on streamflow(Q) that I want to standardize. Data is stored an a large nested table with a layout like the one below that I need to keep:

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))))

I have levels [[1]] and [[2]], in reality, I have 9 of them and those are also model numbers. Within each model I have 18 subbasins numbered 910, 950, 1012, 1087 etc (in the example above just two subbasins 910, 950 for simplicity). The subbasins contain data on streamflow (Q).

There's also a lookup 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)

This data frame includes streamflow means (Q_mean) for the reference period for each model and subbasin. I want to take each Q from the nested table and find the matching model number and subbasin in the lookup table and divide it to get the standardized streamflow Q_st.

fun_st <- function(x, y=FlowtestDF) {
  x$Q_st <- x$Q/y$Q_mean
  x <- x
}

testresult <- lapply(Flowtestlist, lapply, fun_st)

It doesn't work. As I understand the function can't find the appropriate location of the needed number in the lookup table (model and subbasin). How can I make this work, while keeping the nested table structure of the data?

nested-lists r lookup list
4 Answers

Are you looking for this?

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

Note: If you're (still) using R<4.1, instead of e.g. \(x, y) use function(x, y).

user_65740380 
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

output;

   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
user_145870410

The following will derive the required output ...

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
user_24496560

It is easier to do the processing if you have data in a flat dataframe. If for some reason you have to keep the dataframe in nested structure you may split it again.

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
user_39629140
Related