使用 while 循环提高速度：在 R 中找到多个感染链

Question

我最近问了一个关于提高代码性能的问题 (Faster method than "while" loop to find chain of infection in R)。

背景： 我正在分析存储疾病模拟模型输出的数据的大型表（300 000 - 500 000 行）。在该模型中，景观中的动物会感染其他动物。例如，在下图的示例中，动物a1 会感染景观中的每一个动物，并且感染会从一个动物转移到另一个动物，从而形成感染“链”。

在我最初的问题中，我询问如何输出与动物“d2”的“感染链”相对应的 data.frame（见下文，以绿色勾勒，以说明一个“链”）。建议解决方案适用于一种动物。

实际上，我需要计算大约 400 只动物的链，对应于所有动物的一个子集（allanimals 表）。

我已经包含了一个指向 example dataset 的链接，该链接足够大，可以玩。

这是一条链的代码，从动物 5497370 开始，请注意，我对上一个问题的列名稍作更改，并更新了代码！

代码：

allanimals <- read.csv("https://www.dropbox.com/s/0o6w29lz8yzryau/allanimals.csv?raw=1", 
                       stringsAsFactors = FALSE)


# Here's an example animal
ExampleAnimal <- 5497370


ptm <- proc.time()

allanimals_ID <- setdiff(unique(c(allanimals$ID, allanimals$InfectingAnimal_ID)), -1)

infected <- rep(NA_integer_, length(allanimals_ID))

infected[match(allanimals$ID, allanimals_ID)] <-
  match(allanimals$InfectingAnimal_ID, allanimals_ID)

path <- rep(NA_integer_, length(allanimals_ID))
curOne <- match(ExampleAnimal, allanimals_ID)
i <- 1
while (!is.na(nextOne <- infected[curOne])) {
  path[i] <- curOne
  i <- i + 1
  curOne <- nextOne
}

chain <- allanimals[path[seq_len(i - 1)], ]
chain

proc.time() - ptm

# check it out
chain

我想为“sel.set”中的每个动物输出链：

sel.set <- allanimals %>% 
  filter(HexRow < 4 & Year == 130) %>% 
  pull("ID")

如果可能，我想将每个“链”data.frame 存储为长度 = 链数的列表。

Answer 1

所以我将返回索引以访问数据帧而不是所有数据帧子集。如果您想对数据框子集执行其他操作，您只需使用 lapply(test, function(path) allanimals[path, ]) 或在 lapply 中使用更复杂的函数。

人们可以只考虑lapply 针对一种动物的解决方案：

get_path <- function(animal) {
  curOne <- match(animal, allanimals_ID)
  i <- 1
  while (!is.na(nextOne <- infected[curOne])) {
    path[i] <- curOne
    i <- i + 1
    curOne <- nextOne
  }

  path[seq_len(i - 1)]
}

sel.set <- allanimals %>% 
  filter(HexRow < 4 & Year == 130) %>% 
  pull("ID")

system.time(
  test <- lapply(sel.set, get_path)
) # 0.66 seconds

我们可以将此函数重写为递归函数（这将介绍我的第三个也是最后一个解决方案）。

system.time(
  sel.set.match <- match(sel.set, allanimals_ID)
) # 0

get_path_rec <- function(animal.match) {
  `if`(is.na(nextOne <- infected[animal.match]), 
       NULL, 
       c(animal.match, get_path_rec(nextOne)))
}

system.time(
  test2 <- lapply(sel.set.match, get_path_rec)
) # 0.06
all.equal(test2, test) # TRUE

此解决方案的速度提高了 10 倍。不过我不明白为什么。

为什么我想写一个递归函数？我认为您可能有很多情况，例如，您想要获取 animalX 和 animalY 的路径，其中 animalY 感染了 animalX。所以在计算animalX的路径时，你会重新计算animalY的所有路径。 所以我想使用 memoization 来存储已经计算的结果，并且 memoization 可以很好地与递归函数配合使用。所以我的最后一个解决方案：

get_path_rec_memo <- memoise::memoize(get_path_rec)
memoise::forget(get_path_rec_memo)

system.time(
  test3 <- lapply(sel.set.match, get_path_rec_memo)
) # 0.12
all.equal(test3, test) # TRUE

不幸的是，这比第二种解决方案要慢。希望它对整个数据集有用。