Skip to content

Commit

Permalink
Transform clock_roll() to an internal S3 generic
Browse files Browse the repository at this point in the history
  • Loading branch information
danielvartan committed May 25, 2021
1 parent 367cef0 commit ae4f3a9
Show file tree
Hide file tree
Showing 5 changed files with 127 additions and 67 deletions.
4 changes: 4 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -1,5 +1,9 @@
# Generated by roxygen2: do not edit by hand

S3method(clock_roll,Duration)
S3method(clock_roll,Period)
S3method(clock_roll,difftime)
S3method(clock_roll,hms)
S3method(convert,Date)
S3method(convert,Duration)
S3method(convert,Interval)
Expand Down
59 changes: 59 additions & 0 deletions R/utils-clock_roll.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,59 @@
clock_roll <- function(x) {
UseMethod("clock_roll")
}

#' @export
clock_roll.Duration <- function(x) {
if (all(as.numeric(x) > 0 & as.numeric(x) < 86400, na.rm = TRUE)) {
x
} else {
x %>% lubridate::as_datetime() %>%
flat_posixt() %>%
hms::as_hms() %>%
lubridate::as.duration()
}
}

#' @export
clock_roll.Period <- function(x) {
if (all(as.numeric(x) > 0 & as.numeric(x) < 86400, na.rm = TRUE)) {
x
} else {
x %>% lubridate::as_datetime() %>%
flat_posixt() %>%
hms::as_hms() %>%
lubridate::as.period()
}
}

#' @export
clock_roll.difftime <- function(x) {
out <- x
units(out) <- "secs"

if (all(as.numeric(out) > 0 & as.numeric(out) < 86400, na.rm = TRUE)) {
units(out) <- units(x)
out
} else {
out <- out %>% hms::as_hms() %>%
lubridate::as_datetime() %>%
flat_posixt() %>%
hms::as_hms() %>%
as.numeric() %>%
lubridate::as.difftime(units = "secs")

units(out) <- units(x)
out
}
}

#' @export
clock_roll.hms <- function(x) {
if (all(as.numeric(x) > 0 & as.numeric(x) < 86400, na.rm = TRUE)) {
x
} else {
x %>% lubridate::as_datetime() %>%
flat_posixt() %>%
hms::as_hms()
}
}
44 changes: 8 additions & 36 deletions R/utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -6,50 +6,22 @@ flat_posixt <- function(x, force_utc = TRUE, base = "1970-01-01") {
lubridate::date(x) <- base

if (isTRUE(force_utc)) {
x <- lubridate::force_tz(x, "UTC")
lubridate::force_tz(x, "UTC")
} else {
x
}

x
}

