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

Question

我正在构建一个闪亮的应用程序，在这个应用程序中，需要使用大量的外部源文件一次又一次地计算一个大型ggplot2增强的数据格式。我正在寻找最快和最有效的方法来做到这一点。在下一段中，我将进一步研究主题和代码，并提供输入数据以使您能够提供友好的帮助。

我正在使用赫尔辛基地区旅行时间矩阵2018年，这是一个由赫尔辛基大学研究小组数字地理实验室提供的数据集。该数据使用赫尔辛基首都地区的通用地图，在250×250米的单元格内(在我的代码grid_f中)，通过公共交通、私家车、自行车和步行计算地图中所有单元格之间的旅行时间(网格ids称为YKR_ID，n=13231)。计算存储在分隔的.txt文件中，这是一个用于所有到达特定单元格id的旅行时间的文本文件。这些数据可供下载在这个网站，在“下载数据”下。注:解压缩后的数据大小为13.8GB。

下面是从数据集中的文本文件中选择的内容：

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)这幅250×250米赫尔辛基地区地图，为一种旅行模式，私家车，使用任何可能的13231手机ids，如果用户需要反复。因此，重要的是数据获取尽可能快和高效。对于这个问题，让我们集中精力从外部文件中获取和处理数据，并且只使用一个特定的id值。

简而言之，在我制作了250×250米网格空间数据集的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")

dataframe result应该有包含12个变量的66155行，每个250×250米网格单元有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()，但没有成功，用这个问题，受到这个问题的启发
• 查看了包parallel，但由于我使用的Windows环境，最终没有使用它
• 试图用apply()和sapply()找到解决这一问题的替代方法，但没有什么值得注意的地方。

至于为什么我没有对ggplot2::fortify之前的数据做这一切，我只是觉得使用SpatialPolygonsDataFrame很麻烦。

谢谢您抽时间见我。

Answer 1

当我试图找出如何提高我的R函数的性能时，我通常使用以下方法。首先，我查找任何可能是不必要的函数调用，或者识别多个函数调用可以简化为一个的位置。然后，我寻找代码中的位置，通过分别对每个部分进行基准测试，这些地方会招致最大的时间损失。使用套餐可以很容易地做到这一点。

例如，我们可以问，是否使用管道(例如%>%)可以获得更好的性能。

# 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

在您的示例中，虽然需要将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")