Ускорение конвейера dplyr, включая проверки с mutate_if и if_else для больших таблиц

Question

Я написал некоторый код для выполнения передискретизации, что означает, что я копирую свои наблюдения в data.frame и добавляю шум к репликам, чтобы они больше не были одинаковыми. Я очень рад, что теперь он работает как задумано, но ... это слишком медленно. Я только изучаю dplyr и понятия не имею о data.table, но надеюсь, что есть способ улучшить мою функцию. Я запускаю этот код в функции для сотен фреймов data.frames, которые могут содержать около 10 000 столбцов и 400 строк.

Это некоторые игрушечные данные:

library(tidyverse)

train_set1 <- rep(0, 300)
train_set2 <- rep("Factor1", 300)
train_set3 <- data.frame(replicate(1000, sample(0:1, 300, rep = TRUE)))
train_set <- cbind(train_set1, train_set2, train_set3)
row.names(train_set) <- c(paste("Sample", c(1:nrow(train_set)), sep = "_"))

Это код для репликации каждой строки заданное количество раз и функция для определения того, будет ли добавленный шум позже положительным или отрицательным:

# replicate each row twice, added row.names contain a "."
train_oversampled <- train_set[rep(seq_len(nrow(train_set)), each = 3), ]

# create a flip function
flip <- function() {
  sample(c(-1,1), 1)
}

В соответствующем «слишком медленном» фрагменте кода я подгруппирую row.names для добавленного "." фильтровать реплики. Чем я выбираю только цифры c столбцы. Я go через эти столбцы строка за строкой и оставляю значения нетронутыми, если они равны 0. Если нет, то добавляется определенное количество (здесь + - 1%). Позже я объединяю этот набор данных с исходным набором данных и получаю свою передискретизированную data.frame.

# add percentage of noise to non-zero values in numerical columns
noised_copies <- train_oversampled %>% 
  rownames_to_column(var = "rowname") %>%
  filter(grepl("\\.", row.names(train_oversampled))) %>% 
  rowwise() %>%
  mutate_if(~ is.numeric(.), ~ if_else(. == 0, 0,. + (. * flip() * 0.01 ))) %>%
  ungroup() %>%
  column_to_rownames(var = "rowname")
# combine original and oversampled, noised data set
train_noised <- rbind(noised_copies, train_set)

Я предполагаю, что есть более быстрые способы использования, например, data.table, но запустить этот код уже было непросто, и я понятия не имею, как повысить его производительность.

---

РЕДАКТИРОВАТЬ:

Решение работает отлично с фиксированными значениями, но вызывается в течение для l oop Я получаю "Ошибка в вставке (Sample, n, sep =". "): Object 'Sample 'not found'

Код для репликации:

library(data.table)

train_set <- data.frame(
  x = c(rep(0, 10)), 
  y = c(0:9), 
  z = c(rep("Factor1", 10)))

# changing the row name to avoid confusion with "Sample"
row.names(train_set) <- c(paste("Observation", c(1:nrow(train_set)), sep = "_"))
train_list <- list(aa = train_set, bb = train_set, cc = train_set)

for(current_table in train_list) {
  setDT(current_table, keep.rownames="Sample")
  cols <- names(current_table)[sapply(current_table, is.numeric)]
  noised_copies <- lapply(c(1,2), function(n) {
    copy(current_table)[,
      c("Sample", cols) := c(.(paste(Sample, n, sep=".")), 
        .SD * sample(c(-1.01, 1.01), .N*ncol(.SD), TRUE)),
      .SDcols=cols]
  })
train_noised <- rbindlist(c(noised_copies, list(train_set)), use.names=FALSE)
# As this is an example, I did not write anything to actually 
# store the results, so I have to remove the object
rm(train_noised)
}

Есть идеи, почему столбец Sample не может быть найден сейчас?

Answer 1

Вот более векторизованный подход, использующий data.table:

library(data.table)
setDT(train_set, keep.rownames="Sample")
cols <- names(train_set)[sapply(train_set, is.numeric)]
noised_copies <- lapply(c(1,2), function(n) {
    copy(train_set)[,
        c("Sample", cols) := c(.(paste(Sample, n, sep=".")), 
            .SD * sample(c(-1.01, 1.01), .N*ncol(.SD), TRUE)),
        .SDcols=cols]
})
train_noised <- rbindlist(c(noised_copies, list(train_set)), use.names=FALSE)

С версией data.table> = 1.12.9, вы можете передать is.numeric непосредственно аргументу .SDcols и, возможно, более короткому способ (например, (.SD) или names(.SD)) перейти к левой стороне :=

---

адрес обновленного сообщения OP:

Проблема в том, что хотя каждый data.frame в списке преобразуется в data.table, train_list не обновляется. Вы можете обновить список с помощью левой привязки перед for l oop:

library(data.table)

train_set <- data.frame(
    x = c(rep(0, 10)), 
    y = c(0:9), 
    z = c(rep("Factor1", 10)))

# changing the row name to avoid confusion with "Sample"
row.names(train_set) <- c(paste("Observation", c(1:nrow(train_set)), sep = "_"))
train_list <- list(aa = train_set, bb = copy(train_set), cc = copy(train_set))

train_list <- lapply(train_list, setDT, keep.rownames="Sample")

for(current_table in train_list) {
    cols <- names(current_table)[sapply(current_table, is.numeric)]
    noised_copies <- lapply(c(1,2), function(n) {
        copy(current_table)[,
            c("Sample", cols) := c(.(paste(Sample, n, sep=".")),
                .SD * sample(c(-1.01, 1.01), .N*ncol(.SD), TRUE)),
            .SDcols=cols]
    })
    train_noised <- rbindlist(c(noised_copies, train_list), use.names=FALSE)
    # As this is an example, I did not write anything to actually
    # store the results, so I have to remove the object
    rm(train_noised)
}