R не перекрывающийся образец - более быстрая функция - PullRequest
Новая
       16

R не перекрывающийся образец - более быстрая функция

0 голосов
/ 06 мая 2019

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

Функция вызова: 

non_overlapping_sample <- function (tbla, date_field, id_field, window_days) {
  base_evaluar = data.table(tbla)
  base_evaluar[,(date_field):= ymd(base_evaluar[[date_field]]) ]
  setkeyv(base_evaluar, date_field)
  setkeyv(base_evaluar, id_field)
  id_primero = sample(1:nrow(tbla), 1)
  base_muestra = data.frame(base_evaluar[id_primero,])
  base_evaluar = remove_rows(base_evaluar, id_primero, date_field, id_field, window_days)
  while (nrow(base_evaluar) > 0) {
    id_a_sacar = sample(1:nrow(base_evaluar), 1)
    base_muestra = rbind(base_muestra,data.frame(base_evaluar[id_a_sacar,]))
    base_evaluar = remove_rows(base_evaluar, id_a_sacar,  date_field, id_field, window_days)
  }

  base_muestra = base_muestra[order(base_muestra[,id_field],base_muestra[,date_field]),]
  return(base_muestra)
}

Ant внутренняя функция: 

remove_rows <- function(tabla, indice_fila, date_field, id_field, window_days) { 
  fecha = tabla[indice_fila, get(date_field)]
  element = tabla[indice_fila, get(id_field)]
  lim_sup=fecha + window_days
  lim_inf=fecha - window_days
  queda = tabla[ tabla[[id_field]] != element | tabla[[date_field]] > lim_sup | tabla[[date_field]] < lim_inf]
  return(queda)
}

Пример использования: 

set.seed(1)
library(lubridate)
sem = sample(seq.Date(ymd(20150101),ymd(20180101),1), 3000, replace = T)
base = data.frame(fc_fin_semana = sem, cd_cliente=round(runif(3000)*10,0))
base=base[!duplicated(base),]
non_overlapping_sample(base, date_field='fc_fin_semana', 'cd_cliente', 182)

Есть идеи, как заставить его работать быстрее?

Спасибо!

EDITION: Пример того, что было бы неправильно и правильно:

enter image description here

1 Ответ

0 голосов
/ 07 мая 2019

rbind медленно в циклах.Попробуйте что-то вроде этого: 

non_overlapping_sample2 <- function(tbla, date_field, id_field, window_days) {
  dt <- data.table(tbla)
  dt[, (date_field) := ymd(dt[[date_field]])]
  setkeyv(dt, c(id_field, date_field))
  # create vectors for while loop:
  rowIDS <- 1:nrow(dt)
  selected_rows <- NULL
  use <- rep(T, nrow(dt))
  dates <- dt[[date_field]]
  ids <- dt[[id_field]]
  rowIDS2 <- rowIDS
  while (length(rowIDS2) > 0) {
    sid <- sample.int(length(rowIDS2), 1) # as rowIDS2 can be length 1 vector, use this approach
    row_selected <- rowIDS2[sid] # selected row
    selected_rows <- c(selected_rows, row_selected)
    sel_date <- dates[row_selected] # selected date
    sel_ID <- ids[row_selected] # selected ID
    date_max <- sel_date + window_days
    date_min <- sel_date - window_days
    use[ids == sel_ID & dates <= date_max & dates >= date_min] <- FALSE
    rowIDS2 <- rowIDS[use == TRUE] # subset for next sample
  }
  result <- dt[selected_rows, ] # dt subset
  setorderv(result, c(id_field, date_field))
  return(result)
}

В цикле нам не нужно делать data.table\data.frame подмножеств, работать только с векторами.Подстановка может быть выполнена в конце.

...