R中嵌套列表的有效摘要统计

我正在运行模拟研究，结果存储在嵌套列表结构中。列表的第一级代表模型生成的不同超参数。第二个级别是相同模型的复制数量（更改种子）。

在下面的示例中，我列出了由两个超参数（hyperpar1和hyperpar2）控制的模型的输出，其中两个都可以采用2个不同的值，从而导致结果模型具有4种不同的组合。此外，这4种可能的组合中的每一种都运行了两次（不同的种子），从而导致了8种可能的组合（如下图所示str(res, max = 2)）。最后，从模型（metric1和metric2）的每个可能迭代中恢复了两个性能指标。

我的问题是在我的真实数据中，迭代次数（列表的第二级）非常大（最多10000），并且在某些情况下超参数数量的全因数最多为2000。因此，取消上市的过程变得相当缓慢。

在下面，我列出了当前过程以及所需的输出，但同样，它相对较慢。特别是，当我取消列出所有内容时，有一部分是我将其放到一个大data.frame中，这花费了很长时间，但是我没有以更快的方式解决此问题。

res <-list(
  list(list(modeltype = "tree", time_iter = structure(0.7099, class = "difftime", units = "secs"),seed = 1, nobs = 75, hyperpar1 = 0.5, hyperpar2 = 0.5, metric1 = 0.4847, metric2 = 0.2576 ),
       list(modeltype = "tree", time_iter = structure(0.058 , class = "difftime", units = "secs"),seed = 2, nobs = 75, hyperpar1 = 0.5, hyperpar2 = 0.5, metric1 = 0.4013, metric2 = 0.2569 )), 
  list(list(modeltype = "tree", time_iter = structure(0.046 , class = "difftime", units = "secs"),seed = 1, nobs = 75, hyperpar1 = 0.8, hyperpar2 = 0.5, metric1 = 0.4755, metric2 = 0.2988 ), 
       list(modeltype = "tree", time_iter = structure(0.0474, class = "difftime", units = "secs"),seed = 2, nobs = 75, hyperpar1 = 0.8, hyperpar2 = 0.5, metric1 = 0.2413, metric2 = 0.2147 )), 
  list(list(modeltype = "tree", time_iter = structure(0.0502, class = "difftime", units = "secs"),seed = 1, nobs = 75, hyperpar1 = 0.5, hyperpar2 = 1  , metric1 = 0.7131, metric2 = 0.5024 ), 
       list(modeltype = "tree", time_iter = structure(2.9419, class = "difftime", units = "secs"),seed = 2, nobs = 75, hyperpar1 = 0.5, hyperpar2 = 1  , metric1 = 0.4254, metric2 = 0.2824 )), 
  list(list(modeltype = "tree", time_iter = structure(0.041 , class = "difftime", units = "secs"),seed = 1, nobs = 75, hyperpar1 = 0.8, hyperpar2 = 1  , metric1 = 0.6709, metric2 = 0.4092 ), 
       list(modeltype = "tree", time_iter = structure(0.0396, class = "difftime", units = "secs"),seed = 2, nobs = 75, hyperpar1 = 0.8, hyperpar2 = 1  , metric1 = 0.4585, metric2 = 0.4115 )))


hyperpar1   <-   c(0.5 , 0.8 ) 
hyperpar2   <-   c(0.5 , 1   )
expand.grid(hyperpar1 = hyperpar1, hyperpar2 = hyperpar2)

#   hyperpar1 hyperpar2
# 1       0.5       0.5
# 2       0.8       0.5
# 3       0.5       1.0
# 4       0.8       1.0

#List structure:
#The 4 elements represent the 4 combinations of the hyperparams
#Inside each of the 4 combinations of the hyperparams, 2 lists represent the 2 simulations (with different seeds)
str(res, max = 1)
#Finally, inside each of the final level (level=3) there is a list of 10 objects that are the results of each simulation
str(res, max = 2)

