Rewrite unit parser

 fix #16, #17

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: timechange
 Title: Efficient Manipulation of Date-Times
-Version: 0.1.1
+Version: 0.1.1.9000
 Authors@R: c(person("Vitalie", "Spinu", email = "spinuvit@gmail.com", role = c("aut", "cre")),
              person("Google Inc.", role = c("ctb", "cph")))
 Description: Efficient routines for manipulation of date-time objects while

NEWS.md

@@ -1,21 +1,32 @@
+Version 0.1.1.9000
+=================
+
+## Bug Fixes
+
+ - [#16](https://github.com/vspinu/timechange/issues/16) Rounding unit parser is now conformant to R numeric parser
+
+## Internals
+
+ - [#17](https://github.com/vspinu/timechange/issues/17) Simplified and refactored unit parser.
+
 Version 0.1.1
 =============
 
 ## Changes
 
- * Follow vctrs replication rules
- * Change arguments of `time_add()` and `time_subtract()` to singulars
- * Build on top of cpp11 instead of Rcpp
+ - Follow vctrs replication rules
+ - Change arguments of `time_add()` and `time_subtract()` to singulars
+ - Build on top of cpp11 instead of Rcpp
 
 Version 0.1.0
 =============
 
 ## New Features:
 
- * Refactor `roll_month` and `roll_dst` parameterisation
+ - Refactor `roll_month` and `roll_dst` parameterisation
    + more intuitive names
    + full control over the behavior of repeated and skipped DST intervals
- * `time_update()` gains new argument `exact = FALSE` in order to enforce very strict updating rules
+ - `time_update()` gains new argument `exact = FALSE` in order to enforce very strict updating rules
 
 Version 0.0.2
 =============

R/round.R

@@ -199,10 +199,9 @@ time_round <- function(time, unit = "second", week_start = getOption("timechange
   if (length(time) == 0L)
     return(time)
 
-  parsed_unit <- parse_units(unit)
-  n <- parsed_unit$n
-  unit <- standardise_unit_name(parsed_unit$unit)
-  validate_nunit(unit, n)
+  nu <- parse_rounding_unit(unit)
+  n <- nu$n
+  unit <- nu$unit
 
   ct <- to_posixct(time)
 
@@ -233,16 +232,10 @@ time_floor <- function(time, unit = "seconds", week_start = getOption("timechang
   if (length(time) == 0)
     return(time)
 
-  parsed_unit <- parse_units(unit)
-  n <- parsed_unit$n
-  unit <- standardise_unit_name(parsed_unit$unit)
-  validate_nunit(unit, n)
+  nu <- parse_rounding_unit(unit)
 
-  from_posixct(C_time_floor(to_posixct(time),
-                            unit,
-                            n,
-                            as.integer(week_start)),
-               time, force_date = !unit %in% c("asecond", "second", "minute", "hour"))
+  from_posixct(C_time_floor(to_posixct(time), nu$unit, nu$n, as.integer(week_start)),
+               time, force_date = !nu$unit %in% c("asecond", "second", "minute", "hour"))
 
 }
 
@@ -255,17 +248,11 @@ time_ceiling <- function(time, unit = "seconds",
   if (length(time) == 0)
     return(time)
 
-  parsed_unit <- parse_units(unit)
-  n <- parsed_unit$n
-  unit <- standardise_unit_name(parsed_unit$unit)
-  validate_nunit(unit, n)
+  nu <- parse_rounding_unit(unit)
 
-  from_posixct(C_time_ceiling(to_posixct(time),
-                              unit,
-                              n,
-                              as.integer(week_start),
+  from_posixct(C_time_ceiling(to_posixct(time), nu$unit, nu$n, as.integer(week_start),
                               as.logical(change_on_boundary)),
-               time, force_date = !unit %in% c("second", "minute", "hour"))
+               time, force_date = !nu$unit %in% c("second", "minute", "hour"))
 }
 
 
@@ -277,7 +264,21 @@ base_units <- list(second = "secs", minute = "mins", hour = "hours", day = "days
 trunc_multi_limits <- c(asecond = Inf, second = 60, minute = 60, hour = 24, day = 31, year = Inf, week = 1,
                         month = 12, bimonth = 6, quarter = 4, season = 4, halfyear = 2)
 
-validate_nunit <- function(unit, n) {
-  if (n > trunc_multi_limits[[unit]])
-    stop(sprintf("Rounding with %s > %d is not supported. Use aseconds for arbitrary units.", unit, trunc_multi_limits[[unit]]))
+parse_rounding_unit <- function(unit) {
+  if (length(unit) > 1) {
+    warning("'unit' argument has length larger than 1. Using first element.")
+    unit <- unit[[1]]
+  }
+  validate_rounding_nunit(.Call(C_parse_unit, as.character(unit)))
+}
+
+# cOmpat: TODO: remove once lubridate no longer uses .normalize_multi_week_unit
+# https://github.com/tidyverse/lubridate/blob/8c67d9ceca5315ef636d4727348d8914aa5552ea/R/round.r#L206
+parse_units <- parse_rounding_unit
+
+validate_rounding_nunit <- function(nunit) {
+  if (nunit$n > trunc_multi_limits[[nunit$unit]])
+    stop(sprintf("Rounding with %s > %d is not supported. Use aseconds for arbitrary units.",
+                 nunit$unit, trunc_multi_limits[[nunit$unit]]))
+  nunit
 }

R/utils.R

@@ -73,66 +73,13 @@ from_posixlt <- function(new, old, force_date = FALSE) {
   }
 }
 
-
-## utilities copied from lubridate
-
 standardise_unit_name <- function(x) {
-  dates <- c("second", "minute", "hour", "day", "week", "month", "year",
-             ## these ones are used for rounding only
-             "asecond", "bimonth", "quarter", "halfyear", "season")
-  y <- gsub("(.)s$", "\\1", x)
-  y <- substr(y, 1, 3)
-  res <- dates[pmatch(y, dates)]
-  if (any(is.na(res))) {
-    stop("Invalid unit name: ", paste(x[is.na(res)], collapse = ", "),
-         call. = FALSE)
-  }
-  res
+  parse_unit(x)$unit
 }
 
-## return list(n=nr_units, unit="unit_name")
-parse_units <- function(unit) {
-
-  if (length(unit) > 1) {
-    warning("'unit' argument has length larger than 1. Using first element.")
-    unit <- unit[[1]]
-  }
-
-  p <- .Call(C_parse_period, as.character(unit))
-
-  if (!is.na(p[[1]])) {
-
-    units <- c("second", "minute", "hour", "day", "week", "month", "year")
-
-    wp <- which(p > 0)
-    if (length(wp) > 1) {
-      stop("Heterogeneous units are not supported in rounding operations.")
-    }
-
-    list(n = p[wp], unit = units[wp])
-
-  } else {
-    ## allow for bimonth, halfyear, quarter, season and asecond
-
-    m <- regexpr(" *(?<n>[0-9.,]+)? *(?<unit>[^ \t\n]+)", unit[[1]], perl = T)
-    if (m > 0) {
-      ## should always match
-      nms <- attr(m, "capture.names")
-      nms <- nms[nzchar(nms)]
-      start <- attr(m, "capture.start")
-      end <- start + attr(m, "capture.length") - 1L
-      n <- if (end[[1]] >= start[[1]]) {
-             as.numeric(substring(unit, start[[1]], end[[1]]))
-           } else {
-             1
-           }
-      unit <- substring(unit, start[[2]], end[[2]])
-      list(n = n, unit = unit)
-    } else {
-      stop(sprintf("Invalid unit specification '%s'", unit))
-    }
-
-  }
+#' @return list(n=nr_units, unit="unit-name")
+parse_unit <- function(unit) {
+  .Call(C_parse_unit, as.character(unit))
 }
 
 # Because `as.POSIXct.Date()` always uses local timezone

src/cpp11.cpp

@@ -78,10 +78,10 @@ extern "C" SEXP _timechange_C_local_clock(SEXP dt, SEXP tzs) {
 
 extern "C" {
 /* .Call calls */
-extern SEXP C_parse_period(SEXP);
+extern SEXP C_parse_unit(SEXP);
 
 static const R_CallMethodDef CallEntries[] = {
-    {"C_parse_period",             (DL_FUNC) &C_parse_period,             1},
+    {"C_parse_unit",               (DL_FUNC) &C_parse_unit,               1},
     {"_timechange_C_force_tz",     (DL_FUNC) &_timechange_C_force_tz,     3},
     {"_timechange_C_force_tzs",    (DL_FUNC) &_timechange_C_force_tzs,    4},
     {"_timechange_C_local_clock",  (DL_FUNC) &_timechange_C_local_clock,  2},