midday_change <- function(x) {
checkmate::assert_multi_class(x, c("hms", "POSIXct", "POSIXlt"))

x <- flat_posixt(convert(x, "POSIXct"))
if (hms::is_hms(x)) x <- as.POSIXct(x)
x <- flat_posixt(x)

x <- dplyr::case_when(
dplyr::case_when(
lubridate::hour(x) < 12 ~ change_day(x, 2),
TRUE ~ x
)

x
}

clock_roll <- function(x) {
classes <- c("Duration", "Period", "difftime", "hms")
checkmate::assert_multi_class(x, classes)

class <- class(x)[1]
out <- x

if (class == "difftime") {
out <- hms::as_hms(x)
units <- units(x)
}

if (all(as.numeric(out) > 0 & as.numeric(out) < 86400, na.rm = TRUE)) {
x
} else {
out <- flat_posixt(lubridate::as_datetime(out))
out <- convert(out, class, quiet = TRUE)

if (class == "difftime") {
units(out) <- units
out
} else {
out
}
}
}

interval_mean <- function(start, end, class = "hms", ambiguity = 24,
Expand Down Expand Up @@ -80,10 +52,10 @@ interval_mean <- function(start, end, class = "hms", ambiguity = 24,

change_date <- function(x, date) {
classes <- c("Date", "POSIXct", "POSIXlt")
checkmate::assert_multi_class(x, classes, null.ok = FALSE)
checkmate::assert_multi_class(x, classes)

classes <- c("character", "Date")
checkmate::assert_multi_class(date, classes, null.ok = FALSE)
checkmate::assert_multi_class(date, classes)
assert_length_one(date)

lubridate::date(x) <- date
Expand Down
45 changes: 45 additions & 0 deletions tests/testthat/test-utils-clock_roll.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,45 @@
test_that("clock_roll() | general test", {
# Nonexistent method error
expect_error(clock_roll(list()))
})

test_that("clock_roll.Duration() | general test", {
expect_equal(clock_roll(lubridate::dhours(6)), lubridate::dhours(6))
expect_equal(clock_roll(lubridate::dhours(24)), lubridate::dhours(0))
expect_equal(clock_roll(lubridate::dhours(36)), lubridate::dhours(12))

expect_equal(clock_roll(c(lubridate::dhours(1), lubridate::dhours(48))),
c(lubridate::dhours(1), lubridate::dhours(0)))
})

test_that("clock_roll.Period() | general test", {
expect_equal(clock_roll(lubridate::hours(6)), lubridate::hours(6))
expect_equal(clock_roll(lubridate::hours(24)), lubridate::hours(0))
expect_equal(clock_roll(lubridate::hours(36)), lubridate::hours(12))

expect_equal(clock_roll(c(lubridate::hours(1), lubridate::hours(48))),
c(lubridate::hours(1), lubridate::hours(0)))
})

test_that("clock_roll.difftime() | general test", {
expect_equal(clock_roll(as.difftime(6, units = "mins")),
as.difftime(6, units = "mins"))
expect_equal(clock_roll(as.difftime(24, units = "hours")),
as.difftime(0, units = "hours"))
expect_equal(clock_roll(as.difftime(36, units = "hours")),
as.difftime(12, units = "hours"))

expect_equal(clock_roll(c(as.difftime(1, units = "hours"),
as.difftime(48, units = "hours"))),
c(as.difftime(1, units = "hours"),
as.difftime(0, units = "hours")))
})

test_that("clock_roll.hms() | general test", {
expect_equal(clock_roll(hms::parse_hm("06:00")), hms::parse_hm("06:00"))
expect_equal(clock_roll(hms::parse_hm("24:00")), hms::parse_hm("00:00"))
expect_equal(clock_roll(hms::hms(129600)), hms::parse_hm("12:00"))

expect_equal(clock_roll(c(hms::parse_hm("01:00"), hms::hms(172800))),
c(hms::parse_hm("01:00"), hms::parse_hm("00:00")))
})
42 changes: 11 additions & 31 deletions tests/testthat/test-utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -24,23 +24,17 @@ test_that("flat_posixct() | general test", {
})

test_that("midday_change() | general test", {
x <- lubridate::ymd_hms("2000-05-04 18:00:00")
object <- midday_change(x)
expect_equal(object, lubridate::ymd_hms("1970-01-01 18:00:00"))

x <- lubridate::ymd_hms("2000-05-04 06:00:00")
object <- midday_change(x)
expect_equal(object, lubridate::ymd_hms("1970-01-02 06:00:00"))

x <- c(lubridate::ymd_hms("2020-01-01 18:00:00"),
lubridate::ymd_hms("2020-01-01 06:00:00"))
object <- midday_change(x)
expected <- c(lubridate::ymd_hms("1970-01-01 18:00:00"),
lubridate::ymd_hms("1970-01-02 06:00:00"))
expect_equal(object, expected)

# Error test
expect_error(midday_change(1))
expect_equal(midday_change(hms::parse_hm("18:00")),
lubridate::ymd_hms("1970-01-01 18:00:00"))
expect_equal(midday_change(lubridate::ymd_hms("2000-05-04 06:00:00")),
lubridate::ymd_hms("1970-01-02 06:00:00"))
expect_equal(midday_change(c(lubridate::ymd_hms("2020-01-01 18:00:00"),
lubridate::ymd_hms("2020-01-01 06:00:00"))),
c(lubridate::ymd_hms("1970-01-01 18:00:00"),
lubridate::ymd_hms("1970-01-02 06:00:00")))

# Assert error test
expect_error(midday_change(1), "but has class 'numeric'")
})

test_that("change_date() | general test", {
Expand Down Expand Up @@ -299,20 +293,6 @@ test_that("get_names() | general test", {
expect_equal(object, noquote(c("x", "y", "z")))
})

test_that("clock_roll() | general test", {
expect_equal(clock_roll(lubridate::dhours(6)), lubridate::dhours(6))
expect_equal(clock_roll(lubridate::dhours(24)), lubridate::dhours(0))
expect_equal(clock_roll(lubridate::dhours(36)), lubridate::dhours(12))

x <- as.difftime(32, units = "hours")
expect_equal(clock_roll(x), as.difftime(8, units = "hours"))

x <- c(hms::parse_hm("02:00"), hms::hms(86401)) # 24:00:01
object <- clock_roll(x)
expected <- c(hms::parse_hm("02:00"), hms::parse_hms("00:00:01"))
expect_equal(object, expected)
})

test_that("get_class() | general test", {
test <- function(x) class(x)[1]

Expand Down

0 comments on commit ae4f3a9

Please sign in to comment.