我有一个数据框，其中每行代表特定日期特定类别的数据：
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 ...
我需要在特定的日期窗口中缩放此数据的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"]))
}
它按预期工作（好吧，我最初希望在移动窗口中获得每个观察点的百分位数，但缩放值可以正常工作）问题是真实数据集要大得多：
'name'专栏有30个当地分支机构'date'每个分支至少有一年的数据'x'和'y'我有6个变量我在真实数据上运行了这个脚本，在30,000行中，它在4小时内只能完成5000次......这是我第一次遇到这样的问题。
我确信我的剧本效率很低（我很确定，因为我不是R中的专业人士。我只是假设总有更好的方法）
这个脚本可以通过哪种方式进行优化/改进？
map中的一些purrr函数）？nest()？认为这是一个解决方案......不确定如何实施......我可以采取哪些措施来解决问题？
您可以做的一件事是并行处理。我为此使用了future包。这可能会惹恼一些人，他们可能会认为这是一个黑客攻击，因为未来的包装是有意的...嗯...对于期货（或“承诺”，如果你是一个前端开发人员）。这种方法很挑剔，但效果很好。
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 ++的速度来说却是令人难以置信的。
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列。第一列是以该观察开始的窗口的函数值，而第n列是以该观察结束的窗口的函数值。您可以将[,1]更改为您想要的任何一列（窗口中间的百分位数？在结尾处？在开头？）。
参数fill = "extend"复制了窗口开始或结束时的观察结果，因为对于最后的n-k个观测值，窗口中存在k个缺失。
我将您的数据集扩展为28,496行，包括26个名称和3年的数据，并运行此片段的宽度为90天。在我4岁的桌面上，两个变量花了不到一分钟：
user system elapsed
37.66 0.01 37.77
你当然可以使用purrr::map2迭代6个变量（而不是在rollapply中调用mutate 6次），但我不确定它会大大加快它的速度。
@OP您应该提供所提供的答案
- 我原来的答案 -
library(tidyverse)
我首先将split数据帧放入由name分组的数据帧列表中
split.df <- split(df, df$name)
使用分割数据，使用lapply和map_df迭代每个分组df，filter的行，使用between在相关时间窗口之间的日期，然后像之前那样mutate，然后filter再次为相关行（我试图'复制'你的代码尽可能接近）：
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
--END @Brian的回答 -
- @Odysseus的答案 -
@ Odysseus的答案返回正确的结果，因为它使用相同的功能，但您必须手动拆分数据框。请参阅下面的代码，该代码调用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)
--END @Odysseus的回答 -
您可能会从@Odysseus的答案中获得最佳的性能提升，但您需要自己进行基准测试，因为它取决于您拥有的核心数量。并行化并不总是比矢量化操作更快。但是你需要将他的解决方案扩展到数据框的其余部分。