用应用系列中的函数替换 r 中的 for 循环（大型数据集）答案

【问题标题】：replace for loop in r with function from apply family (large data sets)用应用系列中的函数替换 r 中的 for 循环（大型数据集）
【发布时间】：2018-01-09 20:45:13
【问题描述】：

我正在研究一个问题，我们试图为时间序列具有（+150 个每日点）的大量对（+40 000）创建时间序列差异

每一行代表我们要比较的两个人

pairs = data.frame("number" = c(1,2,3,4),
                   "name1" = c("A","B","C","D"),
                   "name2" = c("B","D","D","A")
                               )

pairs$name1 <- as.character(pairs$name1)   
pairs$name2 <- as.character(pairs$name2)

每一行代表特定个体的时间序列数据

ts = data.frame("name" = c("A","B","C","D"),
                        "day1" = c(10,12,54,13),
                        "day2" = c(2,8,47,29),
                        "day3" = c(1,5,14,36)
                             )
ts$name <- as.character(ts$name)

我有以下 R 代码，其目标是为每对个体（在我的示例中为 4 个）创建一个新数据框，该数据框的每日时间序列与 ts 数据框不同。这很有效，但是当我尝试在我的真实数据集上运行它时非常慢，其中对有 40 000 行和 ts 大约 150 列。任何人都知道我如何加快速度？我尝试使用 lapply 但不知道如何创建差异并将其存储在新的时间序列中。谢谢！！

diffs<-data.frame(matrix(ncol=ncol(ts)))
colnames(diffs)<-colnames(ts)

  for (row in 1:nrow(pairs)){
      row1<-ts[(ts$name==pairs[row,"name1"]),]
      row2<-ts[(ts$name==pairs[row,"name2"]),]
      difference<-rbind(row1,row2)
      difference[3,1]<-pairs[row,"number"]
      difference[3,2:ncol(difference)]<-difference[1,2:ncol(difference)]-difference[2,2:ncol(difference)]
      diffs<-rbind(diffs,difference[3,])
                   }

【问题讨论】：

标签： r for-loop lapply

【解决方案1】：

先说几句：

i) data.frame() 有一个参数stringsAsFactors，您可以将其设置为FALSE，即：

pairs = data.frame(
    "number" = c(1,2,3,4),
    "name1" = c("A","B","C","D"),
    "name2" = c("B","D","D","A"),
    stringsAsFactors = FALSE
)

ii) 加速您的代码实际上并不是用apply 替换for-loop 的问题，而是数据结构和处理效率的问题。依靠在 C++ 而不是 R 中内部循环的包/函数或自己编写 C++ 代码将为您带来最大的提升。

iii) 我还将在这里提供一个更大的虚拟示例，以便您和其他人可以更轻松地测试和比较时间：

# all combination of LETTERS, including identity pairs like A~A
pairs = cbind.data.frame(
    "number" = seq(1, 676),
    setNames(expand.grid(LETTERS, LETTERS), nm = c("name1", "name2"))
)
# expand.grid produces factor columns
pairs$name1 <- as.character(pairs$name1)
pairs$name2 <- as.character(pairs$name2)

ts = cbind.data.frame(
    "name" = LETTERS,
    matrix(sample.int(100, 150*26, replace = TRUE), ncol = 150),
    stringsAsFactors = FALSE
)
names(ts)[-1] <- paste0("day", names(ts)[-1])

iv) 你的循环的改进版本可能如下所示：

# initialize full matrix (since the ID is a number too), allocating necessary memory
diffs2 <- matrix(0, ncol = ncol(ts), nrow = nrow(pairs))
colnames(diffs2) <- colnames(ts)
# first column is given
diffs2[, 1] <- pairs$number

for (row in 1:nrow(pairs)) {
  row1 <- as.vector(as.matrix(ts[ts$name==pairs[row,"name1"], -1]))
  row2 <- as.vector(as.matrix(ts[ts$name==pairs[row,"name2"], -1]))
  diffs2[row, -1] <- row1 - row2
}

