强大的 R 函数答案

【问题标题】：A Robust R Function强大的 R 函数
【发布时间】：2020-10-07 20:33:36
【问题描述】：

基于下面定义的手臂，我在dplyr::mutate 函数下编写了这些语句来定义事件。我想知道您是否可以帮助我编写一个可以减少代码行的函数，因为有些代码是重复的？谢谢

Arm- 1 (September 1, 2017- August 31, 2018)
 arm_1_event_1  <- c(as.Date("2017-09-01"), as.Date("2017-11-30"))
 arm_1_event_2  <- c(as.Date("2017-12-01"), as.Date("2018-02-28"))
 arm_1_event_3  <- c(as.Date("2018-03-01"), as.Date("2018-05-31"))
 arm_1_event_4  <- c(as.Date("2018-06-01"), as.Date("2018-08-31"))
Arm- 2 (September 1, 2018- August 31, 2019)
  arm_2_event_1  <- c(as.Date("2018-09-01"), as.Date("2018-11-30"))
  arm_2_event_2  <- c(as.Date("2018-12-01"), as.Date("2019-02-28"))
  arm_2_event_3  <- c(as.Date("2019-03-01"), as.Date("2019-05-31"))
  arm_2_event_4  <- c(as.Date("2019-06-01"), as.Date("2019-08-31"))
Arm- 3 (September 1, 2019- August 31, 2020)
  arm_3_event_1  <- c(as.Date("2019-09-01"), as.Date("2019-11-30"))
  arm_3_event_2  <- c(as.Date("2019-12-01"), as.Date("2020-02-29"))
  arm_3_event_3  <- c(as.Date("2020-03-01"), as.Date("2020-05-31"))
  arm_3_event_4  <- c(as.Date("2020-06-01"), as.Date("2020-08-31"))