# List of 4
# $ :List of 2
# ..$ :List of 8
# ..$ :List of 8
# $ :List of 2
# ..$ :List of 8
# ..$ :List of 8
# $ :List of 2
# ..$ :List of 8
# ..$ :List of 8
# $ :List of 2
# ..$ :List of 8
# ..$ :List of 8

#e.g Fist iteration of first model 
t(res[[1]][[1]])
# modeltype time_iter seed nobs hyperpar1 hyperpar2 metric1 metric2
# [1,] "tree"    0.7099    1    75   0.5       0.5       0.4847  0.2576 

解析列表

在以下代码中，我取消嵌套列表并将所有内容放入data.frame中。

#Unlist the nested structure of the list `res`
all_in_list <- lapply(1:length(res), function(i) {
     unlisting <- unlist(res[i],recursive = FALSE)
     to_df <- do.call(rbind, lapply(unlisting, as.data.frame))
     return(to_df)})

#Here is where averything get really really slow when the list is huge
all_in_df <- do.call(rbind, lapply(all_in_list, as.data.frame))

#   modeltype   time_iter seed nobs hyperpar1 hyperpar2 metric1 metric2
# 1      tree 0.7099 secs    1   75       0.5       0.5  0.4847  0.2576
# 2      tree 0.0580 secs    2   75       0.5       0.5  0.4013  0.2569
# 3      tree 0.0460 secs    1   75       0.8       0.5  0.4755  0.2988
# 4      tree 0.0474 secs    2   75       0.8       0.5  0.2413  0.2147
# 5      tree 0.0502 secs    1   75       0.5       1.0  0.7131  0.5024
# 6      tree 2.9419 secs    2   75       0.5       1.0  0.4254  0.2824
# 7      tree 0.0410 secs    1   75       0.8       1.0  0.6709  0.4092
# 8      tree 0.0396 secs    2   75       0.8       1.0  0.4585  0.4115

输出摘要统计

在下文中，我恢复了性能指标的均值和标准偏差，并在每个指标中添加了其子固定项以colname供日后识别（绘制目的）。

#auxiliar function to compute the metrics at aggregate level. 
foo_summary <- function(df ,
                        metrics =c("time_iter","metric1", "metric2") ,
                        by = c("nobs","hyperpar1", "hyperpar2", "modeltype"),
                        summary_function =  mean)
{
#compute the aggregate metrics  
out <-  as.data.frame(aggregate(
    x = df[metrics],
    by = df[by],
    FUN = summary_function, 
    na.rm = TRUE))
#rename conviniently the metric computed
oldnames <- colnames(out[metrics])
names(out)[match(oldnames,names(out))] <- paste(colnames(out[metrics]), 
                                                as.character(substitute(summary_function)),
                                                sep = "_")
return(out)
}



df_mean <- foo_summary(df = all_in_df, 
            metrics =c("time_iter","metric1", "metric2"),
            by = c("nobs","hyperpar1", "hyperpar2", "modeltype"),
            summary_function =  mean)


df_sd <- foo_summary(df = all_in_df, 
            metrics =c("time_iter","metric1", "metric2"),
            by = c("nobs","hyperpar1", "hyperpar2", "modeltype"),
            summary_function =  sd)

final_df <- merge(df_mean,df_sd )

最后是所需的输出。

# nobs hyperpar1 hyperpar2 modeltype time_iter_mean metric1_mean metric2_mean time_iter_sd metric1_sd   metric2_sd
# 1   75       0.5       0.5      tree   0.38395 secs      0.44300      0.25725 0.4609629107 0.05897271 0.0004949747
# 2   75       0.5       1.0      tree   1.49605 secs      0.56925      0.39240 2.0447406792 0.20343462 0.1555634919
# 3   75       0.8       0.5      tree   0.04670 secs      0.35840      0.25675 0.0009899495 0.16560441 0.0594676803
# 4   75       0.8       1.0      tree   0.04030 secs      0.56470      0.41035 0.0009899495 0.15018948 0.0016263456