Какова альтернатива для этого медленного цикла for, чтобы заполнить отдельные дни между датами?

Question

Для проекта, над которым я работаю, мне нужен блок данных, чтобы указать, отсутствовал ли человек (0) или нет (1) в определенный день.

Проблема в том, что мои данныев формате, где указывается начальная дата отсутствия, а затем число дней, в течение которых человек отсутствовал.

Пример моего фрейма данных:

df1 <- data.frame(Person = c(1,1,1,1,1),
                 StartDate = c("01-01","02-01","03-01","04-01","05-01"),
                 DAYS = c(3,NA,NA,NA,1))

Вместо «Дата начала»и «количество дней отсутствия» на человека, оно должно выглядеть следующим образом:

df2 <- data.frame(Person = c(1,1,1,1,1),
                 Date = c("01-01","02-01","03-01","04-01","05-01"),
                 Absent = c(1,1,1,0,1))

Пока я решил это с помощью цикла for с двумя условиями if:

for(i in 1:nrow(df1)){
  if(!is.na(df1$DAYS[i])){
     var <- df1$DAYS[i]
   }
  if(var > 0){
     var <- var-1
     df1$DAYS[i] <- 1
   }
 }

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

Кто-нибудь знает более быстрый способ решения моей проблемы?Я попытался посмотреть на пакет lubridate для работы с периодами и датами, но не вижу там решения.

Answer 1

Во-первых, ваш оригинальный подход был не так уж плох.Некоторые незначительные улучшения могут сделать его быстрее, чем у gfgm (на момент тестирования я не знаю вашей точной структуры данных):

improvedOP <- function(d) {
  days <- d$DAYS # so we do not repeatedly change data.frames column
  ii <- !is.na(days) # this can be calculated outside the loop
  for (i in 1:nrow(d)) {
    if (ii[i]) var <- days[i]
    if (var > 0) {
      var <- var - 1
      days[i] <- 1
    }
  }
  return(days)
}

Я придумал такой подход:

minem <- function(d) {
  require(zoo)
  rn <- 1:nrow(d) # row numbers
  ii <- rn + d$DAYS - 1L # get row numbers which set to 1
  ii <- na.locf(ii, na.rm = F) # fill NA forward
  ii <- rn <= ii # if row number less or equal than interested row is 1
  ii[ii == 0] <- NA # set 0 to NA to match original results
  as.integer(ii)
}

all.equal(minem(d), improvedOP(d))
# TRUE

Идея состоит в том, что мы вычисляем номера строк, которые должны быть равны 1 (текущая строка + ДНИ - 1).Затем заполните NA этим значением, и если строка соответствует нашему условию, установленному в 1. Это должно быть быстрее, чем любой другой подход, который включает создание последовательностей.

Эталон для более крупных (7,3 млн. Строк) смоделированных данных:

gfgm <- function(d) {
  days <- rep(0, nrow(d))
  inds <- which(!is.na(d$DAYS))
  inds_to_change <- mapply(function(i, d) {i:(i + d - 1)}, inds, na.omit(d$DAYS))
  days[unlist(inds_to_change)] <- 1
  days
}
nrow(d)/1e6 # 7.3 mil
require(bench)
require(data.table)
bm <- bench::mark(minem(d), improvedOP(d), gfgm(d), iterations = 2, check = F)
as.data.table(bm[, 1:7])
#       expression      min     mean   median      max   itr/sec mem_alloc
# 1:      minem(d) 281.34ms 302.85ms 302.85ms 324.35ms 3.3019990     408MB
# 2: improvedOP(d) 747.45ms 754.55ms 754.55ms 761.65ms 1.3252907     139MB
# 3:       gfgm(d)    3.23s    3.27s    3.27s    3.31s 0.3056558     410MB

PS, но реальные результаты, вероятно, зависят от распределения значений DAYS.

Answer 2

Более быстрое решение можно найти с помощью встроенных функций R.

Общая идея:

1. Для каждого человека найдите положение для отсутствующих дней больше 1. Пустьколичество отсутствующих дней будет a, а позиция будет p.
2. В каждой позиции, определенной последовательностью p:(p + a - 1), введите значение 1.
3. Верните переопределенный вектор на местостарого вектора.

Все это может быть реализовано в функции, а затем применено ко всем подгруппам.Чтобы это было быстрее

, функция

В конкретном случае работает mapply (как предполагает предыдущий ответ), но использование data.table в целом будет быстрее для больших наборов данных.Это используется ниже.

RelocateAbsentees <- function(x){
  #Find the position in x for which the value is greater than 1
  pos <- which(x > 1)
  #Fill in the vector with the absent days
  for(i in pos){
    val <- x[i]
    x[i:(i + val - 1)] <- 1
  }
  #return the vector
  pos
} 
df1 <- data.frame(Person = c(1,1,1,1,1),
                  StartDate = c("01-01","02-01","03-01","04-01","05-01"),
                  DAYS = c(3,NA,NA,NA,1))
library(data.table)
setDT(df1)
df2 <- copy(df1)[,Person := 2]
df3 <- rbind(df1,df2)
#Using data.table package (faster)
df1[, newDays := RelocateAbsentees(DAYS), by = Person]
df3[, newDays := RelocateAbsentees(DAYS), by = Person]

Answer 3

Я нашел довольно аккуратное решение, используя tidyverse:

library(tidyverse)

df1 %>%
  group_by(Person) %>%
  mutate(Abs = map_dbl(DAYS, ~ {
    if (!is.na(.x)) {
      d <<- .x
      +(d > 0)
    } else {
      d <<- d - 1
      +(d > 0)
    }
  }))

Answer 4

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

# The data
df1 <- data.frame(Person = c(1,1,1,1,1),
                  StartDate = c("01-01","02-01","03-01","04-01","05-01"),
                  DAYS = c(3,NA,NA,NA,1))

# Initialize the vector we want with zeros
df1$Absent <- 0

# we get the indices of all the non-zero day entries
inds <- which(!is.na(df1$DAYS))

# Now we are going to build a list of all the indices that should be
# set to one. These are the intervals from when absence starts to
# the number of days absent - 1
inds_to_change <- mapply(function(i,d){i:(i+d-1)}, inds, na.omit(df1$DAYS))

df1$Absent[unlist(inds_to_change)] <- 1
df1
#>   Person StartDate DAYS Absent
#> 1      1     01-01    3      1
#> 2      1     02-01   NA      1
#> 3      1     03-01   NA      1
#> 4      1     04-01   NA      0
#> 5      1     05-01    1      1

^{Создано в 2019-02-20 с помощью Представить пакет (v0.2.1)}