Add vec-ptype method for sys-time and naive-time

Author: DavisVaughan

NAMESPACE

@@ -431,6 +431,8 @@ S3method(vec_proxy,clock_zoned_time)
 S3method(vec_proxy_compare,clock_weekday)
 S3method(vec_proxy_compare,clock_year_month_weekday)
 S3method(vec_ptype,clock_iso_year_week_day)
+S3method(vec_ptype,clock_naive_time)
+S3method(vec_ptype,clock_sys_time)
 S3method(vec_ptype,clock_year_month_day)
 S3method(vec_ptype,clock_year_month_weekday)
 S3method(vec_ptype,clock_year_quarter_day)

R/naive-time.R

@@ -697,6 +697,25 @@ new_naive_info_from_fields <- function(fields) {
 
 # ------------------------------------------------------------------------------
 
+#' @export
+vec_ptype.clock_naive_time <- function(x, ...) {
+  switch(
+    time_point_precision(x) + 1L,
+    abort("Internal error: Invalid precision"),
+    abort("Internal error: Invalid precision"),
+    abort("Internal error: Invalid precision"),
+    abort("Internal error: Invalid precision"),
+    clock_empty_naive_time_day,
+    clock_empty_naive_time_hour,
+    clock_empty_naive_time_minute,
+    clock_empty_naive_time_second,
+    clock_empty_naive_time_millisecond,
+    clock_empty_naive_time_microsecond,
+    clock_empty_naive_time_nanosecond,
+    abort("Internal error: Invalid precision.")
+  )
+}
+
 #' @export
 vec_ptype2.clock_naive_time.clock_naive_time <- function(x, y, ...) {
   ptype2_time_point_and_time_point(x, y, ...)
@@ -751,3 +770,19 @@ vec_arith.clock_naive_time.numeric <- function(op, x, y, ...) {
 vec_arith.numeric.clock_naive_time <- function(op, x, y, ...) {
   arith_numeric_and_time_point(op, x, y, ...)
 }
+
+# ------------------------------------------------------------------------------
+
+clock_init_naive_time_utils <- function(env) {
+  day <- as_naive(year_month_day(integer(), integer(), integer()))
+
+  assign("clock_empty_naive_time_day", day, envir = env)
+  assign("clock_empty_naive_time_hour", time_point_cast(day, "hour"), envir = env)
+  assign("clock_empty_naive_time_minute", time_point_cast(day, "minute"), envir = env)
+  assign("clock_empty_naive_time_second", time_point_cast(day, "second"), envir = env)
+  assign("clock_empty_naive_time_millisecond", time_point_cast(day, "millisecond"), envir = env)
+  assign("clock_empty_naive_time_microsecond", time_point_cast(day, "microsecond"), envir = env)
+  assign("clock_empty_naive_time_nanosecond", time_point_cast(day, "nanosecond"), envir = env)
+
+  invisible(NULL)
+}

R/sys-time.R

@@ -416,6 +416,25 @@ new_sys_info_from_fields <- function(fields) {
 
 # ------------------------------------------------------------------------------
 
+#' @export
+vec_ptype.clock_sys_time <- function(x, ...) {
+  switch(
+    time_point_precision(x) + 1L,
+    abort("Internal error: Invalid precision"),
+    abort("Internal error: Invalid precision"),
+    abort("Internal error: Invalid precision"),
+    abort("Internal error: Invalid precision"),
+    clock_empty_sys_time_day,
+    clock_empty_sys_time_hour,
+    clock_empty_sys_time_minute,
+    clock_empty_sys_time_second,
+    clock_empty_sys_time_millisecond,
+    clock_empty_sys_time_microsecond,
+    clock_empty_sys_time_nanosecond,
+    abort("Internal error: Invalid precision.")
+  )
+}
+
 #' @export
 vec_ptype2.clock_sys_time.clock_sys_time <- function(x, y, ...) {
   ptype2_time_point_and_time_point(x, y, ...)
@@ -471,3 +490,18 @@ vec_arith.numeric.clock_sys_time <- function(op, x, y, ...) {
   arith_numeric_and_time_point(op, x, y, ...)
 }
 
+# ------------------------------------------------------------------------------
+
+clock_init_sys_time_utils <- function(env) {
+  day <- as_sys(year_month_day(integer(), integer(), integer()))
+
+  assign("clock_empty_sys_time_day", day, envir = env)
+  assign("clock_empty_sys_time_hour", time_point_cast(day, "hour"), envir = env)
+  assign("clock_empty_sys_time_minute", time_point_cast(day, "minute"), envir = env)
+  assign("clock_empty_sys_time_second", time_point_cast(day, "second"), envir = env)
+  assign("clock_empty_sys_time_millisecond", time_point_cast(day, "millisecond"), envir = env)
+  assign("clock_empty_sys_time_microsecond", time_point_cast(day, "microsecond"), envir = env)
+  assign("clock_empty_sys_time_nanosecond", time_point_cast(day, "nanosecond"), envir = env)
+
+  invisible(NULL)
+}

R/zzz.R

@@ -12,6 +12,8 @@
   clock_init_year_month_day_utils(clock_ns)
   clock_init_year_month_weekday_utils(clock_ns)
   clock_init_iso_year_week_day_utils(clock_ns)
+  clock_init_sys_time_utils(clock_ns)
+  clock_init_naive_time_utils(clock_ns)
 
   vctrs::s3_register("pillar::pillar_shaft", "clock_calendar", pillar_shaft.clock_calendar)
   vctrs::s3_register("pillar::pillar_shaft", "clock_time_point", pillar_shaft.clock_time_point)

tests/testthat/test-naive-time.R

@@ -495,3 +495,22 @@ test_that("strict mode can be activated - ambiguous", {
   expect_snapshot_error(as_zoned(naive_seconds(), zone, nonexistent = "roll-forward", ambiguous = zt))
   expect_snapshot_error(as_zoned(naive_seconds(), zone, nonexistent = "roll-forward", ambiguous = list(zt, NULL)))
 })
+
+# ------------------------------------------------------------------------------
+# vec_ptype()
+
+test_that("ptype is correct", {
+  base <- naive_days(0)
+  ptype <- naive_days(integer())
+
+  for (precision in precision_names()) {
+    if (validate_precision_string(precision) < PRECISION_DAY) {
+      next
+    }
+
+    x <- time_point_cast(base, precision)
+    expect <- time_point_cast(ptype, precision)
+
+    expect_identical(vec_ptype(x), expect)
+  }
+})

tests/testthat/test-sys-time.R

@@ -119,3 +119,22 @@ test_that("failure to parse throws a warning", {
   expect_warning(sys_parse("foo"), class = "clock_warning_parse_failures")
   expect_snapshot(sys_parse("foo"))
 })
+
+# ------------------------------------------------------------------------------
+# vec_ptype()
+
+test_that("ptype is correct", {
+  base <- sys_days(0)
+  ptype <- sys_days(integer())
+
+  for (precision in precision_names()) {
+    if (validate_precision_string(precision) < PRECISION_DAY) {
+      next
+    }
+
+    x <- time_point_cast(base, precision)
+    expect <- time_point_cast(ptype, precision)
+
+    expect_identical(vec_ptype(x), expect)
+  }
+})