[med-svn] [r-cran-hms] 01/06: New upstream version 0.4.0
Andreas Tille
tille at debian.org
Tue Jan 2 07:56:38 UTC 2018
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-hms.
commit 78f58e021e459f91fd3c44dbf9ceacd8f31d2afa
Author: Andreas Tille <tille at debian.org>
Date: Tue Jan 2 08:04:49 2018 +0100
New upstream version 0.4.0
---
DESCRIPTION | 18 ++---
MD5 | 40 +++++++---
NAMESPACE | 8 ++
NEWS.md | 30 ++++++++
R/args.R | 25 +++++++
R/arith.R | 10 +++
R/compat-purrr.R | 162 ++++++++++++++++++++++++++++++++++++++++
R/format.R | 11 ++-
R/hms.R | 84 +++++++++++----------
R/parse.R | 24 ++++++
R/pillar.R | 52 +++++++++++++
R/round.R | 22 ++++++
R/zzz.R | 31 ++++++++
README.md | 8 +-
man/hms.Rd | 26 ++++---
man/parse_hms.Rd | 29 +++++++
man/round_hms.Rd | 28 +++++++
tests/testthat/helper-pillar.R | 4 +
tests/testthat/out/hm.txt | 6 ++
tests/testthat/out/hms.txt | 10 +++
tests/testthat/out/hmss.txt | 10 +++
tests/testthat/out/ms.txt | 6 ++
tests/testthat/out/mss.txt | 8 ++
tests/testthat/test-coercion.R | 11 ++-
tests/testthat/test-colformat.R | 24 ++++++
tests/testthat/test-combine.R | 18 +++++
tests/testthat/test-construct.R | 21 +++++-
tests/testthat/test-output.R | 2 +-
tests/testthat/test-parse.R | 14 ++++
tests/testthat/test-round.R | 17 +++++
30 files changed, 676 insertions(+), 83 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index dcd8e54..fd32c9c 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,25 +1,25 @@
Package: hms
Title: Pretty Time of Day
-Date: 2016-11-22
-Version: 0.3
+Date: 2017-11-16
+Version: 0.4.0
Authors at R: c(
person("Kirill", "Müller", role = c("aut", "cre"), email = "krlmlr+r at mailbox.org"),
person("The R Consortium", role = "cph")
)
Description: Implements an S3 class for storing and formatting time-of-day
values, based on the 'difftime' class.
-Imports: methods
-Suggests: testthat, lubridate
+Imports: methods, pkgconfig, rlang
+Suggests: crayon, lubridate, pillar, testthat
License: GPL-3
Encoding: UTF-8
LazyData: true
-URL: https://github.com/rstats-db/hms
-BugReports: https://github.com/rstats-db/hms/issues
-RoxygenNote: 5.0.1.9000
+URL: https://github.com/tidyverse/hms
+BugReports: https://github.com/tidyverse/hms/issues
+RoxygenNote: 6.0.1
NeedsCompilation: no
-Packaged: 2016-11-22 14:45:31 UTC; muelleki
+Packaged: 2017-11-22 10:27:35 UTC; muelleki
Author: Kirill Müller [aut, cre],
The R Consortium [cph]
Maintainer: Kirill Müller <krlmlr+r at mailbox.org>
Repository: CRAN
-Date/Publication: 2016-11-22 17:08:01
+Date/Publication: 2017-11-23 00:45:05 UTC
diff --git a/MD5 b/MD5
index 2bf6d5c..75aed3e 100644
--- a/MD5
+++ b/MD5
@@ -1,18 +1,36 @@
-71887e025bbc9f8d685076ba4ffd93bf *DESCRIPTION
-6fc52dc59347352469b948db5793ffd3 *NAMESPACE
-d0bf58dc51571b1764786f0337936a56 *NEWS.md
+7feaecc83f2460071b5aa3a1c9c4b933 *DESCRIPTION
+1113606c0b5e64437766950b624a4afc *NAMESPACE
+f814ae2a18aa038b75d965609e252ffa *NEWS.md
fcdf13180407d2fdf40bd661731c2c17 *R/aaa-tools.R
-2b89e2462be5b7d72097c68a4b6c654a *R/arith.R
-8b37fabf6c7f076a6353dc7c260a3d31 *R/format.R
-6f9bba739966b4e509beaa502bce509a *R/hms.R
-86bc8de6929f0043166a736a3fdf1af9 *README.md
-4fedd87423f6f51ccf2aca9558a07e60 *man/hms.Rd
+1fee82e810be4583b57360d2f66e1ee3 *R/args.R
+7df8b329ec567d5034a611c80b293bae *R/arith.R
+feaa904f11d6970ddbc1057a30cf6610 *R/compat-purrr.R
+e9ffa388353c6308807e460f5d305d68 *R/format.R
+0008f91aa0f29daab622a07cd515406a *R/hms.R
+c494e482c2c2e9ecb501cb7c1c96c904 *R/parse.R
+f7f458c6052378720f7924e92a426bae *R/pillar.R
+431e1aca642539fad198d2f1773a25a6 *R/round.R
+564e931b9db52faf3090415a10a62096 *R/zzz.R
+3ceda9573d7cfddc5abc01a9c424f8fa *README.md
+6229c2a0e885be9f4c43e0653b170860 *man/hms.Rd
+47436ae731f3fb89b03f7738b38c07df *man/parse_hms.Rd
+9c9a480061f0b21e078fa4ad07c686d6 *man/round_hms.Rd
929afdb21c50685048246bdc5d82207d *tests/testthat.R
fc7098abdba1003efcde210eced441ac *tests/testthat/helper-compare.R
+9e06811acc259fc01016555a8d6c43fa *tests/testthat/helper-pillar.R
+e62b16d4a6b54887a2d796f01d6be2a9 *tests/testthat/out/hm.txt
+d4004d7ed8d684f185525e8f95d2854a *tests/testthat/out/hms.txt
+e0eb8d7ee8eeee4b1a6e4d050944e182 *tests/testthat/out/hmss.txt
+80e943c2e942458a82800a7ae74b4c70 *tests/testthat/out/ms.txt
+79f4dbf41ce81791ddcf6d8602c4edb2 *tests/testthat/out/mss.txt
baa00de5b6dad9da9a13212b4dfa0da0 *tests/testthat/test-arith.R
-6c97d9c126f0a3f9ecefe6934e0a6fac *tests/testthat/test-coercion.R
-86ca91c46da5d129c7585c3917826596 *tests/testthat/test-construct.R
+6bd9510a73ac0fdbc3a29fdba7ce3db2 *tests/testthat/test-coercion.R
+888229c88d533dd8aa088dc432c3b6b7 *tests/testthat/test-colformat.R
+f163345c83326e50f8ec79f8a8e88436 *tests/testthat/test-combine.R
+d520e015b08a6218f62bd92f8fe480c2 *tests/testthat/test-construct.R
8a0858c5e546d54f7719e77a7940b62a *tests/testthat/test-lubridate.R
-f1bd1c27b9e372c1cb13d9abac4ea102 *tests/testthat/test-output.R
+f3d822c260d27441657068d6523a25cc *tests/testthat/test-output.R
+3a9c090f1e3f948fb1d699341d036a0f *tests/testthat/test-parse.R
+f03c4370a8ed3eb16b66f8ff45140475 *tests/testthat/test-round.R
765c3591c7471688d7b53a8fa47bdddc *tests/testthat/test-subset.R
36082171f366b616c4004a919542871c *tests/testthat/test-update.R
diff --git a/NAMESPACE b/NAMESPACE
index 8a18c6c..a554c2d 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -6,14 +6,22 @@ S3method(as.POSIXct,hms)
S3method(as.POSIXlt,hms)
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)
export(as.hms)
export(hms)
export(is.hms)
+export(parse_hm)
+export(parse_hms)
+export(round_hms)
+export(trunc_hms)
+import(rlang)
importFrom(methods,setOldClass)
+importFrom(pkgconfig,get_config)
diff --git a/NEWS.md b/NEWS.md
index eb899b3..64a2f97 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,3 +1,33 @@
+## hms 0.4.0 (2017-11-16)
+
+### Breaking changes
+
+- `as.hms.POSIXt()` now defaults to the current time zone, the previous default was `"UTC"` and can be restored by calling `pkgconfig::set_config("hms::default_tz", "UTC")`.
+
+### New features
+
+- Pillar support, will display `hms` columns in tibbles in color on terminals
+ that support it (#43).
+- New `round_hms()` and `trunc_hms()` for rounding or truncating to a given multiple of seconds (#31).
+- New `parse_hms()` and `parse_hm()` to parse strings in "HH:MM:SS" and "HH:MM" formats (#30).
+- `as.hms.POSIXt()` gains `tz` argument, default `"UTC"` (#28).
+- `as.hms.character()` and `parse_hms()` accept fractional seconds (#33).
+
+### Bug fixes
+
+- `hms()` now works correctly if all four components (days, hours, minutes, seconds) are passed (#49).
+- `hms()` creates a zero-length object of class `hms` that prints as `"hms()"`.
+- `hms(integer())` and `as.hms(integer())` both work and are identical to `hms()`.
+- Values with durations of over 10000 hours are now printed correctly (#48).
+- `c()` now returns a hms (#41, @qgeissmann).
+
+### Documentation and error messages
+
+- Fix and enhance examples in `?hms`.
+- Documentation is in Markdown format now.
+- Improved error message if calling `hms()` with a character argument (#29).
+
+
# hms 0.3 (2016-11-22)
- Fix `lubridate` test for compatibility with 1.6.0 (#23, @vspinu).
diff --git a/R/args.R b/R/args.R
new file mode 100644
index 0000000..0657b0c
--- /dev/null
+++ b/R/args.R
@@ -0,0 +1,25 @@
+check_args <- function(args) {
+ is_null <- map_lgl(args, is.null)
+ if (all(is_null)) return()
+
+ valid <- map_lgl(args[!is_null], is_numeric_or_na)
+ if (!all(valid)) {
+ stop("All arguments must be numeric or NA", call. = FALSE)
+ }
+
+ if (!all(diff(which(!is_null)) == 1L)) {
+ stop("Can't pass only ", paste(names(is_null)[!is_null], collapse = ", "),
+ " to hms().", call. = FALSE)
+ }
+
+ lengths <- map_int(args[!is_null], length)
+ if (length(unique(lengths)) > 1L) {
+ stop("All arguments to hms() must have the same length or be NULL. Found ",
+ paste0("length(", names(lengths), ") = ", lengths, collapse = ", "), ".",
+ call. = FALSE)
+ }
+}
+
+is_numeric_or_na <- function(x) {
+ is.numeric(x) || all(is.na(x))
+}
diff --git a/R/arith.R b/R/arith.R
index 93f3cd7..988a25c 100644
--- a/R/arith.R
+++ b/R/arith.R
@@ -40,3 +40,13 @@ split_seconds <- function(x) {
split_second_of_second <- function(x) {
abs(split_seconds(x) - seconds(x))
}
+
+decompose <- function(x) {
+ list(
+ sign = x < 0 & !is.na(x),
+ hours = abs(hours(x)),
+ minute_of_hour = minute_of_hour(x),
+ second_of_minute = second_of_minute(x),
+ split_seconds = split_second_of_second(x)
+ )
+}
diff --git a/R/compat-purrr.R b/R/compat-purrr.R
new file mode 100644
index 0000000..7ec8f41
--- /dev/null
+++ b/R/compat-purrr.R
@@ -0,0 +1,162 @@
+# nocov start - compat-purrr (last updated: rlang 0.1.9000)
+
+# This file serves as a reference for compatibility functions for
+# purrr. They are not drop-in replacements but allow a similar style
+# of programming. This is useful in cases where purrr is too heavy a
+# package to depend on. Please find the most recent version in rlang's
+# repository.
+
+map <- function(.x, .f, ...) {
+ lapply(.x, .f, ...)
+}
+map_mold <- function(.x, .f, .mold, ...) {
+ out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE)
+ names(out) <- names(.x)
+ out
+}
+map_lgl <- function(.x, .f, ...) {
+ map_mold(.x, .f, logical(1), ...)
+}
+map_int <- function(.x, .f, ...) {
+ map_mold(.x, .f, integer(1), ...)
+}
+map_dbl <- function(.x, .f, ...) {
+ map_mold(.x, .f, double(1), ...)
+}
+map_chr <- function(.x, .f, ...) {
+ map_mold(.x, .f, character(1), ...)
+}
+map_cpl <- function(.x, .f, ...) {
+ map_mold(.x, .f, complex(1), ...)
+}
+
+pluck <- function(.x, .f) {
+ map(.x, `[[`, .f)
+}
+pluck_lgl <- function(.x, .f) {
+ map_lgl(.x, `[[`, .f)
+}
+pluck_int <- function(.x, .f) {
+ map_int(.x, `[[`, .f)
+}
+pluck_dbl <- function(.x, .f) {
+ map_dbl(.x, `[[`, .f)
+}
+pluck_chr <- function(.x, .f) {
+ map_chr(.x, `[[`, .f)
+}
+pluck_cpl <- function(.x, .f) {
+ map_cpl(.x, `[[`, .f)
+}
+
+map2 <- function(.x, .y, .f, ...) {
+ Map(.f, .x, .y, ...)
+}
+map2_lgl <- function(.x, .y, .f, ...) {
+ as.vector(map2(.x, .y, .f, ...), "logical")
+}
+map2_int <- function(.x, .y, .f, ...) {
+ as.vector(map2(.x, .y, .f, ...), "integer")
+}
+map2_dbl <- function(.x, .y, .f, ...) {
+ as.vector(map2(.x, .y, .f, ...), "double")
+}
+map2_chr <- function(.x, .y, .f, ...) {
+ as.vector(map2(.x, .y, .f, ...), "character")
+}
+map2_cpl <- function(.x, .y, .f, ...) {
+ as.vector(map2(.x, .y, .f, ...), "complex")
+}
+
+args_recycle <- function(args) {
+ lengths <- map_int(args, length)
+ n <- max(lengths)
+
+ stopifnot(all(lengths == 1L | lengths == n))
+ to_recycle <- lengths == 1L
+ args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n))
+
+ args
+}
+pmap <- function(.l, .f, ...) {
+ args <- args_recycle(.l)
+ do.call("mapply", c(
+ FUN = list(quote(.f)),
+ args, MoreArgs = quote(list(...)),
+ SIMPLIFY = FALSE, USE.NAMES = FALSE
+ ))
+}
+
+probe <- function(.x, .p, ...) {
+ if (is_logical(.p)) {
+ stopifnot(length(.p) == length(.x))
+ .p
+ } else {
+ map_lgl(.x, .p, ...)
+ }
+}
+
+keep <- function(.x, .f, ...) {
+ .x[probe(.x, .f, ...)]
+}
+discard <- function(.x, .p, ...) {
+ sel <- probe(.x, .p, ...)
+ .x[is.na(sel) | !sel]
+}
+map_if <- function(.x, .p, .f, ...) {
+ matches <- probe(.x, .p)
+ .x[matches] <- map(.x[matches], .f, ...)
+ .x
+}
+
+compact <- function(.x) {
+ Filter(length, .x)
+}
+
+transpose <- function(.l) {
+ inner_names <- names(.l[[1]])
+ if (is.null(inner_names)) {
+ fields <- seq_along(.l[[1]])
+ } else {
+ fields <- set_names(inner_names)
+ }
+
+ map(fields, function(i) {
+ map(.l, .subset2, i)
+ })
+}
+
+every <- function(.x, .p, ...) {
+ for (i in seq_along(.x)) {
+ if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE)
+ }
+ TRUE
+}
+some <- function(.x, .p, ...) {
+ for (i in seq_along(.x)) {
+ if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE)
+ }
+ FALSE
+}
+negate <- function(.p) {
+ function(...) !.p(...)
+}
+
+reduce <- function(.x, .f, ..., .init) {
+ f <- function(x, y) .f(x, y, ...)
+ Reduce(f, .x, init = .init)
+}
+reduce_right <- function(.x, .f, ..., .init) {
+ f <- function(x, y) .f(y, x, ...)
+ Reduce(f, .x, init = .init, right = TRUE)
+}
+accumulate <- function(.x, .f, ..., .init) {
+ f <- function(x, y) .f(x, y, ...)
+ Reduce(f, .x, init = .init, accumulate = TRUE)
+}
+accumulate_right <- function(.x, .f, ..., .init) {
+ f <- function(x, y) .f(y, x, ...)
+ Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE)
+}
+
+# nocov end
diff --git a/R/format.R b/R/format.R
index 028ca6b..2eddbef 100644
--- a/R/format.R
+++ b/R/format.R
@@ -1,11 +1,14 @@
+format_hours <- function(x) {
+ format(format_two_digits(x), justify = "right")
+}
+
format_two_digits <- function(x) {
- formatC(x, width = 2, flag = "0")
+ formatC(x, format = "f", digits = 0, width = 2, flag = "0")
}
format_split_seconds <- function(x) {
- split_second <- split_second_of_second(x)
- out <- format(split_second, scientific = FALSE)
+ out <- format(x, scientific = FALSE)
digits <- max(min(max(nchar(out) - 2), 6), 0)
- out <- formatC(split_second, format = "f", digits = digits)
+ out <- formatC(x, format = "f", digits = digits)
gsub("^0", "", out)
}
diff --git a/R/hms.R b/R/hms.R
index 1565025..fd49200 100644
--- a/R/hms.R
+++ b/R/hms.R
@@ -1,9 +1,10 @@
+#' @import rlang
#' @importFrom methods setOldClass
setOldClass(c("hms", "difftime"))
#' A simple class for storing time-of-day values
#'
-#' The values are stored as a \code{\link{difftime}} vector with a custom class,
+#' The values are stored as a [difftime] vector with a custom class,
#' and always with "seconds" as unit for robust coercion to numeric.
#' Supports construction from time values, coercion to and from
#' various data types, and formatting. Can be used as a regular column in a
@@ -12,14 +13,12 @@ setOldClass(c("hms", "difftime"))
#' @name hms
#' @examples
#' hms(56, 34, 12)
+#' hms()
#' as.hms(1)
#' as.hms("12:34:56")
#' as.hms(Sys.time())
#' as.POSIXct(hms(1))
-#' \dontrun{
-#' # Will raise an error
-#' data.frame(a = hms(1))
-#' }
+#' data.frame(a = hms(1))
#' d <- data.frame(hours = 1:3)
#' d$hours <- hms(hours = d$hours)
#' d
@@ -28,41 +27,22 @@ NULL
# Construction ------------------------------------------------------------
#' @rdname hms
-#' @details For \code{hms}, all arguments must have the same length or be
-#' \code{NULL}. Odd combinations (e.g., passing only \code{seconds} and
-#' \code{hours} but not \code{minutes}) are rejected.
+#' @details For `hms`, all arguments must have the same length or be
+#' `NULL`. Odd combinations (e.g., passing only `seconds` and
+#' `hours` but not `minutes`) are rejected.
#' @param seconds,minutes,hours,days Time since midnight. No bounds checking is
#' performed.
#' @export
hms <- function(seconds = NULL, minutes = NULL, hours = NULL, days = NULL) {
args <- list(seconds = seconds, minutes = minutes, hours = hours, days = days)
check_args(args)
- arg_secs <- mapply(`*`, args, c(1, 60, 3600, 86400))
- secs <- Reduce(`+`, arg_secs[vapply(arg_secs, length, integer(1L)) > 0L])
+ arg_secs <- map2(args, c(1, 60, 3600, 86400), `*`)
+ secs <- reduce(arg_secs[!map_lgl(args, is.null)], `+`)
+ if (is.null(secs)) secs <- numeric()
as.hms(as.difftime(secs, units = "secs"))
}
-check_args <- function(args) {
- lengths <- vapply(args, length, integer(1L))
- if (all(lengths == 0L)) {
- stop("Need to pass at least one entry for seconds, minutes, hours, or days to hms().",
- call. = FALSE)
- }
-
- if (!all(diff(which(lengths != 0L)) == 1L)) {
- stop("Can't pass only ", paste(names(lengths)[lengths != 0L], collapse = ", "),
- " to hms().", call. = FALSE)
- }
-
- lengths <- lengths[lengths != 0]
- if (length(unique(lengths)) > 1L) {
- stop("All arguments to hms() must have the same length or be NULL. Found ",
- paste0("length(", names(lengths), ") = ", lengths, collapse = ", "), ".",
- call. = FALSE)
- }
-}
-
#' @rdname hms
#' @export
is.hms <- function(x) inherits(x, "hms")
@@ -96,14 +76,27 @@ as.hms.numeric <- function(x, ...) hms(seconds = x)
#' @rdname hms
#' @export
as.hms.character <- function(x, ...) {
- as.hms(as.difftime(x))
+ parse_hms(x)
+}
+
+#' @rdname hms
+#' @param tz The time zone in which to interpret a POSIXt time for extracting
+#' the time of day. The default is now the zone of `x` but was `"UTC"`
+#' for v0.3 and earlier. The previous behavior can be restored by calling
+#' `pkgconfig::set_config("hms::default_tz", "UTC")`, see
+#' [pkgconfig::set_config()].
+#' @export
+#' @importFrom pkgconfig get_config
+as.hms.POSIXt <- function(x, tz = pkgconfig::get_config("hms::default_tz", ""), ...) {
+ time <- as.POSIXlt(x, tz = tz)
+ hms(time$sec, time$min, time$hour)
}
#' @rdname hms
#' @export
-as.hms.POSIXt <- function(x, ...) {
- seconds <- as.numeric(as.POSIXct(x)) %% 86400
- hms(seconds = seconds)
+as.hms.POSIXlt <- function(x, tz = pkgconfig::get_config("hms::default_tz", ""), ...) {
+ # We need to roundtrip via as.POSIXct() to respect the time zone
+ as.hms(as.POSIXct(x), tz = tz, ...)
}
@@ -124,12 +117,14 @@ as.POSIXlt.hms <- function(x, ...) {
#' @rdname hms
#' @export
as.character.hms <- function(x, ...) {
+ xx <- decompose(x)
+
ifelse(is.na(x), "NA", paste0(
- ifelse(x < 0, "-", ""),
- format_two_digits(abs(hours(x))), ":",
- format_two_digits(minute_of_hour(x)), ":",
- format_two_digits(second_of_minute(x)),
- format_split_seconds(x)))
+ ifelse(xx$sign, "-", ""),
+ format_hours(xx$hours), ":",
+ format_two_digits(xx$minute_of_hour), ":",
+ format_two_digits(xx$second_of_minute),
+ format_split_seconds(xx$split_seconds)))
}
#' @rdname hms
@@ -146,6 +141,11 @@ as.data.frame.hms <- forward_to(as.data.frame.difftime)
hms(NextMethod())
}
+# Combination -------------------------------------------------------------
+#' @export
+c.hms <- function(x, ...) {
+ as.hms(NextMethod())
+}
# Updating ----------------------------------------------------------------
@@ -163,7 +163,11 @@ as.data.frame.hms <- forward_to(as.data.frame.difftime)
#' @rdname hms
#' @export
format.hms <- function(x, ...) {
- format(as.character(x), justify = "right")
+ if (length(x) == 0L) {
+ "hms()"
+ } else {
+ format(as.character(x), justify = "right")
+ }
}
#' @rdname hms
diff --git a/R/parse.R b/R/parse.R
new file mode 100644
index 0000000..4dcf465
--- /dev/null
+++ b/R/parse.R
@@ -0,0 +1,24 @@
+#' Parsing hms values
+#'
+#' These functions convert character vectors to objects of the [hms] class.
+#' `NA` values are supported.
+#'
+#' `parse_hms()` accepts values of the form `"HH:MM:SS"`, with optional
+#' fractional seconds.
+#' @param x A character vector
+#' @export
+#' @examples
+#' parse_hms("12:34:56")
+#' parse_hms("12:34:56.789")
+parse_hms <- function(x) {
+ as.hms(as.difftime(as.character(x), format = "%H:%M:%OS", units = "secs"))
+}
+
+#' @rdname parse_hms
+#' @details `parse_hm()` accepts values of the form `"HH:MM"`.
+#' @export
+#' @examples
+#' parse_hm("12:34")
+parse_hm <- function(x) {
+ as.hms(as.difftime(as.character(x), format = "%H:%M", units = "secs"))
+}
diff --git a/R/pillar.R b/R/pillar.R
new file mode 100644
index 0000000..e8cfd58
--- /dev/null
+++ b/R/pillar.R
@@ -0,0 +1,52 @@
+# Dynamically exported, see zzz.R
+pillar_shaft.hms <- function(x, ...) {
+ data <- rep(NA_character_, length(x))
+
+ xx <- decompose(x)
+ highlight_hours <- xx$hours > 0
+ highlighted <- highlight_hours
+ highlight_minutes <- !highlighted & xx$minute_of_hour > 0
+ highlighted <- highlighted | highlight_minutes
+ highlight_seconds <- !highlighted & xx$second_of_minute > 0
+ highlighted <- highlighted | highlight_seconds
+ highlight_split_seconds <- !highlighted & xx$split_seconds > 0
+
+ need_split_seconds <- any(highlight_split_seconds, na.rm = TRUE)
+ need_seconds <- need_split_seconds || any(highlight_seconds, na.rm = TRUE)
+ need_hours <- any(highlight_hours, na.rm = TRUE)
+ need_sign <- any(xx$sign)
+
+ if (need_hours) {
+ data_seconds <- paste0(
+ if (need_sign) ifelse(xx$sign, "-", " ") else "",
+ pillar::style_num(format_hours(xx$hours), xx$sign, highlight_hours),
+ pillar::style_subtle(":"),
+ pillar::style_num(format_two_digits(xx$minute_of_hour), xx$sign, highlight_minutes),
+ if (need_seconds) paste0(
+ pillar::style_subtle(":"),
+ pillar::style_num(format_two_digits(xx$second_of_minute), xx$sign, highlight_seconds)
+ )
+ )
+ data <- paste0(
+ data_seconds,
+ pillar::style_num(format_split_seconds(xx$split_seconds), xx$sign, highlight_split_seconds)
+ )
+ } else {
+ data_seconds <- paste0(
+ if (need_sign) ifelse(xx$sign, "-", " ") else "",
+ pillar::style_num(format_two_digits(xx$minute_of_hour), xx$sign, highlight_minutes),
+ pillar::style_subtle("'"),
+ pillar::style_num(format_two_digits(xx$second_of_minute), xx$sign, highlight_seconds)
+ )
+ data <- paste0(
+ data_seconds,
+ pillar::style_num(format_split_seconds(xx$split_seconds), xx$sign, highlight_split_seconds),
+ pillar::style_subtle('"')
+ )
+ }
+
+ na_indent <- crayon::col_nchar(data_seconds[1], type = "width") - 2L
+ data[is.na(x)] <- NA
+
+ pillar::new_pillar_shaft_simple(data, na_indent = na_indent)
+}
diff --git a/R/round.R b/R/round.R
new file mode 100644
index 0000000..730ab43
--- /dev/null
+++ b/R/round.R
@@ -0,0 +1,22 @@
+#' Round or truncate to a multiple of seconds
+#'
+#' Convenience functions to round or truncate to a multiple of seconds.
+#' @param x A vector of class [hms]
+#' @param secs Multiple of seconds, a positive numeric. Values less than one
+#' are supported
+#' @return The input, rounded or truncated to the nearest multiple of `secs`
+#' @export
+#' @examples
+#' round_hms(as.hms("12:34:56"), 5)
+#' round_hms(as.hms("12:34:56"), 60)
+round_hms <- function(x, secs) {
+ as.hms(round(as.numeric(x) / secs) * secs)
+}
+
+#' @rdname round_hms
+#' @export
+#' @examples
+#' trunc_hms(as.hms("12:34:56"), 60)
+trunc_hms <- function(x, secs) {
+ as.hms(trunc(as.numeric(x) / secs) * secs)
+}
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000..c23f0a0
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,31 @@
+# nocov start
+.onLoad <- function(...) {
+ register_s3_method("pillar", "pillar_shaft", "hms")
+
+ invisible()
+}
+
+register_s3_method <- function(pkg, generic, class, fun = NULL) {
+ stopifnot(is.character(pkg), length(pkg) == 1)
+ stopifnot(is.character(generic), length(generic) == 1)
+ stopifnot(is.character(class), length(class) == 1)
+
+ if (is.null(fun)) {
+ fun <- get(paste0(generic, ".", class), envir = parent.frame())
+ } else {
+ stopifnot(is.function(fun))
+ }
+
+ if (pkg %in% loadedNamespaces()) {
+ registerS3method(generic, class, fun, envir = asNamespace(pkg))
+ }
+
+ # Always register hook in case package is later unloaded & reloaded
+ setHook(
+ packageEvent(pkg, "onLoad"),
+ function(...) {
+ registerS3method(generic, class, fun, envir = asNamespace(pkg))
+ }
+ )
+}
+# nocov end
diff --git a/README.md b/README.md
index 22b8e1f..211fb1a 100644
--- a/README.md
+++ b/README.md
@@ -1,6 +1,8 @@
-hms [](https://travis-ci.org/rstats-db/hms) [](https://ci.appveyor.com/project/rstats-db/hms) [](https://codecov.io/github/rstats-db/hms?branch=master) [](https://travis-ci.org/tidyverse/hms) [](https://ci.appveyor.com/project/tidyverse/hms) [](https://codecov.io/gh/tidyverse/hms) [](https://cran.r-project.org [...]
A simple class for storing durations or time-of-day values and displaying them in the hh:mm:ss format. Intended to simplify data exchange with databases, spreadsheets, and other data sources.
@@ -32,5 +34,5 @@ Install the package from GitHub:
``` r
# install.packages("devtools")
-devtools::install_github("rstats-db/hms")
+devtools::install_github("tidyverse/hms")
```
diff --git a/man/hms.Rd b/man/hms.Rd
index cdccbef..c047178 100644
--- a/man/hms.Rd
+++ b/man/hms.Rd
@@ -10,6 +10,7 @@
\alias{as.hms.numeric}
\alias{as.hms.character}
\alias{as.hms.POSIXt}
+\alias{as.hms.POSIXlt}
\alias{as.POSIXct.hms}
\alias{as.POSIXlt.hms}
\alias{as.character.hms}
@@ -32,7 +33,11 @@ as.hms(x, ...)
\method{as.hms}{character}(x, ...)
-\method{as.hms}{POSIXt}(x, ...)
+\method{as.hms}{POSIXt}(x, tz = pkgconfig::get_config("hms::default_tz", ""),
+ ...)
+
+\method{as.hms}{POSIXlt}(x, tz = pkgconfig::get_config("hms::default_tz", ""),
+ ...)
\method{as.POSIXct}{hms}(x, ...)
@@ -55,6 +60,12 @@ performed.}
\item{...}{Arguments passed on to further methods.}
+\item{tz}{The time zone in which to interpret a POSIXt time for extracting
+the time of day. The default is now the zone of \code{x} but was \code{"UTC"}
+for v0.3 and earlier. The previous behavior can be restored by calling
+\code{pkgconfig::set_config("hms::default_tz", "UTC")}, see
+\code{\link[pkgconfig:set_config]{pkgconfig::set_config()}}.}
+
\item{row.names}{\code{NULL} or a character vector giving the row
names for the data frame. Missing values are not allowed.}
@@ -68,7 +79,7 @@ performed.}
\item{nm}{Name of column in new data frame}
}
\description{
-The values are stored as a \code{\link{difftime}} vector with a custom class,
+The values are stored as a \link{difftime} vector with a custom class,
and always with "seconds" as unit for robust coercion to numeric.
Supports construction from time values, coercion to and from
various data types, and formatting. Can be used as a regular column in a
@@ -76,21 +87,18 @@ data frame.
}
\details{
For \code{hms}, all arguments must have the same length or be
- \code{NULL}. Odd combinations (e.g., passing only \code{seconds} and
- \code{hours} but not \code{minutes}) are rejected.
+\code{NULL}. Odd combinations (e.g., passing only \code{seconds} and
+\code{hours} but not \code{minutes}) are rejected.
}
\examples{
hms(56, 34, 12)
+hms()
as.hms(1)
as.hms("12:34:56")
as.hms(Sys.time())
as.POSIXct(hms(1))
-\dontrun{
- # Will raise an error
- data.frame(a = hms(1))
-}
+data.frame(a = hms(1))
d <- data.frame(hours = 1:3)
d$hours <- hms(hours = d$hours)
d
}
-
diff --git a/man/parse_hms.Rd b/man/parse_hms.Rd
new file mode 100644
index 0000000..6457589
--- /dev/null
+++ b/man/parse_hms.Rd
@@ -0,0 +1,29 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/parse.R
+\name{parse_hms}
+\alias{parse_hms}
+\alias{parse_hm}
+\title{Parsing hms values}
+\usage{
+parse_hms(x)
+
+parse_hm(x)
+}
+\arguments{
+\item{x}{A character vector}
+}
+\description{
+These functions convert character vectors to objects of the \link{hms} class.
+\code{NA} values are supported.
+}
+\details{
+\code{parse_hms()} accepts values of the form \code{"HH:MM:SS"}, with optional
+fractional seconds.
+
+\code{parse_hm()} accepts values of the form \code{"HH:MM"}.
+}
+\examples{
+parse_hms("12:34:56")
+parse_hms("12:34:56.789")
+parse_hm("12:34")
+}
diff --git a/man/round_hms.Rd b/man/round_hms.Rd
new file mode 100644
index 0000000..e0e779b
--- /dev/null
+++ b/man/round_hms.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/round.R
+\name{round_hms}
+\alias{round_hms}
+\alias{trunc_hms}
+\title{Round or truncate to a multiple of seconds}
+\usage{
+round_hms(x, secs)
+
+trunc_hms(x, secs)
+}
+\arguments{
+\item{x}{A vector of class \link{hms}}
+
+\item{secs}{Multiple of seconds, a positive numeric. Values less than one
+are supported}
+}
+\value{
+The input, rounded or truncated to the nearest multiple of \code{secs}
+}
+\description{
+Convenience functions to round or truncate to a multiple of seconds.
+}
+\examples{
+round_hms(as.hms("12:34:56"), 5)
+round_hms(as.hms("12:34:56"), 60)
+trunc_hms(as.hms("12:34:56"), 60)
+}
diff --git a/tests/testthat/helper-pillar.R b/tests/testthat/helper-pillar.R
new file mode 100644
index 0000000..b94b817
--- /dev/null
+++ b/tests/testthat/helper-pillar.R
@@ -0,0 +1,4 @@
+expect_known_pillar_shaft_display <- function(x, file, width) {
+ object_quo <- rlang::quo(pillar::pillar_shaft(x))
+ pillar::expect_known_display(!!object_quo, file = file.path("out", file))
+}
diff --git a/tests/testthat/out/hm.txt b/tests/testthat/out/hm.txt
new file mode 100644
index 0000000..43e6fc5
--- /dev/null
+++ b/tests/testthat/out/hm.txt
@@ -0,0 +1,6 @@
+-[31m01[39m[90m:[39m[90m00[39m
+-[90m00[39m[90m:[39m[31m01[39m
+ [90m00[39m[90m:[39m[90m00[39m
+ [90m00[39m[90m:[39m01
+ 01[90m:[39m[90m00[39m
+ [43m[30mNA[39m[49m
diff --git a/tests/testthat/out/hms.txt b/tests/testthat/out/hms.txt
new file mode 100644
index 0000000..f9dafb1
--- /dev/null
+++ b/tests/testthat/out/hms.txt
@@ -0,0 +1,10 @@
+-[31m1000[39m[90m:[39m[90m00[39m[90m:[39m[90m00[39m
+-[31m 01[39m[90m:[39m[90m00[39m[90m:[39m[90m00[39m
+-[90m 00[39m[90m:[39m[31m01[39m[90m:[39m[90m00[39m
+-[90m 00[39m[90m:[39m[90m00[39m[90m:[39m[31m01[39m
+ [90m 00[39m[90m:[39m[90m00[39m[90m:[39m[90m00[39m
+ [90m 00[39m[90m:[39m[90m00[39m[90m:[39m01
+ [90m 00[39m[90m:[39m01[90m:[39m[90m00[39m
+ 01[90m:[39m[90m00[39m[90m:[39m[90m00[39m
+ 1000[90m:[39m[90m00[39m[90m:[39m[90m00[39m
+ [43m[30mNA[39m[49m
diff --git a/tests/testthat/out/hmss.txt b/tests/testthat/out/hmss.txt
new file mode 100644
index 0000000..50f922e
--- /dev/null
+++ b/tests/testthat/out/hmss.txt
@@ -0,0 +1,10 @@
+-[31m01[39m[90m:[39m[90m00[39m[90m:[39m[90m00[39m[90m.000[39m
+-[90m00[39m[90m:[39m[31m01[39m[90m:[39m[90m00[39m[90m.000[39m
+-[90m00[39m[90m:[39m[90m00[39m[90m:[39m[31m01[39m[90m.000[39m
+-[90m00[39m[90m:[39m[90m00[39m[90m:[39m[90m00[39m[31m.001[39m
+ [90m00[39m[90m:[39m[90m00[39m[90m:[39m[90m00[39m[90m.000[39m
+ [90m00[39m[90m:[39m[90m00[39m[90m:[39m[90m00[39m.001
+ [90m00[39m[90m:[39m[90m00[39m[90m:[39m01[90m.000[39m
+ [90m00[39m[90m:[39m01[90m:[39m[90m00[39m[90m.000[39m
+ 01[90m:[39m[90m00[39m[90m:[39m[90m00[39m[90m.000[39m
+ [43m[30mNA[39m[49m
diff --git a/tests/testthat/out/ms.txt b/tests/testthat/out/ms.txt
new file mode 100644
index 0000000..7644631
--- /dev/null
+++ b/tests/testthat/out/ms.txt
@@ -0,0 +1,6 @@
+-[31m01[39m[90m'[39m[90m00[39m[90m"[39m
+-[90m00[39m[90m'[39m[31m01[39m[90m"[39m
+ [90m00[39m[90m'[39m[90m00[39m[90m"[39m
+ [90m00[39m[90m'[39m01[90m"[39m
+ 01[90m'[39m[90m00[39m[90m"[39m
+ [43m[30mNA[39m[49m
diff --git a/tests/testthat/out/mss.txt b/tests/testthat/out/mss.txt
new file mode 100644
index 0000000..bca6722
--- /dev/null
+++ b/tests/testthat/out/mss.txt
@@ -0,0 +1,8 @@
+-[31m01[39m[90m'[39m[90m00[39m[90m.000[39m[90m"[39m
+-[90m00[39m[90m'[39m[31m01[39m[90m.000[39m[90m"[39m
+-[90m00[39m[90m'[39m[90m00[39m[31m.001[39m[90m"[39m
+ [90m00[39m[90m'[39m[90m00[39m[90m.000[39m[90m"[39m
+ [90m00[39m[90m'[39m[90m00[39m.001[90m"[39m
+ [90m00[39m[90m'[39m01[90m.000[39m[90m"[39m
+ 01[90m'[39m[90m00[39m[90m.000[39m[90m"[39m
+ [43m[30mNA[39m[49m
diff --git a/tests/testthat/test-coercion.R b/tests/testthat/test-coercion.R
index 90292a1..223d995 100644
--- a/tests/testthat/test-coercion.R
+++ b/tests/testthat/test-coercion.R
@@ -4,13 +4,18 @@ test_that("coercion in", {
expect_identical(as.hms(0.5 * 86400), hms(hours = 12))
expect_identical(as.hms(-0.25 * 86400), hms(hours = -6))
expect_hms_equal(as.hms("12:34:56"), hms(56, 34, 12))
- expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "UTC")),
+ expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "UTC"), tz = "UTC"),
hms(56, 34, 12))
- expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "CEST")),
+ expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "CEST"), tz = "CEST"),
hms(56, 34, 12))
- expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "PST")),
+ expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "PST8PDT"), tz = "PST8PDT"),
hms(56, 34, 12))
+ now <- Sys.time()
+ now_lt <- as.POSIXlt(now)
+ expect_hms_equal(as.hms(now), hms(now_lt$sec, now_lt$min, now_lt$hour))
+ expect_hms_equal(as.hms(now_lt), as.hms(now))
+
expect_error(as.hms(FALSE))
})
diff --git a/tests/testthat/test-colformat.R b/tests/testthat/test-colformat.R
new file mode 100644
index 0000000..e938675
--- /dev/null
+++ b/tests/testthat/test-colformat.R
@@ -0,0 +1,24 @@
+context("pillar")
+
+test_that("pillar", {
+ expect_known_pillar_shaft_display(
+ hms(c(-3600, -60, -1, -0.001, 0, 0.001, 1, 60, 3600, NA)),
+ file = "hmss.txt"
+ )
+ expect_known_pillar_shaft_display(
+ hms(c(-3600000, -3600, -60, -1, 0, 1, 60, 3600, 3600000, NA)),
+ file = "hms.txt"
+ )
+ expect_known_pillar_shaft_display(
+ hms(c(-3600, -60, 0, 60, 3600, NA)),
+ file = "hm.txt"
+ )
+ expect_known_pillar_shaft_display(
+ hms(c(-60, -1, 0, 1, 60, NA)),
+ file = "ms.txt"
+ )
+ expect_known_pillar_shaft_display(
+ hms(c(-60, -1, -0.001, 0, 0.001, 1, 60, NA)),
+ file = "mss.txt"
+ )
+})
diff --git a/tests/testthat/test-combine.R b/tests/testthat/test-combine.R
new file mode 100644
index 0000000..436b157
--- /dev/null
+++ b/tests/testthat/test-combine.R
@@ -0,0 +1,18 @@
+context("combine")
+
+test_that("combination keeps class and order", {
+ expect_identical(c(hms(1), hms(2)), hms(1:2))
+})
+
+test_that("combination coerces to hms", {
+ expect_identical(c(hms(1), 2), hms(1:2))
+ if (getRversion() < "3.3") skip("Only for R >= 3.3")
+ expect_identical(c(hms(1), "00:00:02"), hms(1:2))
+})
+
+
+# In R base,`c(as.difftime("20:00:00"), NA)` fails
+test_that("composition with NA fails", {
+ if (getRversion() < "3.3") skip("Only for R >= 3.3")
+ expect_error(c(hms(1), NA))
+})
diff --git a/tests/testthat/test-construct.R b/tests/testthat/test-construct.R
index 2875898..1d54cb3 100644
--- a/tests/testthat/test-construct.R
+++ b/tests/testthat/test-construct.R
@@ -1,11 +1,12 @@
context("construct")
test_that("constructor", {
- expect_identical(hms(1:3, 2:4, 3:5),
- hms(seconds = 1:3 + 2:4 * 60 + 3:5 * 3600))
+ expect_identical(hms(1:3, 2:4, 3:5, 4:6),
+ hms(seconds = 1:3 + 2:4 * 60 + 3:5 * 3600 + 4:6 * 86400))
expect_identical(hms(-1, 1), hms(59))
expect_identical(hms(3600), hms(hours = 1))
+ expect_equal(length(hms(1)), 1L)
expect_true(is.hms(hms(1)))
expect_is(hms(1), "difftime")
expect_identical(as.numeric(hms(1)), 1)
@@ -15,10 +16,24 @@ test_that("constructor", {
expect_identical(as.hms(hms(1)), hms(1))
})
+test_that("zero length (#35)", {
+ expect_equal(length(hms()), 0L)
+ expect_true(is.hms(hms()))
+ expect_is(hms(), "difftime")
+ expect_identical(as.numeric(hms()), numeric())
+ expect_identical(as.difftime(hms()), hms())
+
+ expect_identical(hms(), hms(seconds = numeric()))
+ expect_identical(hms(), hms(minutes = numeric()))
+ expect_identical(hms(), hms(hours = numeric()))
+ expect_identical(hms(), hms(days = numeric()))
+ expect_identical(hms(), as.hms(numeric()))
+})
+
test_that("bad input", {
- expect_error(hms(), "seconds")
expect_error(hms(hours = 1, seconds = 3), "only")
expect_error(hms(minutes = 1, days = 3), "only")
expect_error(hms(minutes = 1, hours = 2:3), "same length or be NULL")
expect_error(hms(seconds = 1:5, minutes = 6:10, hours = 11:17), "same length or be NULL")
+ expect_error(hms("05:00"), "must be numeric")
})
diff --git a/tests/testthat/test-output.R b/tests/testthat/test-output.R
index 73d57bc..881aae5 100644
--- a/tests/testthat/test-output.R
+++ b/tests/testthat/test-output.R
@@ -17,7 +17,7 @@ test_that("beyond 24 hours (#12)", {
expect_identical(format(hms(hours = 99:101)),
c(" 99:00:00", "100:00:00", "101:00:00"))
expect_identical(format(hms(hours = c(-99, 100))),
- c("-99:00:00", "100:00:00"))
+ c("- 99:00:00", " 100:00:00"))
expect_identical(format(hms(hours = c(-100, 99))),
c("-100:00:00", " 99:00:00"))
})
diff --git a/tests/testthat/test-parse.R b/tests/testthat/test-parse.R
new file mode 100644
index 0000000..5a307cb
--- /dev/null
+++ b/tests/testthat/test-parse.R
@@ -0,0 +1,14 @@
+context("parse")
+
+test_that("parse_hms", {
+ expect_equal(parse_hms("12:34:56"), hms(56, 34, 12))
+ expect_equal(parse_hms("12:34:56.789"), hms(56.789, 34, 12))
+ expect_equal(parse_hms(NA), hms(NA))
+ expect_equal(parse_hms(c("12:34:56", NA)), as.hms(c(hms(56, 34, 12), hms(NA))))
+})
+
+test_that("parse_hm", {
+ expect_equal(parse_hm("12:34"), hms(0, 34, 12))
+ expect_equal(parse_hm(NA), hms(NA))
+ expect_equal(parse_hm(c("12:34", NA)), as.hms(c(hms(0, 34, 12), hms(NA))))
+})
diff --git a/tests/testthat/test-round.R b/tests/testthat/test-round.R
new file mode 100644
index 0000000..1f9ada4
--- /dev/null
+++ b/tests/testthat/test-round.R
@@ -0,0 +1,17 @@
+context("round")
+
+test_that("round_hms", {
+ expect_equal(round_hms(parse_hms("12:34:56"), 5), hms(55, 34, 12))
+ expect_equal(round_hms(parse_hms("12:34:56"), 60), hms(0, 35, 12))
+ expect_equal(round_hms(hms(0.7), 0.25), hms(0.75))
+ expect_equal(round_hms(hms(NA), 5), hms(NA))
+ expect_equal(round_hms(parse_hms(c("12:34:56", NA)), 5), as.hms(c(hms(55, 34, 12), hms(NA))))
+})
+
+test_that("trunc_hms", {
+ expect_equal(trunc_hms(parse_hms("12:34:56"), 5), hms(55, 34, 12))
+ expect_equal(trunc_hms(parse_hms("12:34:56"), 60), hms(0, 34, 12))
+ expect_equal(trunc_hms(hms(0.7), 0.25), hms(0.5))
+ expect_equal(trunc_hms(hms(NA), 5), hms(NA))
+ expect_equal(trunc_hms(parse_hms(c("12:34:56", NA)), 5), as.hms(c(hms(55, 34, 12), hms(NA))))
+})
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-hms.git
More information about the debian-med-commit
mailing list