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

Question

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

我正在使用赫尔辛基地区旅行时间矩阵 2018，这是由赫尔辛基大学的一个研究小组 Digital Geography Lab 提供的数据集。该数据使用赫尔辛基首都地区的广义地图，在 250 x 250 米的单元格（在我的代码 grid_f）中计算地图中所有单元格之间的旅行时间（网格 ID 称为 YKR_ID，n=13231）公共交通、私家车、自行车和步行。计算存储在分隔的 .txt 文件中，这是一个文本文件，用于记录到特定单元格 ID 的所有行程时间。数据可供下载at this website, under "Download the data"。注意，解压后的数据大小为 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）可视化这张 250x250 米的赫尔辛基地区地图，用于一种出行模式，即私家车，使用任何可能的 13231 小区 ID，如果用户愿意，可以重复使用。因此，数据帧获取尽可能快速和高效是很重要的。对于这个问题，让我们专注于从外部文件中获取和处理数据，并且只使用一个特定的 id 值。

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

• 我需要浏览所有 13231 Travel Time Matrix 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_ids 反复运行。

#### 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_sl_t、car_sl_t .

我当前的 lapply() 和 data.table::fread() 解决方案大约需要 2-3 分钟才能完成。我觉得这已经是一个不错的成就了，但是我忍不住想有更好更快的方法来完成这个。到目前为止，我已经尝试了以下替代方法：

• 传统的 for 循环：这显然是一个缓慢的解决方案
• 我试图自学更多关于 R 中矢量化函数的知识，但这并没有导致任何结果。 Used this link
• 试图涉足with() 不成功using this SO question, inspired by this SO question
• 查看了包 parallel，但由于我使用的是 Windows 环境而最终没有使用它
• 尝试使用 apply() 和 sapply() 找到解决此问题的替代方法，但没有任何值得注意的结果。

至于为什么我没有对ggplot2::fortify 之前的数据进行所有这些操作，我只是觉得使用 SpatialPolygonsDataFrame 很麻烦。

感谢您的宝贵时间。

Answer 1

每当我想弄清楚如何提高我的 R 的性能时 功能上，我一般采用如下方式。首先，我寻找任何 可能是不必要的函数调用或识别多个位置的函数调用 函数调用可以简化为一个。然后，我在我的 通过对每个代码进行基准测试会导致最大时间损失的代码 分开部分。这可以使用microbenchmark package 轻松完成。

例如，我们可以询问是否有更好的性能 管道（例如%>%）。

# 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 package 加快速度 尽管您需要将 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")