有效的日期向量化

Question

基本上，我有一个函数，我需要运行近一百万次，并且花费了很多时间，因为它没有向量化(我猜)

其思想是，有一个包含日期的参数pf.d.day，输出将是该日期的转换(添加/删除日期)

pf.s.Freq会将日期偏置到下一个期间。

2020年4月8日，Freq =“月”将变为2020年5月1日

2020年4月8日，Freq = "week“将变为2020年4月13日#周从星期一开始

2020年4月8日，Freq = "year“将成为2021年1月1日

library(dplyr)
library(lubridate)
fn.Delay <- function(pf.d.day, pf.s.Freq){
    d.DateWithouthDelay <- as.Date(
        #note: using chained ifs instead of parsing pf.s.Freq into unit to avoid errors from misspells on excel file
        ifelse(pf.s.Freq == "day",     as.character(ceiling_date(pf.d.day + days(1), unit = "day"    )),
        ifelse(pf.s.Freq == "week",    as.character(ceiling_date(pf.d.day + days(1), unit = "week", week_start = 1)),
        ifelse(pf.s.Freq == "month",   as.character(ceiling_date(pf.d.day + days(1), unit = "month"  )),
        ifelse(pf.s.Freq == "quarter", as.character(ceiling_date(pf.d.day + days(1), unit = "quarter")),
        ifelse(pf.s.Freq == "year",    as.character(ceiling_date(pf.d.day + days(1), unit = "year"   )),
        ifelse(pf.s.Freq != "BiWeek", "1900-1-2", #default date if pf.s.Freq is wrong
            ifelse( day(pf.d.day) < 15, 
                as.character(pf.d.day - day(pf.d.day) +15),
                as.character(ceiling_date(pf.d.day, unit = "month")))
        )))))))
    return(d.DateWithouthDelay)
}

举个小例子：

data.frame(
        Di = as.Date(c("2020-4-8", "2020-4-8", "2020-4-8", "2020-4-8", "2020-4-8", "2020-4-8", "2020-4-8")),
        Fr = c("day", "week", "month", "quarter", "year", "BiWeek", "ups")) %>% 
    rowwise() %>% 
    mutate(Df = fn.Delay(Di, Fr)) %>%
    data.frame() 

这段代码的主要问题是它的速度。主要是因为它没有矢量化，但也可能是因为我必须不断地在日期和字符之间切换，仅仅是因为ifelse喜欢把日期弄乱

Answer 1

你的函数是矢量化的。删除rowwise以提高速度，并获得相同的结果：

identical(
  dd %>% mutate(Df = fn.Delay(Di, Fr)) %>% pull(Df),
  dd %>%rowwise() %>% mutate(Df = fn.Delay(Di, Fr)) %>% pull(Df)
)
# TRUE

ifelse实际上并没有那么糟糕。这是一个使用case_when的简化版本，但与ifelse的性能差异可以忽略不计--实际上稍微慢了一点。但是代码更整洁。

fn.Delay2 <- function(pf.d.day, pf.s.Freq){
    case_when(
        pf.s.Freq == "day"     ~ ceiling_date(pf.d.day + days(1), unit = "day"),
        pf.s.Freq == "week"    ~ ceiling_date(pf.d.day + days(1), unit = "week", week_start = 1),
        pf.s.Freq == "month"   ~ ceiling_date(pf.d.day + days(1), unit = "month"  ),
        pf.s.Freq == "quarter" ~ ceiling_date(pf.d.day + days(1), unit = "quarter"),
        pf.s.Freq == "year"    ~ ceiling_date(pf.d.day + days(1), unit = "year"   ),
        pf.s.Freq != "BiWeek"  ~ as.Date("1900-1-2"), #default date if pf.s.Freq is wrong
        day(pf.d.day) < 15     ~ pf.d.day - day(pf.d.day) + 15,
        TRUE                   ~ ceiling_date(pf.d.day, unit = "month")
    )
}

microbenchmark::microbenchmark(
  rowwise = dd %>%rowwise() %>% mutate(Df = fn.Delay(Di, Fr)),
  vectorized = dd %>% mutate(Df = fn.Delay(Di, Fr)),
  case_when = dd %>% mutate(Df = fn.Delay2(Di, Fr))
)
# Unit: milliseconds
#        expr     min       lq     mean   median      uq     max neval
#     rowwise 10.0593 12.47230 13.59725 13.00590 14.1138 30.3810   100
#  vectorized  7.5237  7.97235 10.21504 10.26205 10.7905 25.7858   100
#   case_when  7.7331  8.43595 10.42024 10.54705 11.1035 21.4732   100