在 R 中根据移动日期 window 缩放变量：脚本有效，但速度慢得令人无法接受。优化方法？ rstats
Scale variables over a moving date window in R: script works, but unacceptably slow. Ways to optimize? rstats
我有一个数据框，其中每一行代表特定日期特定类别的数据：
set.seed(1)
k <- 10
df <- data.frame(
name = c(rep('a',k), rep('b',k)),
date = rep(seq(as.Date('2017-01-01'),as.Date('2017-01-01')+k-1, 'days'),2),
x = runif(2*k,1,20),
y = runif(2*k,100,300)
)
View(df)
负责人：
head(df)
name date x y
1 a 2017-01-01 6.044665 286.9410
2 a 2017-01-02 8.070354 142.4285
3 a 2017-01-03 11.884214 230.3348
4 a 2017-01-04 18.255948 125.1110
5 a 2017-01-05 4.831957 153.4441
6 a 2017-01-06 18.069404 177.2228
结构：
str(df)
'data.frame': 20 obs. of 4 variables:
$ name: Factor w/ 2 levels "a","b": 1 1 1 1 1 1 1 1 1 1 ...
$ date: Date, format: "2017-01-01" "2017-01-02" "2017-01-03" "2017-01-04" ...
$ x : num 6.04 8.07 11.88 18.26 4.83 ...
$ y : num 287 142 230 125 153 ...
我需要在特定日期 window 缩放此数据的 x 和 y 变量。
我想出的脚本如下：
library(dplyr)
library(lubridate)
df2 <- df
moving_window_days <- 4
##Iterate over each row in df
for(i in 1:nrow(df)){
df2[i,] <- df %>%
##Give me only rows for 'name' on the current row
##which are within the date window of interest
filter(date <= date(df[i,"date"]) &
date >= date(df[i,"date"]) - moving_window_days &
name == df[i,"name"]
) %>%
##Now scale x and y on this date wondow
mutate(x = percent_rank(x),
y = percent_rank(y)
) %>%
##Get rid of the rest of the rows - leave only the row we are looking at
filter(date == date(df[i,"date"]))
}
它按预期工作（好吧，我最初想在移动中获得每个观察的百分位数 window，但缩放后的值就可以正常工作）
问题是真实的数据集要大得多：
'name' 列有 30 个本地 b运行ch 办事处'date' 是每个 b运行ch- 而不是
'x' 和 'y' 我有 6 个变量
- 搬家window是90天
我 运行 这个脚本基于真实数据，在 30,000 行中 它只能超过 5,000 在 4 小时内...
这是我第一次 运行 遇到这样的问题。
我确定我的脚本效率非常低（我确定是因为我不是 R 专家。我只是假设总有更好的方法）
有什么办法可以优化/改进这个脚本吗？
- 有什么方法可以 'purrrify'（使用
purrr 中的某些 map 函数）？
- 嵌套数据框？
nest()？认为这是一个解决方案...不确定如何实施...
我能做些什么来以不同的方式解决这个问题？
您可以做的一件事是并行处理。我为此使用 future 包。这可能会惹恼一些人，他们可能认为它是 hack，因为 future 包的目的是......好吧......对于未来（或者 "promises" 如果你是前端开发人员）。这种方法很挑剔，但效果很好。
library(future)
# Create a function that iterates over each row in the df:
my_function <- function(df, x) {
x <- df
for(i in 1:nrow(df)){
x[i, ] <- df %>%
##Give me only rows for 'name' on the current row
##which are within the date window of interest
filter(date <= date(df[i,"date"]) &
date >= date(df[i,"date"]) - moving_window_days &
name == df[i,"name"]
) %>%
##Now scale x and y on this date wondow
mutate(x = percent_rank(x),
y = percent_rank(y)
) %>%
##Get rid of the rest of the rows - leave only the row we are looking at
filter(date == date(df[i,"date"]))
}
return(x)
}
plan(multiprocess) # make sure to always include this in a run of the code.
# Divide df evenly into three separate dataframes:
df1 %<-% my_function(df[1:7, ], df1)
df2 %<-% my_function(df = df[(8 - moving_window_days):14, ], df2) # But from here on out, go back 4 days to include that data in the moving average calculation.
df3 %<-% my_function(df = df[(15 - moving_window_days):20, ], df3)
# See if your computer is able to split df into 4 or 5 separate dataframes.
# Now bind the dataframes together, but get the indexing right:
rbind(df1, df2[(nrow(df2) - 6):nrow(df2), ], df3[(nrow(df3) - 5):nrow(df3), ])
并行处理是优化代码以提高效率的众多方法之一。过去，这种技术大大 加快了我的代码速度。它已将 运行 节目的时间从一天半缩短到 3 或 4 小时！
现在，理想情况下，我们希望使用 apply 系列和矩阵。这个答案只是我们可以加速代码的众多方法之一。此外，future 包允许我们在不学习新循环结构的情况下并行处理，例如 parallel 包（尽管如此，它仍然是一个了不起的包）。
另请查看 Rcpp 包。这需要一些时间来学习，但对于释放 C++ 的速度来说是不可思议的。
@OP 你应该小心提供的答案
--我的原答案--
library(tidyverse)
我先split将数据帧放入一个按name
分组的数据帧列表
split.df <- split(df, df$name)
使用拆分数据，使用 lapply 和 map_df 遍历每个分组 df 的行，filter 对于相关 window 时间之间的日期使用 between，然后像以前一样 mutate，然后再次 filter 相关行（我尝试 'copy' 您的代码尽可能接近）：
new <- lapply(split.df, function(z) map_df(1:nrow(z), ~z %>%
filter(between(date, z$date[.x]-moving_window_days, z$date[.x])) %>%
mutate(x=percent_rank(x),y=percent_rank(y)) %>%
filter(date==z$date[.x])))
这导致 list。转换回单个数据框
final <- Reduce("rbind",new)
输出（head）
name date x y
1 a 2017-01-01 0.0000000 0.00
2 a 2017-01-02 1.0000000 0.00
3 a 2017-01-03 1.0000000 0.50
4 a 2017-01-04 1.0000000 0.00
让我们确保我的结果与您的结果相符。
identical(final$x, OP.output$x)
[1] TRUE
--我原来的回答结束--
----------------------------比较解决方案------------ ------------------
--@Brian的回答--
@Brian 的回答与您期望的结果不同。你说你的函数 works as intended，所以让我们将 Brian 的结果与你的进行比较。第一个显示 Brian 的结果。第二个显示您的结果。
name date x y x2 y2
1 a 2017-01-01 6.044665 286.9410 0.0000000 1.0000000
2 a 2017-01-02 8.070354 142.4285 0.0000000 1.0000000
3 a 2017-01-03 11.884214 230.3348 0.3333333 0.3333333
4 a 2017-01-04 18.255948 125.1110 0.3333333 1.0000000
name date x y
1 a 2017-01-01 0.0000000 0.00
2 a 2017-01-02 1.0000000 0.00
3 a 2017-01-03 1.0000000 0.50
4 a 2017-01-04 1.0000000 0.00
identical(Brian.output$x2, OP.output$x, )
[1] FALSE
--结束@Brian的回答--
--@奥德修斯的回答--
@Odysseus 的回答 returns 正确的结果，因为它使用了相同的函数，但您必须手动拆分数据框。请参阅下面调用 my_function
的代码
df1 %<-% my_function(df[1:7, ], df1)
df2 %<-% my_function(df = df[(8 - moving_window_days):14, ], df2) # But from here on out, go back 4 days to include that data in the moving average calculation.
df3 %<-% my_function(df = df[(15 - moving_window_days):20, ], df3)
--结束@Odysseus的回答--
您可能会从@Odysseus 的回答中获得最佳性能增益，但您需要自己对其进行基准测试，因为这取决于您拥有的内核数量。并行化并不总是比矢量化操作更快。但是您需要将他的解决方案扩展到数据框的其余部分。
zoo::rollapply 可以相当快。
df2 <- df %>%
group_by(name) %>%
mutate(x2 = zoo::rollapply(x, width = 4, FUN = percent_rank, fill = "extend")[,1],
y2 = zoo::rollapply(y, width = 4, FUN = percent_rank, fill = "extend")[,1])
每次调用 rollapply 都会生成一个包含 n=width 列的矩阵。第一列是从该观察开始的 window 的函数值，而第 n 列是 window 结束的函数值有了那个观察。您可以将 [,1] 更改为您想要的任何列（window 中间的百分位？在末尾？在开头？）。
参数 fill = "extend" 重复 windows 开头或结尾的观察结果，因为最后 n-k 个观察结果有 window.
缺少 k
我将您的数据集扩展为 28,496 行的虚拟数据集，涵盖 26 个名称和 3 年的数据，运行 这个片段的宽度为 90 天。在我 4 岁的台式机上，两个变量用了不到一分钟的时间：
user system elapsed
37.66 0.01 37.77
你当然可以使用 purrr::map2 来迭代 6 个变量（而不是在 mutate 中调用 rollapply 6 次），但我不确定它会大大加快速度.
我有一个数据框，其中每一行代表特定日期特定类别的数据：
set.seed(1)
k <- 10
df <- data.frame(
name = c(rep('a',k), rep('b',k)),
date = rep(seq(as.Date('2017-01-01'),as.Date('2017-01-01')+k-1, 'days'),2),
x = runif(2*k,1,20),
y = runif(2*k,100,300)
)
View(df)
负责人：
head(df)
name date x y
1 a 2017-01-01 6.044665 286.9410
2 a 2017-01-02 8.070354 142.4285
3 a 2017-01-03 11.884214 230.3348
4 a 2017-01-04 18.255948 125.1110
5 a 2017-01-05 4.831957 153.4441
6 a 2017-01-06 18.069404 177.2228
结构：
str(df)
'data.frame': 20 obs. of 4 variables:
$ name: Factor w/ 2 levels "a","b": 1 1 1 1 1 1 1 1 1 1 ...
$ date: Date, format: "2017-01-01" "2017-01-02" "2017-01-03" "2017-01-04" ...
$ x : num 6.04 8.07 11.88 18.26 4.83 ...
$ y : num 287 142 230 125 153 ...
我需要在特定日期 window 缩放此数据的 x 和 y 变量。 我想出的脚本如下：
library(dplyr)
library(lubridate)
df2 <- df
moving_window_days <- 4
##Iterate over each row in df
for(i in 1:nrow(df)){
df2[i,] <- df %>%
##Give me only rows for 'name' on the current row
##which are within the date window of interest
filter(date <= date(df[i,"date"]) &
date >= date(df[i,"date"]) - moving_window_days &
name == df[i,"name"]
) %>%
##Now scale x and y on this date wondow
mutate(x = percent_rank(x),
y = percent_rank(y)
) %>%
##Get rid of the rest of the rows - leave only the row we are looking at
filter(date == date(df[i,"date"]))
}
它按预期工作（好吧，我最初想在移动中获得每个观察的百分位数 window，但缩放后的值就可以正常工作） 问题是真实的数据集要大得多：
'name'列有 30 个本地 b运行ch 办事处'date'是每个 b运行ch 至少一年的数据
- 而不是
'x'和'y'我有 6 个变量 - 搬家window是90天
我 运行 这个脚本基于真实数据，在 30,000 行中 它只能超过 5,000 在 4 小时内... 这是我第一次 运行 遇到这样的问题。
我确定我的脚本效率非常低（我确定是因为我不是 R 专家。我只是假设总有更好的方法）
有什么办法可以优化/改进这个脚本吗？
- 有什么方法可以 'purrrify'（使用
purrr中的某些map函数）？ - 嵌套数据框？
nest()？认为这是一个解决方案...不确定如何实施...
我能做些什么来以不同的方式解决这个问题？
您可以做的一件事是并行处理。我为此使用 future 包。这可能会惹恼一些人，他们可能认为它是 hack，因为 future 包的目的是......好吧......对于未来（或者 "promises" 如果你是前端开发人员）。这种方法很挑剔，但效果很好。
library(future)
# Create a function that iterates over each row in the df:
my_function <- function(df, x) {
x <- df
for(i in 1:nrow(df)){
x[i, ] <- df %>%
##Give me only rows for 'name' on the current row
##which are within the date window of interest
filter(date <= date(df[i,"date"]) &
date >= date(df[i,"date"]) - moving_window_days &
name == df[i,"name"]
) %>%
##Now scale x and y on this date wondow
mutate(x = percent_rank(x),
y = percent_rank(y)
) %>%
##Get rid of the rest of the rows - leave only the row we are looking at
filter(date == date(df[i,"date"]))
}
return(x)
}
plan(multiprocess) # make sure to always include this in a run of the code.
# Divide df evenly into three separate dataframes:
df1 %<-% my_function(df[1:7, ], df1)
df2 %<-% my_function(df = df[(8 - moving_window_days):14, ], df2) # But from here on out, go back 4 days to include that data in the moving average calculation.
df3 %<-% my_function(df = df[(15 - moving_window_days):20, ], df3)
# See if your computer is able to split df into 4 or 5 separate dataframes.
# Now bind the dataframes together, but get the indexing right:
rbind(df1, df2[(nrow(df2) - 6):nrow(df2), ], df3[(nrow(df3) - 5):nrow(df3), ])
并行处理是优化代码以提高效率的众多方法之一。过去，这种技术大大 加快了我的代码速度。它已将 运行 节目的时间从一天半缩短到 3 或 4 小时！
现在，理想情况下，我们希望使用 apply 系列和矩阵。这个答案只是我们可以加速代码的众多方法之一。此外，future 包允许我们在不学习新循环结构的情况下并行处理，例如 parallel 包（尽管如此，它仍然是一个了不起的包）。
另请查看 Rcpp 包。这需要一些时间来学习，但对于释放 C++ 的速度来说是不可思议的。
@OP 你应该小心提供的答案
--我的原答案--
library(tidyverse)
我先split将数据帧放入一个按name
split.df <- split(df, df$name)
使用拆分数据，使用 lapply 和 map_df 遍历每个分组 df 的行，filter 对于相关 window 时间之间的日期使用 between，然后像以前一样 mutate，然后再次 filter 相关行（我尝试 'copy' 您的代码尽可能接近）：
new <- lapply(split.df, function(z) map_df(1:nrow(z), ~z %>%
filter(between(date, z$date[.x]-moving_window_days, z$date[.x])) %>%
mutate(x=percent_rank(x),y=percent_rank(y)) %>%
filter(date==z$date[.x])))
这导致 list。转换回单个数据框
final <- Reduce("rbind",new)
输出（head）
name date x y
1 a 2017-01-01 0.0000000 0.00
2 a 2017-01-02 1.0000000 0.00
3 a 2017-01-03 1.0000000 0.50
4 a 2017-01-04 1.0000000 0.00
让我们确保我的结果与您的结果相符。
identical(final$x, OP.output$x)
[1] TRUE
--我原来的回答结束--
----------------------------比较解决方案------------ ------------------
--@Brian的回答--
@Brian 的回答与您期望的结果不同。你说你的函数 works as intended，所以让我们将 Brian 的结果与你的进行比较。第一个显示 Brian 的结果。第二个显示您的结果。
name date x y x2 y2
1 a 2017-01-01 6.044665 286.9410 0.0000000 1.0000000
2 a 2017-01-02 8.070354 142.4285 0.0000000 1.0000000
3 a 2017-01-03 11.884214 230.3348 0.3333333 0.3333333
4 a 2017-01-04 18.255948 125.1110 0.3333333 1.0000000
name date x y
1 a 2017-01-01 0.0000000 0.00
2 a 2017-01-02 1.0000000 0.00
3 a 2017-01-03 1.0000000 0.50
4 a 2017-01-04 1.0000000 0.00
identical(Brian.output$x2, OP.output$x, )
[1] FALSE
--结束@Brian的回答--
--@奥德修斯的回答--
@Odysseus 的回答 returns 正确的结果，因为它使用了相同的函数，但您必须手动拆分数据框。请参阅下面调用 my_function
df1 %<-% my_function(df[1:7, ], df1)
df2 %<-% my_function(df = df[(8 - moving_window_days):14, ], df2) # But from here on out, go back 4 days to include that data in the moving average calculation.
df3 %<-% my_function(df = df[(15 - moving_window_days):20, ], df3)
--结束@Odysseus的回答--
您可能会从@Odysseus 的回答中获得最佳性能增益，但您需要自己对其进行基准测试，因为这取决于您拥有的内核数量。并行化并不总是比矢量化操作更快。但是您需要将他的解决方案扩展到数据框的其余部分。
zoo::rollapply 可以相当快。
df2 <- df %>%
group_by(name) %>%
mutate(x2 = zoo::rollapply(x, width = 4, FUN = percent_rank, fill = "extend")[,1],
y2 = zoo::rollapply(y, width = 4, FUN = percent_rank, fill = "extend")[,1])
每次调用 rollapply 都会生成一个包含 n=width 列的矩阵。第一列是从该观察开始的 window 的函数值，而第 n 列是 window 结束的函数值有了那个观察。您可以将 [,1] 更改为您想要的任何列（window 中间的百分位？在末尾？在开头？）。
参数 fill = "extend" 重复 windows 开头或结尾的观察结果，因为最后 n-k 个观察结果有 window.
我将您的数据集扩展为 28,496 行的虚拟数据集，涵盖 26 个名称和 3 年的数据，运行 这个片段的宽度为 90 天。在我 4 岁的台式机上，两个变量用了不到一分钟的时间：
user system elapsed
37.66 0.01 37.77
你当然可以使用 purrr::map2 来迭代 6 个变量（而不是在 mutate 中调用 rollapply 6 次），但我不确定它会大大加快速度.