Roll применить максимум в динамической ширине окна

Question

С учетом следующей таблицы

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

Я ищу что-то похожее на раскладывание, но с динамической шириной.

Я предполагаю, что этого можно достичь, используя цикл for для каждой строки. Но я хотел бы знать, есть ли более элегантное / эффективное решение

Answer 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

Answer 2

Другой вариант (с использованием только базовых функций 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

Answer 3

Вот способ сделать это, используя 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_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))])})
}

С dplyr, предложенным @ Len

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 станет больше, это будет еще интереснее.