ARROW-16516: [R] Implement ym() my() and yq() parsers

r/R/dplyr-datetime-helpers.R

@@ -159,6 +159,26 @@ build_formats <- function(orders) {
  orders <- gsub("[^A-Za-z_]", "", orders)
  orders <- gsub("Y", "y", orders)
 
+ # we separate "ym', "my", and "yq" from the rest of the `orders` vector and
+ # transform them. `ym` and `yq` -> `ymd` & `my` -> `myd`
+ # this is needed for 2 reasons:
+ # 1. strptime does not parse "2022-05" -> we add "-01", thus changing the format,
+ # 2. for equivalence to lubridate, which parses `ym` to the first day of the month
+ short_orders <- c("ym", "my")
+
+ if (any(orders %in% short_orders)) {
+ orders1 <- setdiff(orders, short_orders)
+ orders2 <- intersect(orders, short_orders)
+ orders2 <- paste0(orders2, "d")
+ orders <- unique(c(orders1, orders2))
+ }
+
+ if (any(orders == "yq")) {
+ orders1 <- setdiff(orders, "yq")
+ orders2 <- "ymd"
+ orders <- unique(c(orders1, orders2))
+ }
+
  supported_orders <- c("ymd", "ydm", "mdy", "myd", "dmy", "dym")
  unsupported_passed_orders <- setdiff(orders, supported_orders)
  supported_passed_orders <- intersect(orders, supported_orders)
@@ -176,7 +196,8 @@ build_formats <- function(orders) {
  }
 
  formats_list <- map(orders, build_format_from_order)
- purrr::flatten_chr(formats_list)
+ formats <- purrr::flatten_chr(formats_list)
+ unique(formats)
 }
 
 build_format_from_order <- function(order) {

r/R/dplyr-funcs-datetime.R

@@ -493,27 +493,99 @@ register_bindings_datetime_parsers <- function() {
  # each order is translated into possible formats
  formats <- build_formats(orders)
 
+ x <- x$cast(string())
+
  # make all separators (non-letters and non-numbers) into "-"
  x <- call_binding("gsub", "[^A-Za-z0-9]", "-", x)
  # collapse multiple separators into a single one
  x <- call_binding("gsub", "-{2,}", "-", x)
 
+ # we need to transform `x` when orders are `ym`, `my`, and `yq`
+ # for `ym` and `my` orders we add a day ("01")
+ augmented_x <- NULL
+ if (any(orders %in% c("ym", "my"))) {
+ augmented_x <- call_binding("paste0", x, "-01")
+ }
+
+ # for `yq` we need to transform the quarter into the start month (lubridate
+ # behaviour) and then add 01 to parse to the first day of the quarter
+ augmented_x2 <- NULL
+ if (any(orders == "yq")) {
+ # extract everything that comes after the `-` separator, i.e. the quarter
+ # (e.g. 4 from 2022-4)
+ quarter_x <- call_binding("gsub", "^.*?-", "", x)
+ # we should probably error if quarter is not in 1:4
+ # extract everything that comes before the `-`, i.e. the year (e.g. 2002
+ # in 2002-4)
+ year_x <- call_binding("gsub", "-.*$", "", x)
+ quarter_x <- quarter_x$cast(int32())
+ month_x <- (quarter_x - 1) * 3 + 1
+ augmented_x2 <- call_binding("paste0", year_x, "-", month_x, "-01")
+ }
+
  # TODO figure out how to parse strings that have no separators
  # https://issues.apache.org/jira/browse/ARROW-16446
  # we could insert separators at the "likely" positions, but it might be
  # tricky given the possible combinations between dmy formats + locale
 
  # build a list of expressions for each format
- parse_attempt_expressions <- list()
-
- for (i in seq_along(formats)) {
- parse_attempt_expressions[[i]] <- build_expr(
+ parse_attempt_expressions <- map(
+ formats,
+ ~ build_expr(
  "strptime",
  x,
- options = list(format = formats[[i]], unit = 0L, error_is_null = TRUE)
+ options = list(
+ format = .x,
+ unit = 0L,
+ error_is_null = TRUE
+ )
+ )
+ )
+
+ # build separate expression lists of parsing attempts for the orders that
+ # need an augmented `x`
+ # list for attempts when orders %in% c("ym", "my")
+ parse_attempt_exp_augmented_x <- list()
+
+ if (!is.null(augmented_x)) {
+ parse_attempt_exp_augmented_x <- map(
+ formats,
+ ~ build_expr(
+ "strptime",
+ augmented_x,
+ options = list(
+ format = .x,
+ unit = 0L,
+ error_is_null = TRUE
+ )
+ )
  )
  }
 
+ # list for attempts when orders %in% c("yq")
+ parse_attempt_exp_augmented_x2 <- list()
+ if (!is.null(augmented_x2)) {
+ parse_attempt_exp_augmented_x2 <- map(
+ formats,
+ ~ build_expr(
+ "strptime",
+ augmented_x2,
+ options = list(
+ format = .x,
+ unit = 0L,
+ error_is_null = TRUE
+ )
+ )
+ )
+ }
+
+ # combine all attempts expressions in prep for coalesce
+ parse_attempt_expressions <- c(
+ parse_attempt_expressions,
+ parse_attempt_exp_augmented_x,
+ parse_attempt_exp_augmented_x2
+ )
+
  coalesce_output <- build_expr("coalesce", args = parse_attempt_expressions)
 
  # we need this binding to be able to handle a NULL `tz`, which will then be
@@ -527,7 +599,7 @@ register_bindings_datetime_parsers <- function() {
 
  })
 
- ymd_parser_vec <- c("ymd", "ydm", "mdy", "myd", "dmy", "dym")
+ ymd_parser_vec <- c("ymd", "ydm", "mdy", "myd", "dmy", "dym", "ym", "my", "yq")
 
  ymd_parser_map_factory <- function(order) {
  force(order)

r/tests/testthat/test-dplyr-funcs-datetime.R

@@ -1735,7 +1735,7 @@ test_that("parse_date_time() doesn't work with hour, minutes, and second compone
  )
 })
 
-test_that("year, month, day date/time parsers work", {
+test_that("year, month, day date/time parsers", {
  test_df <- tibble::tibble(
  ymd_string = c("2022-05-11", "2022/05/12", "22.05-13"),
  ydm_string = c("2022-11-05", "2022/12/05", "22.13-05"),
@@ -1776,3 +1776,39 @@ test_that("year, month, day date/time parsers work", {
  test_df
  )
 })
+
+test_that("ym, my & yq parsers", {
+ test_df <- tibble::tibble(
+ ym_string = c("2022-05", "2022/02", "22.03", "1979//12", "88.09", NA),
+ my_string = c("05-2022", "02/2022", "03.22", "12//1979", "09.88", NA),
+ yq_string = c("2007.3", "1970.2", "2020.1", "2009.4", "1975.1", NA),
+ yq_numeric = c(2007.3, 1970.2, 2020.1, 2009.4, 1975.1, NA),
+ yq_space = c("2007 3", "1970 2", "2020 1", "2009 4", "1975 1", NA)
+ )
+
+ # these functions' internals use some string processing which requires the
+ # RE2 library (not available on Windows with R 3.6)
+ skip_if_not_available("re2")
+ compare_dplyr_binding(
+ .input %>%
+ mutate(
+ ym_date = ym(ym_string),
+ ym_datetime = ym(ym_string, tz = "Pacific/Marquesas"),
+ my_date = my(my_string),
+ my_datetime = my(my_string, tz = "Pacific/Marquesas"),
+ yq_date_from_string = yq(yq_string),
+ yq_datetime_from_string = yq(yq_string, tz = "Pacific/Marquesas"),
+ yq_date_from_numeric = yq(yq_numeric),
+ yq_datetime_from_numeric = yq(yq_numeric, tz = "Pacific/Marquesas"),
+ yq_date_from_string_with_space = yq(yq_space),
+ yq_datetime_from_string_with_space = yq(yq_space, tz = "Pacific/Marquesas"),
+ ym_date2 = parse_date_time(ym_string, orders = c("ym", "ymd")),
+ my_date2 = parse_date_time(my_string, orders = c("my", "myd")),
+ yq_date_from_string2 = parse_date_time(yq_string, orders = "yq"),
+ yq_date_from_numeric2 = parse_date_time(yq_numeric, orders = "yq"),
+ yq_date_from_string_with_space2 = parse_date_time(yq_space, orders = "yq")
+ ) %>%
+ collect(),
+ test_df
+ )
+})