效率与R中的日期一起工作

Question

我有一个函数用于计算两个日期之间的差异。我有一个包含超过40万条记录的数据集，并且我无法使其按规模工作。

功能：

library(lubridate) 
get_recency <- function(last_gift_date, refresh_date) { 
    last_gift_date <- as.Date(last_gift_date) 
    refresh_date <- as.Date(refresh_date) 

    case_when(
    is.na(last_gift_date) ~ "ERROR", 
    last_gift_date > refresh_date ~ "ERROR", 
    last_gift_date %m+% months(12) >= refresh_date ~ "0-12", 
    last_gift_date %m+% months(24) >= refresh_date ~ "13-24", 
    last_gift_date %m+% months(36) >= refresh_date ~ "25-36", 
    last_gift_date %m+% months(48) >= refresh_date ~ "37-48", 
    last_gift_date %m+% months(60) >= refresh_date ~ "49-60", 
    last_gift_date %m+% months(72) >= refresh_date ~ "61-72", 
    last_gift_date %m+% months(84) >= refresh_date ~ "73-84", 
    TRUE ~ "85+") 
} 

如果我通过一个日期到refresh_date参数似乎执行精细，但是当我在传递一个等效长度矢量，它需要超长。

任何想法如何改善这将不胜感激。

实例来运行代码：

a<- c("2014-01-29", "2015-04-07", "2015-04-10") 
b<- c(NA, "2014-01-29", "2015-04-07") 
get_recency(b,a) 

# OUTPUT 
#[1] "ERROR" "13-24" "0-12" 

UPDATE 2017年7月10日 我把@Akrun的意见和利用了cut()功能。它具有更快，更简洁的代码的好处。结果如下。

get_recency <- function(last_gift_date, refresh_date) { 
    last_gift_date <- as.Date(last_gift_date) 
    refresh_date <- as.Date(refresh_date) 

    x <- (as.yearmon(refresh_date)-as.yearmon(last_gift_date))*12 

    x <- replace(x, is.na(x), -Inf) 

    cut(x, breaks = c(-Inf, -0.000001, 12, 24, 36, 48, 60, 72, 84, Inf), 
     labels = c("ERROR", "0-12", "13-24", "25-36", "37-48", 
       "49-60", "61-72", "73-84", "85+"), 
     include.lowest = T) 
} 

Answer 1

library(lubridate) 
library(dplyr) 

a <- c("2014-01-29", "2015-04-07", "2015-04-10", "2025-04-10") 
b <- c(NA, "2014-01-29", "2015-04-07", "2015-04-07") 
intervals <- 12 * 1:7 

get_recency <- function(last_gift_date, refresh_date, intervals) { 


    last_gift_date <- as.Date(last_gift_date) 
    refresh_date <- as.Date(refresh_date) 

    intervals_chr <- c(
    "ERROR", 
    paste(c(0, intervals[-length(intervals)] + 1), intervals, sep = "-"), 
    paste0(tail(intervals, 1) + 1, "+") 
) 

    code <- sapply(c(0, intervals), function(n) { 
    last_gift_date %m+% months(n) < refresh_date 
    }) %>% 
    rowSums() 

    if_else(condition = is.na(code), true = "ERROR", 
      false = intervals_chr[code + 1]) 
} 

get_recency(b, a, intervals) 

[1] "ERROR" "13-24" "0-12" "85+" 

这样快？