这已经比你的速度快了好几倍，但说明了 时间序列 有一个 data.frame 对象的尴尬，它应该是一个允许更直接/更有效地处理数字数据的类的对象（有几个包提供时间序列类）。

现在使用dplyr 和tidyr 得到一个仍然相当简单但相当快的答案：

# simple way of measuring time
start <- Sys.time()

xx <- tidyr::gather(ts, key = "day", value = "value", 2:151)
yy <- dplyr::left_join(pairs, xx, by = c("name1" = "name"))
zz <- dplyr::left_join(yy, xx, by = c("name2" = "name", "day" = "day"))
res <- dplyr::mutate(zz, diff = value.x - value.y)

end <- Sys.time()

duration <- end - start

持续时间

0.06700397秒的时间差

您也可以尝试前两个答案中的方法，很明显mapply 的解决方案会很慢，而data.table 的解决方案还没有完全工作，而且看起来更慢更复杂。

【讨论】：

为什么还没有完全工作？对我来说也不复杂，操作非常清晰简单
您是否尝试过我的上述 pair 和 ts 的虚拟数据示例？
RolandASc 当我将它应用到我的大型数据集时，您使用 tidyr 和 dplyr 的解决方案非常优雅且速度极快！谢谢！

【解决方案2】：

我有一个 data.table 解决方案可以提供帮助。想法是切换到长格式以便能够使用分组操作（相当于应用）并创建置换列来进行配对：

name1idx <- unlist(lapply(pairs$name1,function(x){grep(x,ts$name)}))
name2idx <- unlist(lapply(pairs$name2,function(x){grep(x,ts$name)}))

plouf <-melt(setDT(ts),measure.vars = patterns("^day"),variable.name = "day")
plouf[,name1 := name[name1idx],by = day]
plouf[,value1 := value[name1idx],by = day]
plouf[,name2 := name[name2idx],by = day]
plouf[,value2 := value[name2idx],by = day]
plouf[,diff := value1 - value2]
plouf[,.(day,diff),by = .(name1,name2)]

    name1 name2  day diff
 1:     A     B day1   -2
 2:     A     B day2   -6
 3:     A     B day3   -4
 4:     B     D day1   -1
 5:     B     D day2  -21
 6:     B     D day3  -31
 7:     C     D day1   41
 8:     C     D day2   18
 9:     C     D day3  -22
10:     D     A day1    3
11:     D     A day2   27
12:     D     A day3   35

name1idx和name1idx是ts$name对应pairs$name1和pairs$name2的索引。你可以这样拥有所有的对。

【讨论】：

嗨，丹尼斯，问题是 name2 列中的某些名称可能不在 name1 列中，例如，这对可能是 A 和 L 而不是 A 和 B。
我编辑了解决方案，因此它在任何情况下都应该可以工作。我想所有的名字都在 ts$name 中，也就是带有数据的 data.frame。我很想知道您将获得多少时间。告诉我们，如果它确实回答了问题，请不要忘记接受答案

【解决方案3】：

我正在寻找一种解决方案，其中列名的使用是动态的，并且除了name 之外没有其他列名可以使用。 mapply、dplyr 和 reshape2 已用于此解决方案。

# library(reshape2)
# A function which will filter value based on pairs
matchPair <- function(x, y){
  matchedRow <- ts %>% 
    filter(name == x | name == y) %>% 
    select(-name)

  data.frame(diff(as.matrix(matchedRow))) %>% 
    mutate(name = paste0(x, '~',y))
}

df.r <-do.call(rbind,mapply(matchPair, pairs$name1, pairs$name2,
               SIMPLIFY = FALSE))

# Row names are not meaningful. Hence remove those.
row.names(df.r) <- NULL

#Result
#> df.r
#  day1 day2 day3 name
#1    2    6    4  A~B
#2    1   21   31  B~D
#3  -41  -18   22  C~D
#4    3   27   35  D~A

【讨论】：