vctrs support

DESCRIPTION

@@ -12,7 +12,8 @@ Description: Implements an S3 class for storing and formatting time-of-day
 Imports:
     methods,
     pkgconfig,
-    rlang
+    rlang,
+    vctrs
 Suggests:
     crayon,
     lubridate,

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[<-",hms)
 S3method("[[",hms)
 S3method("units<-",hms)
 S3method(as.POSIXct,hms)
@@ -8,21 +9,53 @@ S3method(as.character,hms)
 S3method(as.data.frame,hms)
 S3method(as.hms,POSIXlt)
 S3method(as.hms,POSIXt)
-S3method(as.hms,character)
 S3method(as.hms,default)
-S3method(as.hms,difftime)
-S3method(as.hms,numeric)
 S3method(c,hms)
 S3method(format,hms)
 S3method(print,hms)
+S3method(vec_cast,hms)
+S3method(vec_cast.POSIXct,hms)
+S3method(vec_cast.POSIXlt,hms)
+S3method(vec_cast.character,hms)
+S3method(vec_cast.difftime,hms)
+S3method(vec_cast.double,hms)
+S3method(vec_cast.hms,POSIXct)
+S3method(vec_cast.hms,POSIXlt)
+S3method(vec_cast.hms,character)
+S3method(vec_cast.hms,default)
+S3method(vec_cast.hms,difftime)
+S3method(vec_cast.hms,double)
+S3method(vec_cast.hms,hms)
+S3method(vec_cast.hms,integer)
+S3method(vec_cast.hms,logical)
+S3method(vec_cast.integer,hms)
+S3method(vec_ptype_abbr,hms)
+S3method(vec_ptype_full,hms)
+S3method(vec_type2,hms)
+S3method(vec_type2.character,hms)
+S3method(vec_type2.difftime,hms)
+S3method(vec_type2.double,hms)
+S3method(vec_type2.hms,character)
+S3method(vec_type2.hms,default)
+S3method(vec_type2.hms,difftime)
+S3method(vec_type2.hms,double)
+S3method(vec_type2.hms,hms)
+S3method(vec_type2.hms,integer)
+S3method(vec_type2.hms,vctrs_unspecified)
+S3method(vec_type2.integer,hms)
 export(as.hms)
+export(as_hms)
 export(hms)
 export(is.hms)
 export(is_hms)
+export(new_hms)
 export(parse_hm)
 export(parse_hms)
 export(round_hms)
 export(trunc_hms)
+export(vec_cast.hms)
+export(vec_type2.hms)
 import(rlang)
+import(vctrs)
 importFrom(methods,setOldClass)
 importFrom(pkgconfig,get_config)

R/arith.R

@@ -46,7 +46,7 @@ tic_of_second <- function(x) {
 }
 
 decompose <- function(x) {
-  x <- as.numeric(x) * TICS_PER_SECOND
+  x <- vec_data(x) * TICS_PER_SECOND
 
   # #140
   xr <- round(x)

R/cast.R

@@ -0,0 +1,117 @@
+#' Casting
+#'
+#' Double dispatch methods to support [vctrs::vec_cast()].
+#'
+#' @inheritParams vctrs::vec_cast
+#'
+#' @method vec_cast hms
+#' @export
+#' @export vec_cast.hms
+vec_cast.hms <- function(x, to) UseMethod("vec_cast.hms")
+
+#' @method vec_cast.hms default
+#' @export
+vec_cast.hms.default <- function(x, to) stop_incompatible_cast(x, to)
+
+#' @method vec_cast.hms logical
+#' @export
+vec_cast.hms.logical <- function(x, to) vec_unspecified_cast(x, to)
+
+#' @method vec_cast.hms hms
+#' @export
+vec_cast.hms.hms <- function(x, to) x
+
+#' @method vec_cast.hms difftime
+#' @export
+vec_cast.hms.difftime <- function(x, to) {
+  units(x) <- "secs"
+  new_hms(vec_data(x))
+}
+
+#' @method vec_cast.difftime hms
+#' @export
+vec_cast.difftime.hms <- function(x, to) {
+  # as.difftime() doesn't change the class
+  class(x) <- "difftime"
+  vec_cast(x, to)
+}
+
+#' @method vec_cast.hms POSIXct
+#' @export
+vec_cast.hms.POSIXct <- function(x, to) {
+  vec_cast(as.POSIXlt(x), to)
+}
+
+#' @method vec_cast.POSIXct hms
+#' @export
+vec_cast.POSIXct.hms <- function(x, to) {
+  structure(as.numeric(x), tzone = "UTC", class = c("POSIXct", "POSIXt"))
+}
+
+#' @method vec_cast.hms POSIXlt
+#' @export
+vec_cast.hms.POSIXlt <- function(x, to) {
+  hms(x$sec, x$min, x$hour)
+}
+
+#' @method vec_cast.POSIXlt hms
+#' @export
+vec_cast.POSIXlt.hms <- function(x, to) {
+  as.POSIXlt(vec_cast(x, new_datetime()))
+}
+
+#' @method vec_cast.hms double
+#' @export
+vec_cast.hms.double <- function(x, to) new_hms(x)
+
+#' @method vec_cast.double hms
+#' @export
+vec_cast.double.hms <- function(x, to) vec_data(x)
+
+#' @method vec_cast.hms integer
+#' @export
+vec_cast.hms.integer <- function(x, to) new_hms(as.numeric(x))
+
+#' @method vec_cast.integer hms
+#' @export
+vec_cast.integer.hms <- function(x, to) as.integer(vec_data(x))
+
+#' @method vec_cast.hms character
+#' @export
+vec_cast.hms.character <- function(x, to) {
+  ret <- parse_hms(x)
+  lossy <- is.na(ret) && !is.na(x)
+  warn_lossy_cast(x, to, lossy)
+  ret
+}
+
+#' @method vec_cast.character hms
+#' @export
+vec_cast.character.hms <- function(x, to) format_hms(x)
+
+warn_lossy_cast <- function(x, to, lossy) {
+  problems <- which(lossy)
+  if (is_empty(problems)) return()
+
+  warn(paste0("Lossy cast from <character> to <hms> at position(s) ", commas(problems)))
+}
+
+commas <- function(problems) {
+  MAX_BULLETS <- 6L
+  if (length(problems) >= MAX_BULLETS) {
+    n_more <- length(problems) - MAX_BULLETS + 1L
+    problems[[MAX_BULLETS]] <-
+      paste0(pre_dots("(and "), n_more, " more)")
+    length(problems) <- MAX_BULLETS
+  }
+
+  paste0(problems, collapse = ", ")
+}
+
+pre_dots <- function(x) {
+  if (length(x) > 0) {
+    paste0("... ", x)
+  } else {
+    character()
+  }
+}

R/coerce.R

@@ -0,0 +1,63 @@
+#' Coercion
+#'
+#' Double dispatch methods to support [vctrs::vec_type2()].
+#'
+#' @inheritParams vctrs::vec_type2
+#'
+#' @method vec_type2 hms
+#' @export
+#' @export vec_type2.hms
+vec_type2.hms <- function(x, y) UseMethod("vec_type2.hms", y)
+
+#' @method vec_type2.hms default
+#' @export
+vec_type2.hms.default <- function(x, y) stop_incompatible_type(x, y)
+
+#' @method vec_type2.hms vctrs_unspecified
+#' @export
+vec_type2.hms.vctrs_unspecified <- function(x, y) x
+
+#' @method vec_type2.hms hms
+#' @export
+vec_type2.hms.hms <- function(x, y) hms::hms()
+
+#' @method vec_type2.difftime hms
+#' @export
+vec_type2.difftime.hms <- function(x, y) new_hms()
+
+#' @method vec_type2.hms difftime
+#' @export
+vec_type2.hms.difftime <- function(x, y) new_hms()
+
+#' @method vec_type2.double hms
+#' @export
+vec_type2.double.hms <- function(x, y) {
+  warn_deprecated("Coercion of <double> to <time> is deprecated and will be removed in a future version. Please use as_hms().")
+  new_hms()
+}
+
+#' @method vec_type2.hms double
+#' @export
+vec_type2.hms.double <- function(x, y) vec_type2.double.hms(y, x)
+
+#' @method vec_type2.integer hms
+#' @export
+vec_type2.integer.hms <- function(x, y) {
+  warn_deprecated("Coercion of <integer> to <time> is deprecated and will be removed in a future version. Please use as_hms().")
+  new_hms()
+}
+
+#' @method vec_type2.hms integer
+#' @export
+vec_type2.hms.integer <- function(x, y) vec_type2.integer.hms(y, x)
+
+#' @method vec_type2.character hms
+#' @export
+vec_type2.character.hms <- function(x, y) {
+  warn_deprecated("Coercion of <character> to <time> is deprecated and will be removed in a future version. Please use as_hms().")
+  new_hms()
+}
+
+#' @method vec_type2.hms character
+#' @export
+vec_type2.hms.character <- function(x, y) vec_type2.character.hms(y, x)