R ~ Векторизация пользовательской функции

Question

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

Вот функция, которая будет давать количество дней недели между двумя датами:

removeWeekends <- function(end, start){

  range <- as.Date(start:end, "1970-01-01")

  range<- range[sapply(range, function(x){
                                if(!chron::is.weekend(x)){
                                  return(TRUE)
                                }else{
                                  return(FALSE)
                                }
                              })]

  return(NROW(range))

}

, которая работает, когда ей присваивается одна дата для каждого аргумента:

removeWeekends(as.Date("2018-05-08"), as.Date("2018-06-08"))
#[1] 24

Но когда ему дается два вектора из фрейма данных, происходит сбой:

one <- as.Date("2017-01-01"):as.Date("2017-01-08")
two <- as.Date("2018-06-08"):as.Date("2018-06-15")
df <- data.frame(one, two)
removeWeekends(df$two, df$one)
#[1] 375
#Warning messages:
#1: In start:end : numerical expression has 8 elements: only the first used
#2: In start:end : numerical expression has 8 elements: only the first used

Я также попробовал (что, как я догадался, не сработает, так как синтаксис кажется отключенным):

lapply(df, removeWeekends, df$two, df$one)
#Error in FUN(X[[i]], ...) : unused argument (17167:17174)

И:

lapply(df[,c("two", "one")], removeWeekends)
#Error in as.Date(start:end, "1970-01-01") :   argument "start" is missing,
# with no default 

Я предполагаю, что я неправильно понимаю концепцию векторизации.

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

Answer 1

Если вы хотите полностью векторизовать это, вам нужно будет подумать «из коробки».chron::is.weekend просто проверяет, сколько дней было воскресеньям и субботам в определенный период времени.Мы можем вычислить это сами векторизованным способом, потому что у каждой недели есть два выходных, и единственная сложная часть - это оставшиеся кадры.

Я написал следующую функцию для достижения этой цели, хотя я уверен, что это можно улучшить

frw <- function(two, one) {

  diff_d <- two - one ## difference in days
  l_d <- (two + 4L) %% 7L + 1L ## last day of the remainder 
  weeks <- diff_d %/% 7L ## number of weeks between
  days <- diff_d %% 7L ## days left

  ## calculate how many work days left
  diff_d - 
    ((weeks * 2L) + ((l_d - days < 1) + ((l_d - days < 2) - (l_d == 1L))) +
    (l_d %in% c(1L, 7L))) + 1L

}

Вы можете запустить его следующим образом

frw(two, one)
## [1] 375 375 374 374 374 374 374 375

Этонамного быстрее, чем mapply версия (почти мгновенная), некоторые тесты для больших данных:

one <- as.Date("2017-01-01"):as.Date("2030-01-08")
two <- as.Date("2017-05-01"):as.Date("2030-05-08")
df <- data.frame(one, two)

system.time(res_mapply <- vremoveWeekends(df$two, df$one)) # taken from the other answer
#  user  system elapsed 
# 76.46    0.06   77.25 

system.time(res_vectorized <- frw(df$two, df$one))
# user  system elapsed 
#    0       0       0

identical(res_mapply, res_vectorized)
# [1] TRUE

Answer 2

У вас есть пара опций для поддержки аргумента vectorized в функции.Поскольку вы уже написали свою функцию, самым простым вариантом будет использование Vectorize и преобразование вашей функции для поддержки векторизованных аргументов.Другой вариант - изменить вашу функцию и переписать ее для поддержки векторизованных аргументов.

Опция № 1: Использование Vectorize

# Function will support vectorized argument with single statement
vremoveWeekends  <- Vectorize(removeWeekends)

# Try vremoveWeekends  function 
df$dayswithoutweekends <- vremoveWeekends(df$two, df$one)

Опция № 2: Переписать функцию для поддержки векторизованных аргументов.Я предпочту эту опцию, поскольку OP получил два аргумента одинаковой длины.Следовательно, будет проще выполнять проверку ошибок аргументов, если мы переписываем ее.

# Modified function 
removeWeekendsNew <- function(end, start){
  if(length(start) != length(end)){
    return(0L)  #Error condition
  }
  result <- rep(0L, length(start)) #store the result for each row

  #One can use mapply instead of for-loop. But for-loop will be faster
  for(i in seq_along(start)){     
    range      = seq(start[i], end[i], by="day")
    result[i]  = length(range[!chron::is.weekend(range)])
  }

  return(result)
}

#Use new function:
df$dayswithoutweekends <- removeWeekendsNew(df$two, df$one)

Результат: То же самое для обоих вариантов, упомянутых выше.

df
#          one        two dayswithoutweekends
# 1 2017-01-01 2018-06-08                 375
# 2 2017-01-02 2018-06-09                 375
# 3 2017-01-03 2018-06-10                 374
# 4 2017-01-04 2018-06-11                 374
# 5 2017-01-05 2018-06-12                 374
# 6 2017-01-06 2018-06-13                 374
# 7 2017-01-07 2018-06-14                 374
# 8 2017-01-08 2018-06-15                 375

Данные:

one <- seq(as.Date("2017-01-01"),as.Date("2017-01-08"), by="day")
two <- seq(as.Date("2018-06-08"),as.Date("2018-06-15"), by="day")
df <- data.frame(one, two)
df
#          one        two
# 1 2017-01-01 2018-06-08
# 2 2017-01-02 2018-06-09
# 3 2017-01-03 2018-06-10
# 4 2017-01-04 2018-06-11
# 5 2017-01-05 2018-06-12
# 6 2017-01-06 2018-06-13
# 7 2017-01-07 2018-06-14
# 8 2017-01-08 2018-06-15