在 R 中，尽可能高效地从数千个外部文件中计算数据帧

Question

我正在构建一个 Shiny 应用程序，其中需要使用大量外部源文件一遍又一遍地计算大型 ggplot2 强化数据帧。我正在寻找最快，最有效的方法来做到这一点。在下面的段落中，我将更深入地研究我到目前为止拥有的主题和代码，并提供输入数据以使您能够获得善意的帮助。

我使用的是赫尔辛基地区旅行时间矩阵2018，这是赫尔辛基大学研究小组数字地理实验室提供的数据集。此数据使用赫尔辛基首都地区的广义地图，在 250 x 250 米单元格中(在我的代码grid_f中(，以计算地图中所有单元格之间的旅行时间(网格 ID 称为YKR_ID，n=13231(乘坐公共交通工具、私家车、自行车和步行。计算存储在分隔.txt文件中，一个文本文件用于特定单元ID的所有行程时间。数据可在本网站的"下载数据"下下载。注意，解压缩的数据大小为 13.8 GB。

以下是数据集中文本文件中的选择：

from_id;to_id;walk_t;walk_d;bike_s_t;bike_f_t;bike_d;pt_r_tt;pt_r_t;pt_r_d;pt_m_tt;pt_m_t;pt_m_d;car_r_t;car_r_d;car_m_t;car_m_d;car_sl_t
5785640;5785640;0;0;-1;-1;-1;0;0;0;0;0;0;-1;0;-1;0;-1
5785641;5785640;48;3353;51;32;11590;48;48;3353;48;48;3353;22;985;21;985;16
5785642;5785640;50;3471;51;32;11590;50;50;3471;50;50;3471;22;12167;21;12167;16
5785643;5785640;54;3764;41;26;9333;54;54;3764;54;54;3764;22;10372;21;10370;16
5787544;5785640;38;2658;10;7;1758;38;38;2658;38;38;2658;7;2183;7;2183;6

我的兴趣是可视化(ggplot2(这张 250x250m 的赫尔辛基地区地图，用于一种旅行模式，即私家车，使用任何可能的 13231 个单元格 ID，如果用户愿意，可以重复。因此，数据帧提取必须尽可能快速和高效。对于这个问题，让我们专注于从外部文件获取和处理数据，并仅使用一个特定的 id 值。

简而言之，在我制作了 250 x 250 米网格空间数据集grid_f的ggplot2::fortify()版本之后，

• 我需要扫描所有 13231 旅行时间矩阵 2018 文本文件
• 在每个文件中仅选取相关列(from_id、to_id、car_r_t、car_m_t、car_sl_t
(
• 在每个文件中使用from_id(在本例中为origin_id <- "5985086"(选择相关行
• 将生成的行连接到强化空间数据grid_f

我的代码如下：

# Libraries
library(ggplot2)
library(dplyr)
library(rgdal)
library(data.table)
library(sf)
library(sp)
# File paths. ttm_path is the folder which contains the unchanged Travel
# Time Matrix 2018 data from the research group's home page
ttm_path <- "HelsinkiTravelTimeMatrix2018"
gridpath <- "MetropAccess_YKR_grid_EurefFIN.shp"

#### Import grid cells
# use this CRS information throughout the app
app_crs <- sp::CRS("+init=epsg:3067")
# Read grid shapefile and transform
grid_f <- rgdal::readOGR(gridpath, stringsAsFactors = TRUE) %>%
sp::spTransform(., app_crs) %>%
# preserve grid dataframe data in the fortify
{dplyr::left_join(ggplot2::fortify(.),
as.data.frame(.) %>%
dplyr::mutate(id = as.character(dplyr::row_number() - 1)))} %>%
dplyr::select(-c(x, y))

此点上面的代码仅运行一次。下面的代码或多或少会用不同的origin_id一遍又一遍地运行。

#### Fetch TTM18 data
origin_id <- "5985086"
origin_id_num <- as.numeric(origin_id)
# column positions of columns from_id, to_id, car_r_t, car_m_t, car_sl_t
col_range <- c(1, 2, 14, 16, 18)
# grid_f as data.table version
dt_grid <- as.data.table(grid_f)
# Get filepaths of all of the TTM18 data. Remove metadata textfile filepath.
all_files <- list.files(path = ttm_path, 
pattern = ".txt$", 
recursive = TRUE, 
full.names = TRUE)
all_files <- all_files[-length(all_files)]
# lapply function
TTM18_fetch <- function(x, col_range, origin_id) {
res <- fread(x, select = col_range)
res <- subset(res, from_id == origin_id)
return(res)
}
# The part of the code that needs to be fast and efficient
result <- 
lapply(all_files, FUN = TTM18_fetch, col_range, origin_id_num) %>%
data.table::rbindlist(., fill = TRUE) %>%
data.table::merge.data.table(dt_grid, ., by.x = "YKR_ID", by.y = "to_id")

数据帧result应有 66155 行(包含 12 个变量(，每个 250x250 米网格单元对应 5 行。这些列分别是YKR_ID、long、lat、order、hole、piece、id、group、from_id、car_r_t、car_m_t、car_sl_t。

我当前的lapply()和data.table::fread()解决方案大约需要 2-3 分钟才能完成。我认为这已经是一个很好的成就，但我忍不住认为有更好更快的方法来完成这项工作。到目前为止，我已经尝试了这些替代我现在拥有的替代方案：

• 传统的 for 循环：这显然是一个缓慢的解决方案
• 我试图自学更多关于R中的矢量化函数的知识，但这并没有带来任何结果。使用了此链接
• 试图涉足with()，但未能成功使用这个SO问题，灵感来自这个SO问题
• 查看了包parallel，但由于我正在使用的 Windows 环境，最终没有使用它
• 试图找到其他方法来解决这个问题apply()和sapply()但没有什么值得注意的。

至于为什么我在ggplot2::fortify之前没有对数据做所有这些，我只是发现使用空间多边形数据帧很麻烦。

谢谢你的时间。

Answer 1

每当我想弄清楚如何提高我的 R 的性能时 函数，我一般采用以下方法。首先，我寻找任何 函数调用可能是 unesscesary 或标识多个位置 函数调用可以简化为一个。然后，我在我的地方寻找地方 通过对每个代码进行基准测试而产生最大的时间损失的代码 部分分开。这可以使用microbenchmark轻松完成 包。

例如，我们可以问我们是否在有或没有的情况下获得更好的性能管道(例如%>%(。

# hint... piping is always slower
library(magrittr)
library(microbenchmark)
microbenchmark(
pipe = iris %>% subset(Species=='setosa'),
no_pipe = subset(iris, Species=='setosa'),
times = 200)

Unit: microseconds
expr     min      lq     mean   median       uq      max neval cld
pipe 157.518 196.739 308.1328 229.6775 312.6565 2473.582   200   b
no_pipe  84.894 116.386 145.4039 126.1950 139.4100  612.492   200  a 

在这里，我们发现在没有管道的情况下删除子集data.frame执行时间将近一半！

接下来，我确定每个地方的净时间惩罚通过将执行时间乘以总次数进行基准测试 需要执行。对于净时间惩罚最大的区域， 我尝试用更快的功能替换它和/或尝试减少总数 需要执行的次数。

TLDR

在您的情况下，您可以使用fst包加快速度 尽管您需要将CSV文件转换为FST文件。

# before
TTM18_fetch <- function(x, col_range, origin_id) {
res <- data.table::fread(x, select = col_range)
res <- subset(res, from_id == origin_id)
return(res)
}
# after (NB x needs to be a fst file)
col_range <- c('from_id', 'to_id', 'car_r_t', 'car_m_t', 'car_sl_t')
TTM18_fetch <- function(x, col_range, origin_id) {
res <- fst::read_fst(path = x,
columns = col_range,
as.data.table = TRUE)[from_id==origin_id]
return(res)
}

将 csv 文件转换为 fst

library(data.table)
library(fst)
ttm_path <- 'REPLACE THIS'
new_ttm_path <- 'REPLACE THIS'
# Get filepaths of all of the TTM18 data. Remove metadata textfile filepath.
all_files <- list.files(path = ttm_path, 
pattern = ".txt$", 
recursive = TRUE, 
full.names = TRUE)
all_files <- all_files[-grepl('[Mm]eta', all_files)]
# creating new file paths and names for fst files
file_names <- list.files(path = ttm_path, 
pattern = ".txt$", 
recursive = TRUE)
file_names <-  file_names[-grepl('[Mm]eta', file_names)]
file_names <- gsub(pattern = '.csv$',
replacement = '.fst', 
x =file_names)
file_names <- file.path(new_ttm_path, file_names)
# csv to fst conversion
require(progress) # this will help you create track of things
pb <- progress_bar$new(
format = " :what [:bar] :percent eta: :eta",
clear = FALSE, total = length(file_names), width = 60)

# an index file to store from_id file locations
from_id_paths <- data.table(from_id = numeric(), 
file_path = character())
for(i in seq_along(file_names)){
pb$tick(tokens = list(what = 'reading'))
tmp <- data.table::fread(all_files[i], key = 'from_id')
pb$update(tokens = list(what = 'writing'))
fst::write_fst(tmp,
compress = 50,  # less compressed files read faster
path = file_names[i] )  
pb$update(tokens = list(what = 'indexing'))
from_id_paths <- rbind(from_id_paths,  
data.table(from_id = unique(tmp$from_id),
file_path = file_names[i]))
}
setkey(from_id_paths, from_id)
write_fst(from_id_paths,
path =  file.path('new_ttm_path', 'from_id_index.fst'),
compress = 0)

这将是替代品

library(fst)
library(data.table)
new_ttm_path <- 'REPLACE THIS'
#### Fetch TTM18 data
origin_id <- "5985086"
origin_id_num <- as.numeric(origin_id)
# column positions of columns from_id, to_id, car_r_t, car_m_t, car_sl_t
col_range <- c('from_id', 'to_id', 'car_r_t', 'car_m_t', 'car_sl_t')
# grid_f as data.table version
dt_grid <- as.data.table(grid_f)

nescessary_files <- read_fst(path = file.path(new_ttm_path,
'from_id_index.fst'),
as.data.table = TRUE
)[from_id==origin_id,file_path]

TTM18_fetch <- function(x, col_range, origin_id) {
res <- fst::read_fst(path = x,
columns = col_range,
as.data.table = TRUE)[from_id==origin_id]
return(res)
}

result <-  rbindlist(lapply(nescessary_files, FUN = TTM18_fetch, col_range,  origin_id_num),
fill = TRUE)
result <- data.table::merge.data.table(dt_grid, result, by.x = "YKR_ID", by.y = "to_id")