Использование lapply для транспонирования части столбца и добавления его в качестве новых столбцов во фрейм данных

Question

Я искал некоторую ясность в этом, но не могу найти что-то подходящее для моего случая, я построил DF, очень похожий на этот (но со значительно большим количеством данных, в общей сложности более миллиона строк)

Key1 <- c("A", "B", "C", "A", "C", "B", "B", "C", "A", "C") 
Key2 <- c("A1", "B1", "C1", "A2", "C2", "B2", "B3", "C3", "A3", "C4") 
NumVal <- c(2, 3, 1, 4, 6, 8, 2, 3, 1, 0)
DF1 <- as.data.frame(cbind(Key1, Key2, NumVal), stringsAsFactors = FALSE) %>% arrange(Key2)
ConsId <- c(1:10)
DF1 <- cbind(DF1, ConsId)

Теперь я хочу добавить, скажем, 3 новых столбца (в реальной жизни мне нужно 12, но для большей наглядности в этом игрушечном примере мы будем использовать 3) к даннымкадр, где каждая строка соответствует значениям $ NumVal с тем же $ Key1 и большим или равным $ ConsId для значений в каждой строке и заполнением оставшихся пробелов NA, вот ожидаемый результат, если я не оченьclear:

Key1    Key2    NumVal  ConsId  V1  V2  V3
A        A1        2       1    2   4   1
A        A2        4       2    4   1   NA
A        A3        1       3    1   NA  NA
B        B1        3       4    3   8   2
B        B2        8       5    8   2   NA
B        B3        2       6    2   NA  NA
C        C1        1       7    1   6   3
C        C2        6       8    6   3   0
C        C3        3       9    3   0   NA
C        C4        0      10    0   NA  NA

Теперь я использую do.call (rbind), и даже если он работает нормально, это занимает слишком много времени для моих реальных данных с чуть более 1 миллиона строк (около 6hrs), я также пытался использовать функцию bind_rows dplyr, но это заняло немного больше времени, поэтому я остановился на опции do.call, вот пример кода, который я использую:

# Function
TranspNumVal <- function(i){
  Id <- DF1[i, "Key1"]
  IdCons <- DF1[i, "ConsId"]
  myvect <- as.matrix(filter(DF1, Id == Key1, ConsId >= IdCons) %>% select(NumVal))
  Result <-  as.data.frame(t(myvect[1:3]))
  return(Result)
}

# Applying the function to the entire data frame
DF2 <- do.call(rbind, lapply(1:NROW(DF1), function(i) TranspNumVal(i)))
DF3 <- cbind(DF1, DF2)

Возможно, изменениекласс вызываеткод настолько неэффективен, или, может быть, я просто не нахожу лучшего способа векторизовать мою проблему (вы не хотите знать, сколько времени это заняло с помощью вложенного цикла), я довольно плохо знаком с R и простоначал дурачиться с dplyr, так что я открыт для любых предложений о том, как оптимизировать мой код

Answer 1

A dplyr конвейер.

Первая служебная функция будет фильтровать a (NumVal) на основе значений b (ConsId):

myfunc1 <- function(a,b) {
  n <- length(b)
  lapply(seq_along(b), function(i) a[ b >= b[i] ])
}

Вторая служебная функция преобразует рваный list в data.frame.Он работает с произвольным количеством добавляемых столбцов, но мы ограничили его до 3, исходя из ваших требований:

myfunc2 <- function(x, ncols = 3) {
  n <- min(ncols, max(lengths(x)))
  as.data.frame(do.call(rbind, lapply(x, `length<-`, n)))
}

Теперь конвейер:

dat %>%
  group_by(Key1) %>%
  mutate(lst = myfunc1(NumVal, ConsId)) %>%
  ungroup() %>%
  bind_cols(myfunc2(.$lst)) %>%
  select(-lst) %>%
  arrange(Key1, ConsId)
# # A tibble: 10 × 7
#     Key1  Key2 NumVal ConsId    V1    V2    V3
#    <chr> <chr>  <int>  <int> <int> <int> <int>
# 1      A    A1      2      1     2     4     1
# 2      A    A2      4      2     4     1    NA
# 3      A    A3      1      3     1    NA    NA
# 4      B    B1      3      4     3     8     2
# 5      B    B2      8      5     8     2    NA
# 6      B    B3      2      6     2    NA    NA
# 7      C    C1      1      7     1     6     3
# 8      C    C2      6      8     6     3     0
# 9      C    C3      3      9     3     0    NA
# 10     C    C4      0     10     0    NA    NA

Answer 2

Мы можем использовать dplyr::lead

DF1 %>%
    group_by(Key1) %>%
    mutate(
        V1 = NumVal,
        V2 = lead(NumVal, n = 1),
        V3 = lead(NumVal, n = 2))
## A tibble: 10 x 7
## Groups:   Key1 [3]
#   Key1  Key2  NumVal ConsId V1    V2    V3
#   <chr> <chr> <chr>   <int> <chr> <chr> <chr>
# 1 A     A1    2           1 2     4     1
# 2 A     A2    4           2 4     1     NA
# 3 A     A3    1           3 1     NA    NA
# 4 B     B1    3           4 3     8     2
# 5 B     B2    8           5 8     2     NA
# 6 B     B3    2           6 2     NA    NA
# 7 C     C1    1           7 1     6     3
# 8 C     C2    6           8 6     3     0
# 9 C     C3    3           9 3     0     NA
#10 C     C4    0          10 0     NA    NA

Объяснение: Мы группируем записи по Key1, а затем используем lead для смещения NumVal значений для столбцов V2 и V3.V1 это просто копия NumVal.

Answer 3

После группировки по 'Key1', используйте shift (из data.table), чтобы получить следующее значение 'NumVal' в list, преобразовать его в tibble и unnest вложенное listэлементы для отдельных столбцов набора данных.По умолчанию shift fill NA в конце.

library(data.table) 
library(tidyverse)
DF1 %>% 
  group_by(Key1) %>% 
  mutate(new = shift(NumVal, 0:(n()-1), type = 'lead') %>% 
                     map(~ 
                          as.list(.x) %>%
                          set_names(paste0("V", seq_along(.))) %>% 
                          as_tibble)) %>% 
  unnest %>%
  select(-V4)
# A tibble: 10 x 7
# Groups:   Key1 [3]
#   Key1  Key2  NumVal ConsId    V1    V2    V3
#   <chr> <chr>  <dbl>  <int> <dbl> <dbl> <dbl>
# 1 A     A1         2      1     2     4     1
# 2 A     A2         4      2     4     1    NA
# 3 A     A3         1      3     1    NA    NA
# 4 B     B1         3      4     3     8     2
# 5 B     B2         8      5     8     2    NA
# 6 B     B3         2      6     2    NA    NA
# 7 C     C1         1      7     1     6     3
# 8 C     C2         6      8     6     3     0
# 9 C     C3         3      9     3     0    NA
#10 C     C4         0     10     0    NA    NA

data

DF1 <- data.frame(Key1, Key2, NumVal, stringsAsFactors = FALSE) %>% 
                       arrange(Key2)
DF1$ConsId <- 1:10