Нужна помощь в оптимизации cumsum-подобного кода - sqldf, data.table, non-equi joins - PullRequest
Новая
       35

Нужна помощь в оптимизации cumsum-подобного кода - sqldf, data.table, non-equi joins

0 голосов
/ 04 мая 2018

Требуется помощь для оптимизации моего кода sqldf, который генерирует агрегированные статистические данные на основе неравных объединений, т. Е. Данные должны агрегироваться только до текущей строки данных.

Важно, чтобы любое решение могло работать для множества различных групп, например, для фильтрации агрегатов по tourney_name и т. Д. В примере sqldf.

Получить данные: 

library(dplyr); library(sqldf); data_list <- list()

for(i in 2000:2018){
    data_list[[i]] <- 
        readr::read_csv(paste0('https://raw.githubusercontent.com/JeffSackmann/tennis_atp/master/atp_matches_',i,'.csv')) %>% 
        as.data.frame}

data <- data.table::rbindlist(data_list)
data <- select(data, tourney_name, tourney_date, match_num, winner_id, winner_name, loser_id, loser_name)

system.time(
    data2 <- sqldf("select a.*, 
                   count(b.winner_id) as winner_overall_wins
                   from data a 
                   left join data b 
                   on (a.winner_id = b.winner_id and a.tourney_date > b.tourney_date)
                   group by a.tourney_name, a.tourney_date, a.match_num, a.winner_id
                   order by tourney_date desc, tourney_name, match_num desc",
                   stringsAsFactors = FALSE)
) # takes 16 sec, would like to look for a vectorized solution

head(data2)

Подходы, которые я пытался ускорить код:

  1. Для цикла - слишком медленно

  2. Dplyr full join / filter - взорвали память за 60 ГБ.

  3. Data.table / cumsum - не удалось заставить код работать правильно. Предпочитаю не data.table подход, но готов учиться для обобщенного решения

Спасибо!

1 Ответ

0 голосов
/ 11 мая 2018

ОП попросил оптимизировать несколько каскадных sqldf операторов (до редактирования ОП). К сожалению, ФП не объяснил устно, какие агрегаты он реализовал. Таким образом, потребовалось значительное количество реверс-инжиниринга.

Во всяком случае, вот , что я бы сделал , используя data.table для достижения тех же результатов. Время выполнения уменьшено с 16 секунд для кода OP sqldf до менее 0,2 секунды для версий data.table.

data.table версии отредактированного примера

ОП отредактировал вопрос, чтобы уменьшить количество sqldf утверждений. Теперь вычисляется только один агрегат.

Новый столбец winner_overall_wins в data2 - это количество всех матчей, выигранных победителем до фактического турнира. Этот номер прикрепляется ко всем матчам реального турнира, которые выиграл победитель. (Обратите внимание, что это агрегирование отличается от количества матчей, которые были выиграны до фактического матча).

Начиная с версии 1.9.8 (в CRAN 25 ноября 2016 г.), data.table способен выполнять неравных объединений . Кроме того, fread() можно посоветовать читать только выбранные столбцы, что еще больше ускоряет ввод / вывод. 

library(data.table)  # v1.11.2

urls <- sprintf(
  "https://raw.githubusercontent.com/JeffSackmann/tennis_atp/master/atp_matches_%i.csv", 
  2000:2018)
selected_cols <- c("tourney_name", "tourney_date", "match_num", 
                   "winner_id", "winner_name", 
                   "loser_id", "loser_name") 

# read only selected columns from files & combine into one data object
matches <- rbindlist(lapply(urls, fread, select = selected_cols))

# non-equi join to compute aggregate, second join to append, order result 
system.time({
  result_nej <- matches[
    unique(matches[matches, on = .(winner_id, tourney_date < tourney_date), 
                   .(winner_overall_wins = .N), by = .EACHI]),
    on = .(winner_id, tourney_date)][
      order(-tourney_date, tourney_name, -match_num)]
})

Два соединения data.table и последующее упорядочение заняли в моей системе около 0,15 с против 16–19 с для различных прогонов кода sqldf ОП.

История конкретного игрока может быть восстановлена ​​с помощью 

p_name <- "Federer"; result_nej[winner_name %like% p_name | loser_id %like% p_name]

                     tourney_name tourney_date match_num winner_id   winner_name loser_id         loser_name winner_overall_wins
   1:             Australian Open     20180115       701    103819 Roger Federer   105227        Marin Cilic                1128
   2:             Australian Open     20180115       602    103819 Roger Federer   111202        Hyeon Chung                1128
   3:             Australian Open     20180115       504    103819 Roger Federer   104607      Tomas Berdych                1128
   4:             Australian Open     20180115       408    103819 Roger Federer   105916   Marton Fucsovics                1128
   5:             Australian Open     20180115       316    103819 Roger Federer   104755    Richard Gasquet                1128
  ---                                                                                                                           
1131:                   Marseille     20000207         3    103819 Roger Federer   102179      Antony Dupuis                   4
1132: Davis Cup WG R1: SUI vs AUS     20000204         2    103819 Roger Federer   102882 Mark Philippoussis                   3
1133:             Australian Open     20000117        90    103819 Roger Federer   102466        Jan Kroslak                   1
1134:             Australian Open     20000117        52    103819 Roger Federer   102021      Michael Chang                   1
1135:                    Adelaide     20000103         2    103819 Roger Federer   102533   Jens Knippschild                   0

Существует альтернативное и более быстрое решение с использованием cumsum() и shift(): 

system.time({
  # cumumlative operations require ordered data
  setorder(matches, tourney_date, tourney_name, match_num)
  # add tourney id for convenience and conciseness
  matches[, t_id := rleid(tourney_date, tourney_name)]
  # aggregate by player and tourney
  p_t_hist <- matches[, .(winner_won = .N), by = .(winner_id, t_id)]
  # compute cumulative sum for each player and 
  # lag to show only matches of previous tourneys
  tmp <- p_t_hist[order(t_id), 
                  .(t_id, winner_overall_wins = shift(cumsum(winner_won))), 
                  by = winner_id]
  # append new column & order result
  result_css <- matches[tmp, on = .(t_id, winner_id)][order(-t_id)]
})
p_name <- "Federer"; result_css[winner_name %like% p_name | loser_id %like% p_name]

В моей системе истекшее время составляет около 0,05 с, что в 3 раза быстрее, чем вариант с неравным соединением, и на величины быстрее, чем подход OP.

...