dplyr::mutate(
 arms_and_events   =         NA_character_,
 arms_and_events   =         dplyr::case_when(
                                                                                    ((date_application_received >= arm_1_event_1[1] & 
date_application_received <= arm_1_event_1[2])  ~ "arm_1_event_1"),
                                                                                    ((date_application_received >= arm_1_event_2[1] & 
date_application_received <= arm_1_event_2[2])  ~ "arm_1_event_2"),
                                                                                    ((date_application_received >= arm_1_event_3[1] & 
date_application_received <= arm_1_event_3[2])  ~ "arm_1_event_3"),
                                                                                    ((date_application_received >= arm_1_event_4[1] & 
date_application_received <= arm_1_event_4[2])  ~ "arm_1_event_4"),
                                                                                    ((date_application_received >= arm_2_event_1[1] & 
date_application_received <= arm_2_event_1[2])  ~ "arm_2_event_1"),
                                                                                    ((date_application_received >= arm_2_event_2[1] &  
date_application_received <= arm_2_event_2[2])  ~ "arm_2_event_2"),
                                                                                    ((date_application_received >= arm_2_event_3[1] &  
date_application_received <= arm_2_event_3[2])  ~ "arm_2_event_3"),
                                                                                    ((date_application_received >= arm_2_event_4[1] 
& date_application_received <= arm_2_event_4[2]) ~ "arm_2_event_4"),
                                                                                    ((date_application_received >= arm_3_event_1[1] & 
date_application_received <= arm_3_event_1[2])   ~ "arm_3_event_1"),
                                                                                    ((date_application_received >= arm_3_event_2[1] & 
date_application_received <= arm_3_event_2[2])   ~ "arm_3_event_2"),
                                                                                    ((date_application_received >= arm_3_event_3[1] & 
date_application_received <= arm_3_event_3[2])   ~ "arm_3_event_3"),
                                                                                    ((date_application_received >= arm_3_event_4[1] & 
date_application_received <= arm_3_event_4[2])   ~ "arm_3_event_4"),
                                                                                    
((date_voucher_issued       >= arm_1_event_1[1] & 
date_voucher_issued       <= arm_1_event_1[2])   ~ "arm_1_event_1"),

((date_voucher_issued       >= arm_1_event_2[1] & 
date_voucher_issued       <= arm_1_event_2[2]) ~ "arm_1_event_2"),

((date_voucher_issued       >= arm_1_event_3[1] & 
date_voucher_issued       <= arm_1_event_3[2]) ~ "arm_1_event_3"),

((date_voucher_issued       >= arm_1_event_4[1] & 
date_voucher_issued       <= arm_1_event_4[2]) ~ "arm_1_event_4"),
                                                                                    
                                                                                    
((date_voucher_issued       >= arm_2_event_1[1] & 
date_voucher_issued       <= arm_2_event_1[2]) ~ "arm_2_event_1"),
                                                                                    
((date_voucher_issued       >= arm_2_event_2[1] & 
date_voucher_issued       <= arm_2_event_2[2]) ~ "arm_2_event_2"),

((date_voucher_issued       >= arm_2_event_3[1] & 
date_voucher_issued       <= arm_2_event_3[2]) ~ "arm_2_event_3"),
                                                                                    
((date_voucher_issued       >= arm_2_event_4[1] & 
date_voucher_issued       <= arm_2_event_4[2]) ~ "arm_2_event_4"),
                                                                                    
                                                                                    
((date_voucher_issued       >= arm_3_event_1[1] & 
date_voucher_issued       <= arm_3_event_1[2]) ~ "arm_3_event_1"),
                                                                                    
((date_voucher_issued       >= arm_3_event_2[1] & 
date_voucher_issued       <= arm_3_event_2[2]) ~ "arm_3_event_2"),

((date_voucher_issued       >= arm_3_event_3[1] & 
date_voucher_issued       <= arm_3_event_3[2]) ~ "arm_3_event_3"),
                                                                                    
((date_voucher_issued       >= arm_3_event_4[1] & 
date_voucher_issued       <= arm_3_event_4[2]) ~ "arm_3_event_4")
              
       )

【问题讨论】：

标签： r function date dplyr

【解决方案1】：

您的整个代码（包括第一个块中的分配）可以简化为一个简单的函数：

arm_and_event <- function(d)
{
  df <- data.frame(arm   = rep(1:3, each = 4), 
                   event = rep(1:4, 3),
                   start = as.Date(c("2017-09-01", "2017-12-01", "2018-03-01", 
                                     "2018-06-01", "2018-09-01", "2018-12-01", 
                                     "2019-03-01", "2019-06-01", "2019-09-01", 
                                     "2019-12-01", "2020-03-01", "2020-06-01")),
                   stop  = as.Date(c("2017-11-30", "2018-02-28", "2018-05-31", 
                                     "2018-08-31", "2018-11-30", "2019-02-28", 
                                     "2019-05-31", "2019-08-31", "2019-11-30", 
                                     "2020-02-29", "2020-05-31", "2020-08-31")))
  
  matches <- sapply(d, function(x) which(x >= df$start & x <= df$stop))  
  paste0("arm", df$arm[matches], "_event", df$event[matches])
}

因此，例如，如果我们有一个这样的日期向量：

date_application_received <- as.Date(c("2017-09-30", "2019-01-05"))

那么我们可以这样做：

arm_and_event(date_application_received)
#> [1] "arm1_event1" "arm2_event2"

我们的全局工作区没有被大量变量污染，而且代码更易于维护。

【讨论】：

我将此函数应用于所需的变量：```arms_and_events = arm_and_events_function(d$date_application_received) ``` 我收到以下错误：df$arm[matches] 中的错误：下标类型无效'列表'
你能解释一下这条线在做什么吗？匹配 = df$start & x
如果我在向量中包含缺失值，该函数不会运行。例如，如果我使用 date_application_received 运行函数，我会得到同样的错误
使用同一个函数怎么解决丢失问题？

【解决方案2】：

当我们考虑 NA 时，这个函数起作用：

 arms_and_events_function <- function(d)
  {
    df <- data.frame(arm   = rep(1:3, each = 4), 
                     event = rep(1:4, 3),
                     start = as.Date(c("2017-09-01", "2017-12-01", "2018-03-01", 
                                       "2018-06-01", "2018-09-01", "2018-12-01", 
                                       "2019-03-01", "2019-06-01", "2019-09-01", 
                                       "2019-12-01", "2020-03-01", "2020-06-01")),
                     stop  = as.Date(c("2017-11-30", "2018-02-28", "2018-05-31", 
                                       "2018-08-31", "2018-11-30", "2019-02-28", 
                                       "2019-05-31", "2019-08-31", "2019-11-30", 
                                       "2020-02-29", "2020-05-31", "2020-08-31"))
      )
    
      sapply(d, function(x) if(is.na(x)) NA else {
        inds <- which(x >= df$start & x<= df$stop)
        paste0("arm_", df$arm[inds], "_event_", df$event[inds])
      })
  }

谢谢！

【讨论】：