R ~ 用户定义函数的向量化

Question

我需要编写一个函数来计算工作日数（减去周末，以及其他当地银行假期的向量），但我遇到的问题更简单地说明了只计算工作日的数量工作日。

这是一个函数，它将给出两个日期之间的工作日数：

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 

我假设是我误解了矢量化的概念。

我唯一的另一个想法是将函数嵌套在条件中以查看它是否是向量，然后在其上调用 apply 函数，尽管我也不太确定我将如何构造它。

Answer 1

你有几个选项来支持函数中的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

Answer 2

如果您想完全矢量化，您需要开箱即用。 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