给出下表
library(tidyverse)
set.seed(1)
data.frame(x = rep(words[1:5], 50) %>% sort(),
Width = sample(1:5, size = 250, replace = T),
z = sample(seq(from = 30 , to = 90, by = 0.1), size = 250, replace = T)) %>%
head(20)
x Width z
1 a 2 75.7
2 a 2 86.0
3 a 3 58.2
4 a 5 66.2
5 a 2 59.1
6 a 5 36.5
7 a 5 44.8
8 a 4 59.9
9 a 4 52.4
10 a 1 86.1
11 a 2 61.4
12 a 1 49.0
13 a 4 46.7
14 a 2 77.3
15 a 4 72.2
16 a 3 39.9
17 a 4 33.8
18 a 5 75.3
19 a 2 67.2
20 a 4 40.1
对于z [i]的每个值，在z [i + 1]：z [i + width [i]]中找到最大值
例如：
对于第1行显示：86.0
第2行显示：66.2
第4行显示：59.9
第11行显示：49.0
对于第18行这样的部分窗口，显示67.2
最后一行显示NA
我正在寻找类似rollapply但具有动态宽度的东西。
我认为这可以通过为每一行使用for循环来实现。 但我想知道是否有更优雅/更有效的解决方案
答案 0 :(得分：1)
这是一种使用sapply的方法。
我要做的第一件事是建立一个搜索列表：对于每个元素，我都会建立一个索引列表，该索引应该用于max：
> # First make it an iteratable
> search_list = sapply(df$Width, function(x){1:x})
> search_list[1:2]
[[1]]
[1] 1 2
[[2]]
[1] 1 2
> # Then add i
> search_list = sapply(1:length(search_list), function(i){search_list[[i]] + i})
> search_list[1:2]
[[1]]
[1] 2 3
[[2]]
[1] 3 4
现在，我知道要搜索哪个元素了，我将max应用于
> result <- sapply(search_list, function(elt){max(df$z[elt], na.rm = TRUE)})
Warning message:
In max(df$z[elt], na.rm = TRUE) :
no non-missing arguments to max; returning -Inf
> result[1:3]
[1] 86.0 66.2 66.2
为避免警告，可以添加一项检查以控制max不会在NULL上执行，但这会降低代码的速度。
例如，您可以构建自己的max函数：
my_max <- function(x){ if (any(!is.na(x))){max(x, na.rm = TRUE)} else{NA}}
比较效率：
这里有一些代码可以循环执行，并在函数中加上sapply：
sapply_way <- function(df){
search_list = sapply(df$Width, function(x){0:(x - 1)})
search_list = sapply(1:length(search_list), function(i){search_list[[i]] + i})
return(sapply(search_list, function(elt){max(df$z[elt], na.rm = TRUE)}))
}
loop_way <- function(df){
res <- list()
for (i in 1:nrow(df)){
res <- c(res, max(df$z[i:(i+df$Width[i] - 1)], na.rm = TRUE))
}
return(res)
}
只有@symbolrush提出的一个建议：
one_sapply_way <- function(df){
sapply(1:nrow(df), function(i) {max(df$z[(i + 1):min((i+df$Width[i]), nrow(df))])})
}
使用@Len建议的dplyr
dplyr_way <- function(df){
df %>%
mutate(newmaxvar = rollapply(lead(df$z,1), df$Width, FUN = max, na.rm = T, align = "left", partial = T))
}
使用微基准程序库，我将它们进行比较：
> microbenchmark(
+ sapply_way(df),
+ loop_way(df),
+ one_sapply_way(df),
+ dplyr_way(df)
+ )
Unit: milliseconds
expr min lq mean median uq max neval
sapply_way(df) 1.874739 2.029868 2.826689 2.126493 2.284847 13.071267 100
loop_way(df) 2.965918 3.222217 3.917204 3.331158 3.522210 9.327948 100
one_sapply_way(df) 4.002259 4.537584 5.318989 4.672185 4.968806 21.825913 100
dplyr_way(df) 4.770276 5.418942 7.573212 5.693570 5.968198 104.622040 100
如您所见，sapply更快。而且，如果您的df变大，它将变得更加有趣。
答案 1 :(得分：1)
library(dplyr)
library(zoo)
df %>%
mutate(newmaxvar = rollapply(lead(df$z,1), df$Width, FUN = max, na.rm = T, align = "left", partial = T))
x Width z newmaxvar
1 a 2 75.7 86.0
2 a 2 86.0 66.2
3 a 3 58.2 66.2
4 a 5 66.2 59.9
5 a 2 59.1 44.8
6 a 5 36.5 86.1
7 a 5 44.8 86.1
8 a 4 59.9 86.1
9 a 4 52.4 86.1
10 a 1 86.1 61.4
11 a 2 61.4 49.0
12 a 1 49.0 46.7
13 a 4 46.7 77.3
14 a 2 77.3 72.2
15 a 4 72.2 75.3
16 a 3 39.9 75.3
17 a 4 33.8 75.3
18 a 5 75.3 67.2
19 a 2 67.2 40.1
20 a 4 40.1 -Inf
答案 2 :(得分：1)
另一个选项（仅使用基本R函数）是以下单行代码：
sapply(1:nrow(df), function(i) {max(df$z[(i+1):min((i+df$Width[i]), nrow(df))])})
输出与您所需的输出匹配：
[1] 86.0 66.2 66.2 59.9 44.8 86.1 86.1 86.1 86.1 61.4 49.0 46.7 77.3 72.2 75.3 75.3 75.3 67.2 40.1 NA
或全部在一起：
library(tidyverse)
set.seed(1)
df <- data.frame(x = rep(words[1:5], 50) %>% sort(),
Width = sample(1:5, size = 250, replace = T),
z = sample(seq(from = 30 , to = 90, by = 0.1), size = 250, replace = T)) %>%
head(20)
df$newmaxvar <- sapply(1:nrow(df), function(i) {max(df$z[(i+1):min((i+df$Width[i]), nrow(df))])})
df
x Width z newmaxvar
1 a 2 75.7 86.0
2 a 2 86.0 66.2
3 a 3 58.2 66.2
4 a 5 66.2 59.9
5 a 2 59.1 44.8
6 a 5 36.5 86.1
7 a 5 44.8 86.1
8 a 4 59.9 86.1
9 a 4 52.4 86.1
10 a 1 86.1 61.4
11 a 2 61.4 49.0
12 a 1 49.0 46.7
13 a 4 46.7 77.3
14 a 2 77.3 72.2
15 a 4 72.2 75.3
16 a 3 39.9 75.3
17 a 4 33.8 75.3
18 a 5 75.3 67.2
19 a 2 67.2 40.1
20 a 4 40.1 NA