Эффективно применять пользовательские функции в определенных диапазонах дат для групп - PullRequest
Новая
       12

Эффективно применять пользовательские функции в определенных диапазонах дат для групп

1 голос
/ 22 октября 2019

Я рассчитываю ряд различных показателей центральности и разброса на нескольких таймфреймах в относительно большом наборе данных ~ 1 миллион строк. У меня было несколько разных попыток, но алгоритм, на котором я остановился, все еще слишком медленный для моей цели.

Вот моя текущая итерация: 

ts_rollapply <- function(COI, DATE_COL, FUN, n, unit = c("day", "week", "month", "year"), verbose = FALSE, ...) {
  # Initiate Variables
  APPLY_FUNC <- match.fun(FUN = FUN)
  LAST_DATE <- last_date(DATE_COL, n = n, unit = match.arg(unit))
  result <- vector(mode = "numeric", length = length(COI))

  for(i in seq_along(COI)) {
    # Extract range from Column of Interest
    APPLY_RANGE <- COI[DATE_COL > LAST_DATE[i] & DATE_COL <= DATE_COL[i]]
    # Apply function to extracted range
    result[i] <- APPLY_FUNC(APPLY_RANGE, ...)
    if(verbose && i%%100 == 0) {
      ARL <- length(APPLY_RANGE)
      writeLines(sprintf("Last Date: %10s, Current Date: %10s, Iteration: %3d, Length: %3d, Mean: %.2f", 
                         LAST_DATE[i], DATE_COL[i], i, ARL, result[i]))
    }
  }

  result
}

Обратите внимание, что я также сделал вспомогательную функцию для извлечения определенных периодов времени (last_date), которая реализована следующим образом: 

last_date <- function(x, n = 1, unit = c("day", "week", "month", "year")) {
  require(lubridate)

  # Stop function if x is not Class Date.
  if(!is.Date(x)) stop("x is not class: Date")
  if(any(is.na(x))) stop("x contains NA")

  # Match unit and Perform Calculation
  unit <- match.arg(unit)
  result <- switch(unit,
         day = x - n,
         week = x - (7L*n),
         month = x %m-% months(n),
         year = x %m-% months(12L*n))

  result
}

Проблема, с которой я сталкиваюсь, заключается в том, что функция работает так, как задумано, когда я запускаю ее на небольшом образце, но она не работает (по времени), когда я масштабирую ее до полного набора данных. И я не могу понять, является ли это выполнением функции, которое я сделал, что является медленным. Или, если это так, как я вызываю функцию в моем data.table. 

library(data.table)
library(lubridate)

# Functions to apply -- I have multiple others, but these should work as example
functions <- c("mean", "median", "sd")

# Toy Data:
DT <- data.table(store = rep(1:10, each = 1000),
                 sales = rnorm(n = 10000, mean = 4500, sd = 2500),
                 date = rep(seq(ymd("2015-01-01"), by = "day", length.out = 1000), 10))

# How i call the ts_rollapply function
DT[, paste("sales_quarter", functions, sep = "_") := lapply(functions, function(x) ts_rollapply(sales, date, x, n = 3, unit = "month", na.rm = T)), store]

Любая помощь в том, как ускорить мои вычисления, будет высоко ценится!

1 Ответ

0 голосов
/ 23 октября 2019

Один из способов - выполнить неэквивалентное объединение 

DT[, (cols) := 
    DT[.(STORE=STORE, START_DATE=DATE - 7L, END_DATE=DATE), 
        on=.(STORE, DATE>=START_DATE, DATE<=END_DATE),
        lapply(functions, function(f) get(f)(SALES)), by=.EACHI][, (1:3) := NULL]
    ]

Более быстрым способом является заполнение ПРОДАЖ на все даты и использование data.table::frollapply, как указано в комментариях. 

res <- DT[DT[, .(DATE=seq(min(DATE), max(DATE), by="1 day")), STORE], on=.(STORE, DATE)][,
    (cols) := lapply(functions, function(f) frollapply(SALES, 7L, f, na.rm=TRUE))]
DT[res, on=.(STORE, DATE), names(res) := mget(paste0("i.", names(res)))]

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

data: 

library(data.table)    
functions <- c("mean", "median", "sd")
nr <- 1e6
DT <- data.table(STORE=rep(1:10, each=nr/10),
    SALES=rnorm(nr, 4500, 2500),
    DATE=rep(seq(as.IDate("2015-01-01"), by="day", length.out=nr/10), 10))
cols <- paste("sales_quarter", functions, sep = "_")
...