warp/0000755000176200001440000000000014520757362011236 5ustar liggesuserswarp/NAMESPACE0000644000176200001440000000022413744061106012442 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(warp_boundary) export(warp_change) export(warp_distance) useDynLib(warp, .registration = TRUE) warp/LICENSE0000644000176200001440000000005214520521772012232 0ustar liggesusersYEAR: 2023 COPYRIGHT HOLDER: warp authors warp/README.md0000644000176200001440000000644714520722147012521 0ustar liggesusers # warp [![R-CMD-check](https://github.com/DavisVaughan/warp/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/DavisVaughan/warp/actions/workflows/R-CMD-check.yaml) [![Codecov test coverage](https://codecov.io/gh/DavisVaughan/warp/branch/main/graph/badge.svg)](https://app.codecov.io/gh/DavisVaughan/warp?branch=main) ![](https://media.giphy.com/media/jjeK2Er3E5igw/giphy.gif) The goal of warp is to provide tooling to group dates by a variety of periods, such as: yearly, monthly, by second, by week of the month, and more. ``` r library(warp) ``` ## Installation You can install the release version from CRAN with: ``` r install.package("warp") ``` You can install the development version from [GitHub](https://github.com/) with: ``` r # install.packages("pak") pak::pak("DavisVaughan/warp") ``` ## Example One of the core functions in warp is `warp_distance()`, which allows you to provide a date time vector and compute the “distance” from an `origin`. For example, this computes the number of months from the unix epoch. ``` r x <- as.Date("1970-01-01") + -2:2 x #> [1] "1969-12-30" "1969-12-31" "1970-01-01" "1970-01-02" "1970-01-03" warp_distance(x, period = "month") #> [1] -1 -1 0 0 0 ``` The values that `warp_distance()` returns correspond to the distance from `x` to the `origin`, in units defined by the `period` and the width defined by `every`. The `origin` defaults to the unix epoch of `1970-01-01 00:00:00` in the time zone of `x`, but you can change that. In this case the distances are saying that, for example, `"1970-01-02"` is in the same month as the origin, and `"1969-12-31"` is 1 month group away. You can also compute daily distances. Rather than grouping by 1 day, let’s lump every 2 days together, starting from the default `origin`. ``` r # Groups 1970-01-01 and 1970-01-02 together warp_distance(x, period = "day", every = 2) #> [1] -1 -1 0 0 1 ``` You will often want to set your own `origin` date. Let’s shift it forward 1 to `1970-01-02`. ``` r origin <- as.Date("1970-01-02") origin #> [1] "1970-01-02" # Groups 1970-01-02 and 1970-01-03 together warp_distance(x, period = "day", every = 2, origin = origin) #> [1] -2 -1 -1 0 0 ``` Another interesting period to group by is the `"mweek"`, i.e. the week of the month. Notice that days 1-7 of January 1970 are grouped into the same bucket. Also note that days 29-31 of December 1969 fell at the end of their corresponding month. This irregular week of size 3 is treated as the 5th week of that month, but the offset value of `-1` is still the number of week buckets from the `origin` of `1970-01-01`. ``` r y <- as.Date("1969-12-28") + 0:14 tibble::tibble( y = y, mweek = warp_distance(y, "mweek") ) #> # A tibble: 15 × 2 #> y mweek #> #> 1 1969-12-28 -2 #> 2 1969-12-29 -1 #> 3 1969-12-30 -1 #> 4 1969-12-31 -1 #> 5 1970-01-01 0 #> 6 1970-01-02 0 #> 7 1970-01-03 0 #> 8 1970-01-04 0 #> 9 1970-01-05 0 #> 10 1970-01-06 0 #> 11 1970-01-07 0 #> 12 1970-01-08 1 #> 13 1970-01-09 1 #> 14 1970-01-10 1 #> 15 1970-01-11 1 ``` ## Inspiration The algorithm for `warp_distance()` was inspired by `xts::endpoints()`. warp/man/0000755000176200001440000000000013743336661012012 5ustar liggesuserswarp/man/warp-package.Rd0000644000176200001440000000171014520521717014632 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/warp-package.R \docType{package} \name{warp-package} \alias{warp} \alias{warp-package} \title{warp: Group Dates} \description{ Tooling to group dates by a variety of periods including: yearly, monthly, by second, by week of the month, and more. The groups are defined in such a way that they also represent the distance between dates in terms of the period. This extracts valuable information that can be used in further calculations that rely on a specific temporal spacing between observations. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/DavisVaughan/warp} \item \url{https://davisvaughan.github.io/warp/} \item Report bugs at \url{https://github.com/DavisVaughan/warp/issues} } } \author{ \strong{Maintainer}: Davis Vaughan \email{davis@posit.co} Other contributors: \itemize{ \item Posit Software, PBC [copyright holder, funder] } } \keyword{internal} warp/man/warp_distance.Rd0000644000176200001440000002200014520263005015077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distance.R \name{warp_distance} \alias{warp_distance} \title{Compute distances from a date time origin} \usage{ warp_distance(x, period, ..., every = 1L, origin = NULL) } \arguments{ \item{x}{\verb{[Date / POSIXct / POSIXlt]} A date time vector.} \item{period}{\verb{[character(1)]} A string defining the period to group by. Valid inputs can be roughly broken into: \itemize{ \item \code{"year"}, \code{"quarter"}, \code{"month"}, \code{"week"}, \code{"day"} \item \code{"hour"}, \code{"minute"}, \code{"second"}, \code{"millisecond"} \item \code{"yweek"}, \code{"mweek"} \item \code{"yday"}, \code{"mday"} }} \item{...}{\verb{[dots]} These dots are for future extensions and must be empty.} \item{every}{\verb{[positive integer(1)]} The number of periods to group together. For example, if the period was set to \code{"year"} with an every value of \code{2}, then the years 1970 and 1971 would be placed in the same group.} \item{origin}{\verb{[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]} The reference date time value. The default when left as \code{NULL} is the epoch time of \verb{1970-01-01 00:00:00}, \emph{in the time zone of the index}. This is generally used to define the anchor time to count from, which is relevant when the every value is \verb{> 1}.} } \value{ A double vector containing the distances. } \description{ \code{warp_distance()} is a low level engine for computing date time distances. It returns the distance from \code{x} to the \code{origin} in units defined by the \code{period}. For example, \code{period = "year"} would return the number of years from the \code{origin}. Setting \code{every = 2} would return the number of 2 year groups from the \code{origin}. } \details{ The return value of \code{warp_distance()} has a variety of uses. It can be used for: \itemize{ \item A grouping column in a \code{dplyr::group_by()}. This is especially useful for grouping by a multitude of a particular period, such as "every 5 months". \item Computing distances between values in \code{x}, in units of the \code{period}. By returning the distances from the \code{origin}, \code{warp_distance()} has also implicitly computed the distances between values of \code{x}. This is used by \code{slide::block()} to break the input into time blocks. } When the time zone of \code{x} differs from the time zone of \code{origin}, a warning is issued, and \code{x} is coerced to the time zone of \code{origin} without changing the number of seconds of \code{x} from the epoch. In other words, the time zone of \code{x} is directly changed to the time zone of \code{origin} without changing the underlying numeric representation. \strong{It is highly advised to specify an \code{origin} value with the same time zone as \code{x}.} If a \code{Date} is used for \code{x}, its time zone is assumed to be \code{"UTC"}. } \section{Period}{ For \code{period} values of \code{"year"}, \code{"month"}, and \code{"day"}, the information provided in \code{origin} is truncated. Practically this means that if you specify: \if{html}{\out{
}}\preformatted{warp_distance(period = "month", origin = as.Date("1970-01-15")) }\if{html}{\out{
}} then only \code{1970-01} will be used, and not the fact that the origin starts on the 15th of the month. The \code{period} value of \code{"quarter"} is internally \verb{period = "month", every = every * 3}. This means that for \code{"quarter"} the month specified for the \code{origin} will be used as the month to start counting from to generate the 3 month quarter. To mimic the behavior of \code{lubridate::floor_date()}, use \code{period = "week"}. Internally this is just \verb{period = "day", every = every * 7}. To mimic the \code{week_start} argument of \code{floor_date()}, set \code{origin} to a date with a week day identical to the one you want the week to start from. For example, the default origin of \code{1970-01-01} is a Thursday, so this would be generate groups identical to \code{floor_date(week_start = 4)}. The \code{period} value of \code{"yday"} is computed as complete \code{every}-day periods from the \code{origin}, with a forced reset of the \code{every}-day counter every time you hit the month-day value of the \code{origin}. \code{"yweek"} is built on top of this internally as \verb{period = "yday", every = every * 7}. This ends up using an algorithm very similar to \code{lubridate::week()}, with the added benefit of being able to control the \code{origin} date. The \code{period} value of \code{"mday"} is computed as \code{every}-day periods within each month, with a forced reset of the \code{every}-day counter on the first day of each month. The most useful application of this is \code{"mweek"}, which is implemented as \verb{period = "mday", every = every * 7}. This allows you to group by the "week of the month". For \code{"mday"} and \code{"mweek"}, only the year and month parts of the \code{origin} value are used. Because of this, the \code{origin} argument is not that interesting for these periods. The \code{"hour"} period (and more granular frequencies) can produce results that might be surprising, even if they are technically correct. See the vignette at \code{vignette("hour", package = "warp")} for more information. } \section{Precision}{ With \code{POSIXct}, the limit of precision is approximately the microsecond level. Only dates that are very close to the unix origin of 1970-01-01 can possibly represent microsecond resolution correctly (close being within about 40 years on either side). Otherwise, the values past the microsecond resolution are essentially random, and can cause problems for the distance calculations. Because of this, decimal digits past the microsecond range are zeroed out, so please do not attempt to rely on them. It should still be safe to work with microseconds, by, say, bucketing them by millisecond distances. } \examples{ x <- as.Date("1970-01-01") + -4:4 x # Compute monthly distances (really, year + month) warp_distance(x, "month") # Compute distances every 2 days, relative to "1970-01-01" warp_distance(x, "day", every = 2) # Compute distances every 2 days, this time relative to "1970-01-02" warp_distance(x, "day", every = 2, origin = as.Date("1970-01-02")) y <- as.POSIXct("1970-01-01 00:00:01", "UTC") + c(0, 2, 3, 4, 5, 6, 10) # Compute distances every 5 seconds, starting from the unix epoch of # 1970-01-01 00:00:00 # So this buckets: # [1970-01-01 00:00:00, 1970-01-01 00:00:05) = 0 # [1970-01-01 00:00:05, 1970-01-01 00:00:10) = 1 # [1970-01-01 00:00:10, 1970-01-01 00:00:15) = 2 warp_distance(y, "second", every = 5) # Compute distances every 5 seconds, starting from the minimum of `x` # 1970-01-01 00:00:01 # So this buckets: # [1970-01-01 00:00:01, 1970-01-01 00:00:06) = 0 # [1970-01-01 00:00:06, 1970-01-01 00:00:11) = 1 # [1970-01-01 00:00:11, 1970-01-01 00:00:16) = 2 origin <- as.POSIXct("1970-01-01 00:00:01", "UTC") warp_distance(y, "second", every = 5, origin = origin) # --------------------------------------------------------------------------- # Time zones # When `x` is not UTC and `origin` is left as `NULL`, the origin is set as # 1970-01-01 00:00:00 in the time zone of `x`. This seems to be the most # practically useful default. z <- as.POSIXct("1969-12-31 23:00:00", "UTC") z_in_nyc <- as.POSIXct("1969-12-31 23:00:00", "America/New_York") # Practically this means that these give the same result, because their # `origin` values are defined in their respective time zones. warp_distance(z, "year") warp_distance(z_in_nyc, "year") # Compare that to what would happen if we used a static `origin` of # 1970-01-01 00:00:00 UTC. # America/New_York is 5 hours behind UTC, so when `z_in_nyc` is converted to # UTC the value becomes `1970-01-01 04:00:00 UTC`, a different year. Because # this is generally surprising, a warning is thrown. origin <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") warp_distance(z, "year", origin = origin) warp_distance(z_in_nyc, "year", origin = origin) # --------------------------------------------------------------------------- # `period = "yweek"` x <- as.Date("2019-12-23") + 0:16 origin <- as.Date("1970-01-01") # `"week"` counts the number of 7 day periods from the `origin` # `"yweek"` restarts the 7 day counter every time you hit the month-day # value of the `origin`. Notice how, for the `yweek` column, only 1 day was # in the week starting with `2019-12-31`. This is because the next day is # `2020-01-01`, which aligns with the month-day value of the `origin`. data.frame( x = x, week = warp_distance(x, "week", origin = origin), yweek = warp_distance(x, "yweek", origin = origin) ) # --------------------------------------------------------------------------- # `period = "mweek"` x <- as.Date("2019-12-23") + 0:16 # `"mweek"` breaks `x` up into weeks of the month. Notice how days 1-7 # of 2020-01 all have the same distance value. A forced reset of the 7 day # counter is done at the 1st of every month. This results in the 3 day # week of the month at the end of 2019-12, from 29-31. data.frame( x = x, mweek = warp_distance(x, "mweek") ) } warp/man/warp_change.Rd0000644000176200001440000000573413743336661014570 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/change.R \name{warp_change} \alias{warp_change} \title{Detect changes in a date time vector} \usage{ warp_change( x, period, ..., every = 1L, origin = NULL, last = TRUE, endpoint = FALSE ) } \arguments{ \item{x}{\verb{[Date / POSIXct / POSIXlt]} A date time vector.} \item{period}{\verb{[character(1)]} A string defining the period to group by. Valid inputs can be roughly broken into: \itemize{ \item \code{"year"}, \code{"quarter"}, \code{"month"}, \code{"week"}, \code{"day"} \item \code{"hour"}, \code{"minute"}, \code{"second"}, \code{"millisecond"} \item \code{"yweek"}, \code{"mweek"} \item \code{"yday"}, \code{"mday"} }} \item{...}{\verb{[dots]} These dots are for future extensions and must be empty.} \item{every}{\verb{[positive integer(1)]} The number of periods to group together. For example, if the period was set to \code{"year"} with an every value of \code{2}, then the years 1970 and 1971 would be placed in the same group.} \item{origin}{\verb{[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]} The reference date time value. The default when left as \code{NULL} is the epoch time of \verb{1970-01-01 00:00:00}, \emph{in the time zone of the index}. This is generally used to define the anchor time to count from, which is relevant when the every value is \verb{> 1}.} \item{last}{\verb{[logical(1)]} If \code{TRUE}, the \emph{last} location \emph{before} a change is returned. The last location of the input is always returned. If \code{FALSE}, the \emph{first} location \emph{after} a change is returned. The first location of the input is always returned.} \item{endpoint}{\verb{[logical(1)]} If \code{TRUE} and \code{last = TRUE}, will additionally return the first location of the input. If \code{TRUE} and \code{last = FALSE}, will additionally return the last location of the input. If \code{FALSE}, does nothing.} } \value{ A double vector of locations. } \description{ \code{warp_change()} detects changes at the \code{period} level. If \code{last = TRUE}, it returns locations of the last value before a change, and the last location in \code{x} is always included. Additionally, if \code{endpoint = TRUE}, the first location in \code{x} will be included. If \code{last = FALSE}, it returns locations of the first value after a change, and the first location in \code{x} is always included. Additionally, if \code{endpoint = TRUE}, the last location in \code{x} will be included. } \examples{ x <- as.Date("2019-01-01") + 0:5 x # Last location before a change, last location of `x` is always included warp_change(x, period = "yday", every = 2, last = TRUE) # Also include first location warp_change(x, period = "yday", every = 2, last = TRUE, endpoint = TRUE) # First location after a change, first location of `x` is always included warp_change(x, period = "yday", every = 2, last = FALSE) # Also include last location warp_change(x, period = "yday", every = 2, last = FALSE, endpoint = TRUE) } warp/man/warp_boundary.Rd0000644000176200001440000000452713743336661015165 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/boundary.R \name{warp_boundary} \alias{warp_boundary} \title{Locate period boundaries for a date vector} \usage{ warp_boundary(x, period, ..., every = 1L, origin = NULL) } \arguments{ \item{x}{\verb{[Date / POSIXct / POSIXlt]} A date time vector.} \item{period}{\verb{[character(1)]} A string defining the period to group by. Valid inputs can be roughly broken into: \itemize{ \item \code{"year"}, \code{"quarter"}, \code{"month"}, \code{"week"}, \code{"day"} \item \code{"hour"}, \code{"minute"}, \code{"second"}, \code{"millisecond"} \item \code{"yweek"}, \code{"mweek"} \item \code{"yday"}, \code{"mday"} }} \item{...}{\verb{[dots]} These dots are for future extensions and must be empty.} \item{every}{\verb{[positive integer(1)]} The number of periods to group together. For example, if the period was set to \code{"year"} with an every value of \code{2}, then the years 1970 and 1971 would be placed in the same group.} \item{origin}{\verb{[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]} The reference date time value. The default when left as \code{NULL} is the epoch time of \verb{1970-01-01 00:00:00}, \emph{in the time zone of the index}. This is generally used to define the anchor time to count from, which is relevant when the every value is \verb{> 1}.} } \value{ A two column data frame with the columns \code{start} and \code{stop}. Both are double vectors representing boundaries of the date time groups. } \description{ \code{warp_boundary()} detects a change in time period along \code{x}, for example, rolling from one month to the next. It returns the start and stop positions for each contiguous period chunk in \code{x}. } \details{ The stop positions are just the \code{\link[=warp_change]{warp_change()}} values, and the start positions are computed from these. } \examples{ x <- as.Date("1970-01-01") + -4:5 x # Boundaries by month warp_boundary(x, "month") # Bound by every 5 days, relative to "1970-01-01" # Creates boundaries of: # [1969-12-27, 1970-01-01) # [1970-01-01, 1970-01-06) # [1970-01-06, 1970-01-11) warp_boundary(x, "day", every = 5) # Bound by every 5 days, relative to the smallest value in our vector origin <- min(x) origin # Creates boundaries of: # [1969-12-28, 1970-01-02) # [1970-01-02, 1970-01-07) warp_boundary(x, "day", every = 5, origin = origin) } warp/DESCRIPTION0000644000176200001440000000224114520757362012743 0ustar liggesusersPackage: warp Title: Group Dates Version: 0.2.1 Authors@R: c( person("Davis", "Vaughan", , "davis@posit.co", role = c("aut", "cre")), person("Posit Software, PBC", role = c("cph", "fnd")) ) Description: Tooling to group dates by a variety of periods including: yearly, monthly, by second, by week of the month, and more. The groups are defined in such a way that they also represent the distance between dates in terms of the period. This extracts valuable information that can be used in further calculations that rely on a specific temporal spacing between observations. License: MIT + file LICENSE URL: https://github.com/DavisVaughan/warp, https://davisvaughan.github.io/warp/ BugReports: https://github.com/DavisVaughan/warp/issues Depends: R (>= 3.2) Suggests: covr, knitr, rmarkdown, testthat (>= 3.0.0) VignetteBuilder: knitr Config/Needs/website: tidyverse/tidytemplate Encoding: UTF-8 RoxygenNote: 7.2.3 NeedsCompilation: yes Packaged: 2023-11-02 13:46:26 UTC; davis Author: Davis Vaughan [aut, cre], Posit Software, PBC [cph, fnd] Maintainer: Davis Vaughan Repository: CRAN Date/Publication: 2023-11-02 17:40:02 UTC warp/build/0000755000176200001440000000000014520724062012324 5ustar liggesuserswarp/build/vignette.rds0000644000176200001440000000033514520724062014664 0ustar liggesusersmP0  QHLL|, period = "year") test_that("can warp_distance() by year with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "year"), 0) x <- as.Date("1971-01-01") expect_identical(warp_distance(x, "year"), 1) }) test_that("can warp_distance() by year with 'negative' Dates", { x <- as.Date("1969-01-01") expect_identical(warp_distance(x, "year"), -1) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "year", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "year", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "year", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "year"), 0) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, class = "Date") expect_identical(warp_distance(x, "year"), NA_real_) x <- structure(NA_integer_, class = "Date") expect_identical(warp_distance(x, "year"), NA_real_) }) test_that("can handle `every` with default origin", { x <- as.Date(c( "1967-01-01", "1968-01-01", "1969-01-01", "1970-01-01", "1971-01-01", "1972-01-01", "1973-01-01" )) expect_equal(warp_distance(x, period = "year", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "year", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "year", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin", { x <- as.Date(c( "1967-01-01", "1968-01-01", "1969-01-01", "1970-01-01", "1971-01-01", "1972-01-01", "1973-01-01" )) origin <- as.Date("1971-01-01") expect_equal(warp_distance(x, period = "year", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "year", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "year", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("fractional Date pieces are ignored", { # "1969-12-31 23:59:52 UTC" # .POSIXct(-0.0001 * 86400, "UTC") y <- structure(-0.0001, class = "Date") # But we really treat this as `new_date(0)` expect_equal(warp_distance(y, period = "year"), 0) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_equal(warp_distance(x, period = "year"), numeric()) expect_equal(warp_distance(x, period = "year", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_equal(warp_distance(x, period = "year"), numeric()) expect_equal(warp_distance(x, period = "year", every = 2), numeric()) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "year") test_that("can warp_distance() by year with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "year"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "year"), 1) }) test_that("can warp_distance() by year with 'negative' POSIXct", { x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "year"), -1) x <- as.POSIXct("1969-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "year"), -1) x <- as.POSIXct("1968-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "year"), -2) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "year"), NA) expect_identical(warp_distance(x, "year"), 1) expect_identical(warp_distance(x, "year", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "year", origin = origin1), NA) expect_identical(warp_distance(x, "year", origin = origin1), 0) expect_identical(warp_distance(x, "year", origin = origin2), -1) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "year", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "year", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "year", origin = origin)), 0 ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "year"), -1) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "year"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "year"), NA_real_) }) test_that("can handle `every` with default origin", { x <- as.POSIXct(c( "1967-01-01", "1968-01-01", "1969-01-01", "1970-01-01", "1971-01-01", "1972-01-01", "1973-01-01" ), tz = "UTC") expect_equal(warp_distance(x, period = "year", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "year", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "year", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin", { x <- as.POSIXct(c( "1967-01-01", "1968-01-01", "1969-01-01", "1970-01-01", "1971-01-01", "1972-01-01", "1973-01-01" ), tz = "UTC") origin <- as.Date("1971-01-01") expect_equal(warp_distance(x, period = "year", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "year", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "year", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with altered origin and altered timezone", { x <- as.POSIXct(c( "1967-01-01", "1968-01-01", "1969-01-01", "1970-01-01", "1971-01-01", "1972-01-01", "1973-01-01" ), tz = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_equal(warp_distance(x, period = "year", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "year", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "year", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "year"), warp_distance(y, period = "year") ) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "year") test_that("can warp_distance() by year with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "year"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "year"), 1) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "quarter") # This uses `period = "month"` with `every = every * 3`, so just do a basic test test_that("can warp_distance() by quarter with Date", { x <- as.Date(c("1970-01-01", "1970-03-31", "1970-04-01")) expect_identical(warp_distance(x, "quarter"), c(0, 0, 1)) }) test_that("can adjust the origin at the month level", { origin <- as.Date("1970-02-01") x <- as.Date(c("1970-01-01", "1970-04-30", "1970-05-01")) expect_identical(warp_distance(x, "quarter", origin = origin), c(-1, 0, 1)) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "quarter") test_that("can warp_distance() by quarter with POSIXct", { x <- as.POSIXct(c("1970-01-01 00:00:00", "1970-03-31 23:59:59", "1970-04-01 00:00:00"), "UTC") expect_identical(warp_distance(x, "quarter"), c(0, 0, 1)) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "month") test_that("can warp_distance() by month with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "month"), 0) x <- as.Date("1970-02-01") expect_identical(warp_distance(x, "month"), 1) x <- as.Date("1971-02-01") expect_identical(warp_distance(x, "month"), 13) }) test_that("can warp_distance() by month with 'negative' Dates", { x <- as.Date("1969-12-31") expect_identical(warp_distance(x, "month"), -1) x <- as.Date("1968-11-30") expect_identical(warp_distance(x, "month"), -14) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "month", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "month", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "month", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "month"), 0) x <- structure(31L, class = "Date") expect_identical(warp_distance(x, "month"), 1) }) test_that("can handle `every` with default origin", { x <- as.Date(c( "1969-10-01", "1969-11-01", "1969-12-01", "1970-01-01", "1970-02-01", "1970-03-01", "1970-04-01" )) expect_equal(warp_distance(x, period = "month", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "month", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "month", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin", { x <- as.Date(c( "1969-10-01", "1969-11-01", "1969-12-01", "1970-01-01", "1970-02-01", "1970-03-01", "1970-04-01" )) origin <- as.Date("1970-02-01") expect_equal(warp_distance(x, period = "month", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "month", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "month", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("fractional Date pieces are ignored", { # "1969-12-31 23:59:52 UTC" # .POSIXct(-0.0001 * 86400, "UTC") x <- structure(-0.0001, class = "Date") # But we really treat this as `new_date(0)` expect_equal(warp_distance(x, period = "month"), 0) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_equal(warp_distance(x, period = "month"), numeric()) expect_equal(warp_distance(x, period = "month", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_equal(warp_distance(x, period = "month"), numeric()) expect_equal(warp_distance(x, period = "month", every = 2), numeric()) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "month") test_that("can warp_distance() by month with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "month"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "month"), 12) }) test_that("can warp_distance() by month with 'negative' POSIXct", { x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "month"), -1) x <- as.POSIXct("1969-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "month"), -12) x <- as.POSIXct("1968-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "month"), -13) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "month"), NA) expect_identical(warp_distance(x, "month"), 12) expect_identical(warp_distance(x, "month", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "month", origin = origin1), NA) expect_identical(warp_distance(x, "month", origin = origin1), 0) expect_identical(warp_distance(x, "month", origin = origin2), -12) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "month", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "month", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971-01 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "month", origin = origin)), 0 ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "month"), -1) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "month"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "month"), NA_real_) }) test_that("can handle `every` with default origin", { x <- as.POSIXct(c( "1969-10-01", "1969-11-01", "1969-12-01", "1970-01-01", "1970-02-01", "1970-03-01", "1970-04-01" ), tz = "UTC") expect_equal(warp_distance(x, period = "month", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "month", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "month", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin", { x <- as.POSIXct(c( "1969-10-01", "1969-11-01", "1969-12-01", "1970-01-01", "1970-02-01", "1970-03-01", "1970-04-01" ), tz = "UTC") origin <- as.Date("1970-02-01") expect_equal(warp_distance(x, period = "month", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "month", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "month", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with altered origin and altered timezone", { x <- as.POSIXct(c( "1969-10-01", "1969-11-01", "1969-12-01", "1970-01-01", "1970-02-01", "1970-03-01", "1970-04-01" ), tz = "America/New_York") origin <- as.POSIXct("1970-02-01", tz = "America/New_York") expect_equal(warp_distance(x, period = "month", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "month", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "month", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "month"), warp_distance(y, period = "month") ) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "month") test_that("can warp_distance() by month with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "month"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "month"), 12) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "yweek") test_that("can warp_distance() by yweek with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "yweek"), 0) x <- as.Date("1970-01-08") expect_identical(warp_distance(x, "yweek"), 1) x <- as.Date("1971-01-01") expect_identical(warp_distance(x, "yweek"), 53) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "yweek", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "yweek", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "yweek", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "yweek"), 0) x <- structure(31L, class = "Date") expect_identical(warp_distance(x, "yweek"), 4) }) test_that("can handle `every` with default origin", { x <- as.Date(c( "1969-12-02", "1969-12-09", "1969-12-16", "1969-12-23", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-08", "1970-01-15", "1970-01-22" )) expect_equal(warp_distance(x, period = "yweek", every = 2L), c(-4, -3, -3, -2, -2, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "yweek", every = 3L), c(-3, -2, -2, -2, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "yweek", every = 4L), c(-3, -2, -2, -2, -2, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin", { x <- as.Date(c( "1969-12-02", "1969-12-09", "1969-12-16", "1969-12-23", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-06", "1970-01-07", "1970-01-08", "1970-01-15", "1970-01-22" )) origin <- as.Date("1970-01-08") expect_equal(warp_distance(x, period = "yweek", every = 2L, origin = origin), c(-4, -4, -3, -3, -2, -2, -2, -2, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "yweek", every = 3L, origin = origin), c(-3, -3, -2, -2, -2, -1, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "yweek", every = 4L, origin = origin), c(-3, -3, -2, -2, -2, -2, -2, -2, -1, 0, 0, 0)) }) test_that("fractional Date pieces are ignored", { # "1969-12-31 23:59:52 UTC" # .POSIXct(-0.0001 * 86400, "UTC") x <- structure(-0.0001, class = "Date") # But we really treat this as `new_date(0)` expect_equal(warp_distance(x, period = "yweek"), 0) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_equal(warp_distance(x, period = "yweek"), numeric()) expect_equal(warp_distance(x, period = "yweek", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_equal(warp_distance(x, period = "yweek"), numeric()) expect_equal(warp_distance(x, period = "yweek", every = 2), numeric()) }) test_that("going backwards in time still uses groups computed from the first of the year", { # The 53rd yweek of 1969 x <- as.Date("1969-12-31") # The 52nd yweek of 1969 y <- as.Date("1969-12-30") expect_identical(warp_distance(x, "yweek"), -1) expect_identical(warp_distance(y, "yweek"), -2) }) test_that("leap years in `x` affect the yweek group", { origin <- as.Date("1999-03-01") x <- as.Date(c("1999-02-27", "1999-02-28", "1999-03-01", "1999-03-02", "1999-03-07", "1999-03-08")) y <- as.Date(c("2000-02-27", "2000-02-28", "2000-02-29", "2000-03-01", "2000-03-02", "2000-03-07", "2000-03-08")) z <- as.Date(c("2001-02-27", "2001-02-28", "2001-03-01", "2001-03-02", "2001-03-07", "2001-03-08")) # 1998-03-01 -> 1999-02-21 = 51 full weeks # [1999-02-21, 1999-02-28) = -2 # [1999-02-28, 1999-03-01) = -1 # [1999-03-01, 1999-03-08) = 0 # [1999-03-08, 1999-03-15) = 1 expect_identical(warp_distance(x, period = "yweek", every = 1, origin = origin), c(-2, -1, 0, 0, 0, 1)) # 1999-03-01 -> 2000-02-21 = 51 full weeks # [2000-02-21, 2000-02-28) = 51 # [2000-02-28, 2000-03-01) = 52 # [2000-03-01, 2000-03-08) = 53 # [2000-03-08, 2000-03-15) = 54 expect_identical(warp_distance(y, period = "yweek", every = 1, origin = origin), c(51, 52, 52, 53, 53, 53, 54)) # 2000-03-01 -> 2001-02-21 = 51 full weeks # [2001-02-21, 2001-02-28) = 104 # [2001-02-28, 2001-03-01) = 105 # [2001-03-01, 2001-03-08) = 106 # [2001-03-08, 2001-03-15) = 107 expect_identical(warp_distance(z, period = "yweek", every = 1, origin = origin), c(104, 105, 106, 106, 106, 107)) }) test_that("leap years in `origin` affect the yweek group", { origin <- as.Date("2000-03-01") x <- as.Date(c("1999-02-27", "1999-02-28", "1999-03-01", "1999-03-02", "1999-03-07", "1999-03-08")) y <- as.Date(c("2000-02-27", "2000-02-28", "2000-02-29", "2000-03-01", "2000-03-02", "2000-03-07", "2000-03-08")) z <- as.Date(c("2001-02-27", "2001-02-28", "2001-03-01", "2001-03-02", "2001-03-07", "2001-03-08")) # 1998-03-01 -> 1999-02-21 = 51 full weeks # [1999-02-21, 1999-02-28) = -55 # [1999-02-28, 1999-03-01) = -54 # [1999-03-01, 1999-03-08) = -53 # [1999-03-08, 1999-03-15) = -52 expect_identical(warp_distance(x, period = "yweek", every = 1, origin = origin), c(-55, -54, -53, -53, -53, -52)) # 1999-03-01 -> 2000-02-21 = 51 full weeks # [2000-02-21, 2000-02-28) = -2 # [2000-02-28, 2000-03-01) = -1 # [2000-03-01, 2000-03-08) = 0 # [2000-03-08, 2000-03-15) = 1 expect_identical(warp_distance(y, period = "yweek", every = 1, origin = origin), c(-2, -1, -1, 0, 0, 0, 1)) # 2000-03-01 -> 2001-02-21 = 51 full weeks # [2001-02-21, 2001-02-28) = 104 # [2001-02-28, 2001-03-01) = 105 # [2001-03-01, 2001-03-08) = 106 # [2001-03-08, 2001-03-15) = 107 expect_identical(warp_distance(z, period = "yweek", every = 1, origin = origin), c(51, 52, 53, 53, 53, 54)) }) test_that("`origin` value can be on the leap day", { origin <- as.Date("2000-02-29") # Non-leap years start that group on 02/28 x <- as.Date(c("1999-02-27", "1999-02-28", "1999-03-01", "1999-03-02", "1999-03-07", "1999-03-08")) y <- as.Date(c("2000-02-27", "2000-02-28", "2000-02-29", "2000-03-01", "2000-03-02", "2000-03-07", "2000-03-08")) z <- as.Date(c("2001-02-27", "2001-02-28", "2001-03-01", "2001-03-02", "2001-03-07", "2001-03-08")) # 1998-02-28 -> 1999-02-27 = 52 full weeks # [1999-02-27, 1999-02-28) = -54 # [1999-02-28, 1999-03-07) = -53 # [1999-03-07, 1999-03-15) = -52 expect_identical(warp_distance(x, period = "yweek", every = 1, origin = origin), c(-54, -53, -53, -53, -52, -52)) # 1999-02-28 -> 2000-02-27 = 52 full weeks # [2000-02-27, 2000-02-29) = -1 # [2000-02-29, 2000-03-07) = 0 # [2000-03-07, 2000-03-15) = 1 expect_identical(warp_distance(y, period = "yweek", every = 1, origin = origin), c(-1, -1, 0, 0, 0, 1, 1)) # 2000-02-29 -> 2001-02-27 = 52 full weeks # [2001-02-27, 2001-02-28) = 52 # [2001-02-28, 2001-03-07) = 53 # [2001-03-07, 2001-03-15) = 54 expect_identical(warp_distance(z, period = "yweek", every = 1, origin = origin), c(52, 53, 53, 53, 54, 54)) }) test_that("Ignoring the leap adjustment if before Feb 28th is required", { origin <- as.Date("1970-01-01") x <- as.Date(c("2019-12-31", "2020-01-01")) # if we don't ignore the leap adjustment we end up with both at 2649 expect_identical(warp_distance(x, "yweek", origin = origin), c(2649, 2650)) }) test_that("sanity check `every`", { expect_error(warp_distance(as.Date("1970-01-01"), "yweek", every = 53), "is 52") }) # ------------------------------------------------------------------------------ # warp_distance(, period = "yweek") test_that("can warp_distance() by yweek with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "yweek"), 0) x <- as.POSIXct("1970-01-08", tz = "UTC") expect_identical(warp_distance(x, "yweek"), 1) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "yweek"), NA) expect_identical(warp_distance(x, "yweek"), 53) expect_identical(warp_distance(x, "yweek", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "yweek", origin = origin1), NA) expect_identical(warp_distance(x, "yweek", origin = origin1), 0) expect_identical(warp_distance(x, "yweek", origin = origin2), -53) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "yweek", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "yweek", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971-01 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "yweek", origin = origin)), 0 ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "yweek"), -1) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "yweek"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "yweek"), NA_real_) }) test_that("can handle `every` with default origin", { x <- as.POSIXct(c( "1969-12-02", "1969-12-09", "1969-12-16", "1969-12-23", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-08", "1970-01-15", "1970-01-22" ), tz = "UTC") expect_equal(warp_distance(x, period = "yweek", every = 2L), c(-4, -3, -3, -2, -2, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "yweek", every = 3L), c(-3, -2, -2, -2, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "yweek", every = 4L), c(-3, -2, -2, -2, -2, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin", { x <- as.POSIXct(c( "1969-12-02", "1969-12-09", "1969-12-16", "1969-12-23", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-06", "1970-01-07", "1970-01-08", "1970-01-15", "1970-01-22" ), tz = "UTC") origin <- as.Date("1970-01-08") expect_equal(warp_distance(x, period = "yweek", every = 2L, origin = origin), c(-4, -4, -3, -3, -2, -2, -2, -2, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "yweek", every = 3L, origin = origin), c(-3, -3, -2, -2, -2, -1, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "yweek", every = 4L, origin = origin), c(-3, -3, -2, -2, -2, -2, -2, -2, -1, 0, 0, 0)) }) test_that("can handle `every` with altered origin and altered timezone", { x <- as.POSIXct(c( "1969-12-02", "1969-12-09", "1969-12-16", "1969-12-23", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-06", "1970-01-07", "1970-01-08", "1970-01-15", "1970-01-22" ), tz = "America/New_York") origin <- as.POSIXct("1970-01-08", tz = "America/New_York") expect_equal(warp_distance(x, period = "yweek", every = 2L, origin = origin), c(-4, -4, -3, -3, -2, -2, -2, -2, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "yweek", every = 3L, origin = origin), c(-3, -3, -2, -2, -2, -1, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "yweek", every = 4L, origin = origin), c(-3, -3, -2, -2, -2, -2, -2, -2, -1, 0, 0, 0)) }) test_that("going backwards in time still uses groups computed from the first of the year", { # The 53rd yweek of 1969 x <- as.POSIXct("1969-12-31", "UTC") # The 52nd yweek of 1969 y <- as.POSIXct("1969-12-30", "UTC") expect_identical(warp_distance(x, "yweek"), -1) expect_identical(warp_distance(y, "yweek"), -2) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "yweek"), warp_distance(y, period = "yweek") ) }) test_that("`origin` value can be on the leap day", { origin <- as.POSIXct("2000-02-29", "UTC") # Non-leap years start that group on 02/28 x <- as.POSIXct(c("1999-02-27", "1999-02-28", "1999-03-01", "1999-03-02", "1999-03-07", "1999-03-08"), "UTC") y <- as.POSIXct(c("2000-02-27", "2000-02-28", "2000-02-29", "2000-03-01", "2000-03-02", "2000-03-07", "2000-03-08"), "UTC") z <- as.POSIXct(c("2001-02-27", "2001-02-28", "2001-03-01", "2001-03-02", "2001-03-07", "2001-03-08"), "UTC") # 1998-02-28 -> 1999-02-27 = 52 full weeks # [1999-02-27, 1999-02-28) = -54 # [1999-02-28, 1999-03-07) = -53 # [1999-03-07, 1999-03-15) = -52 expect_identical(warp_distance(x, period = "yweek", every = 1, origin = origin), c(-54, -53, -53, -53, -52, -52)) # 1999-02-28 -> 2000-02-27 = 52 full weeks # [2000-02-27, 2000-02-29) = -1 # [2000-02-29, 2000-03-07) = 0 # [2000-03-07, 2000-03-15) = 1 expect_identical(warp_distance(y, period = "yweek", every = 1, origin = origin), c(-1, -1, 0, 0, 0, 1, 1)) # 2000-02-29 -> 2001-02-27 = 52 full weeks # [2001-02-27, 2001-02-28) = 52 # [2001-02-28, 2001-03-07) = 53 # [2001-03-07, 2001-03-15) = 54 expect_identical(warp_distance(z, period = "yweek", every = 1, origin = origin), c(52, 53, 53, 53, 54, 54)) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "yweek") test_that("can warp_distance() by yweek with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "yweek"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "yweek"), 53) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "mweek") # Mainly tested in `period = "mday"` test_that("warp_distance() with mweek period works", { x <- as.Date("1970-01-01") + 0:500 expect_identical( warp_distance(x, "mweek"), warp_distance(x, "mday", every = 7) ) }) test_that("sanity check `every`", { expect_error(warp_distance(new_date(0), "mweek", every = 5), "is 4") }) # ------------------------------------------------------------------------------ # warp_distance(, period = "week") # Mainly tested in `period = "day"` test_that("warp_distance() with week period works through day", { x <- as.Date("1970-01-01") + 0:500 expect_identical( warp_distance(x, "week"), warp_distance(x, "day", every = 7) ) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "yday") # Mainly tested in `period = "yweek"` test_that("warp_distance() with yday period works", { x <- as.Date("1970-01-01") + 0:500 expect_identical( warp_distance(x, "yday", every = 7), warp_distance(x, "yweek") ) }) test_that("sanity check `every`", { expect_error(warp_distance(new_date(0), "yday", every = 365), "is 364") }) test_that("can use an integer Date origin with yday", { origin <- structure(1L, class = "Date") expect_identical(warp_distance(new_date(0), "yday", origin = origin), -1) }) test_that("integer Date origin that is NA is an error", { origin <- structure(NA_integer_, class = "Date") expect_error(warp_distance(new_date(0), "yday", origin = origin), "cannot be `NA`") }) test_that("double Date origin that is NA / NaN / Inf is an error", { origin <- structure(NA_real_, class = "Date") expect_error(warp_distance(new_date(0), "yday", origin = origin), "must be finite") origin <- structure(NaN, class = "Date") expect_error(warp_distance(new_date(0), "yday", origin = origin), "must be finite") origin <- structure(Inf, class = "Date") expect_error(warp_distance(new_date(0), "yday", origin = origin), "must be finite") }) # ------------------------------------------------------------------------------ # warp_distance(, period = "mday") test_that("can warp_distance() by mday with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "mday"), warp_distance(x, "day")) x <- as.Date("1970-01-08") expect_identical(warp_distance(x, "mday"), warp_distance(x, "day")) x <- as.Date("1971-01-01") expect_identical(warp_distance(x, "mday"), warp_distance(x, "day")) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "mday", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "mday", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "mday", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "mday"), 0) x <- structure(31L, class = "Date") expect_identical(warp_distance(x, "mday"), 31) }) test_that("leap year borders are handled correctly", { x <- as.Date(c("1968-12-31", "1969-01-01")) origin <- as.Date("1969-01-01") expect_equal(warp_distance(x, "mday", every = 2, origin = origin), c(-1, 0)) }) test_that("can handle `every` with default origin", { x <- as.Date(c( "1968-12-31", "1969-01-01", "1969-11-30", "1969-12-01", "1969-12-28", "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03" )) expect_equal(warp_distance(x, period = "mday", every = 2L), c(-187, -186, -17, -16, -3, -2, -2, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "mday", every = 3L), c(-128, -127, -12, -11, -2, -2, -2, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "mday", every = 4L), c(-96, -95, -9, -8, -2, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with altered origin", { x <- as.Date(c( "1968-12-31", "1969-01-01", "1969-11-30", "1969-12-01", "1969-12-28", "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03" )) origin <- as.Date("1969-12-01") expect_equal(warp_distance(x, period = "mday", every = 2L, origin = origin), c(-171, -170, -1, 0, 13, 14, 14, 15, 16, 16, 17)) expect_equal(warp_distance(x, period = "mday", every = 3L, origin = origin), c(-117, -116, -1, 0, 9, 9, 9, 10, 11, 11, 11)) expect_equal(warp_distance(x, period = "mday", every = 4L, origin = origin), c(-88, -87, -1, 0, 6, 7, 7, 7, 8, 8, 8)) }) test_that("fractional Date pieces are ignored", { # "1969-12-31 23:59:52 UTC" # .POSIXct(-0.0001 * 86400, "UTC") x <- structure(-0.0001, class = "Date") # But we really treat this as `new_date(0)` expect_equal(warp_distance(x, period = "mday"), 0) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_equal(warp_distance(x, period = "mday"), numeric()) expect_equal(warp_distance(x, period = "mday", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_equal(warp_distance(x, period = "mday"), numeric()) expect_equal(warp_distance(x, period = "mday", every = 2), numeric()) }) test_that("going backwards in time still uses groups computed from the first of the year", { # The 53rd mday of 1969 x <- as.Date("1969-12-31") # The 52nd mday of 1969 y <- as.Date("1969-12-30") expect_identical(warp_distance(x, "mday"), -1) expect_identical(warp_distance(y, "mday"), -2) }) test_that("sanity check `every`", { expect_error(warp_distance(as.Date("1970-01-01"), "mday", every = 31), "is 30") }) test_that("can use an integer Date origin with mday", { origin <- structure(-1L, class = "Date") expect_identical(warp_distance(new_date(0), "mday", origin = origin), 31) }) test_that("integer Date origin that is NA is an error", { origin <- structure(NA_integer_, class = "Date") expect_error(warp_distance(new_date(0), "mday", origin = origin), "cannot be `NA`") }) test_that("double Date origin that is NA / NaN / Inf is an error", { origin <- structure(NA_real_, class = "Date") expect_error(warp_distance(new_date(0), "mday", origin = origin), "must be finite") origin <- structure(NaN, class = "Date") expect_error(warp_distance(new_date(0), "mday", origin = origin), "must be finite") origin <- structure(Inf, class = "Date") expect_error(warp_distance(new_date(0), "mday", origin = origin), "must be finite") }) # ------------------------------------------------------------------------------ # warp_distance(, period = "mday") test_that("can warp_distance() by mday with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "mday"), warp_distance(x, "day")) x <- as.POSIXct("1970-01-08", tz = "UTC") expect_identical(warp_distance(x, "mday"), warp_distance(x, "day")) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "mday"), NA) expect_identical(warp_distance(x, "mday"), 365) expect_identical(warp_distance(x, "mday", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "mday", origin = origin1), NA) expect_identical(warp_distance(x, "mday", origin = origin1), 0) expect_identical(warp_distance(x, "mday", origin = origin2), -365) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "mday", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "mday", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971-01 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "mday", origin = origin)), 0 ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "mday"), -1) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "mday"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "mday"), NA_real_) }) test_that("can handle `every` with default origin", { x <- as.POSIXct(c( "1968-12-31", "1969-01-01", "1969-11-30", "1969-12-01", "1969-12-28", "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03" ), tz = "UTC") expect_equal(warp_distance(x, period = "mday", every = 2L), c(-187, -186, -17, -16, -3, -2, -2, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "mday", every = 3L), c(-128, -127, -12, -11, -2, -2, -2, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "mday", every = 4L), c(-96, -95, -9, -8, -2, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with altered origin", { x <- as.POSIXct(c( "1968-12-31", "1969-01-01", "1969-11-30", "1969-12-01", "1969-12-28", "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03" ), tz = "UTC") origin <- as.POSIXct("1969-12-01", "UTC") expect_equal(warp_distance(x, period = "mday", every = 2L, origin = origin), c(-171, -170, -1, 0, 13, 14, 14, 15, 16, 16, 17)) expect_equal(warp_distance(x, period = "mday", every = 3L, origin = origin), c(-117, -116, -1, 0, 9, 9, 9, 10, 11, 11, 11)) expect_equal(warp_distance(x, period = "mday", every = 4L, origin = origin), c(-88, -87, -1, 0, 6, 7, 7, 7, 8, 8, 8)) }) test_that("can handle `every` with altered origin and altered timezone", { x <- as.POSIXct(c( "1968-12-31", "1969-01-01", "1969-11-30", "1969-12-01", "1969-12-28", "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03" ), tz = "America/New_York") origin <- as.POSIXct("1969-12-01", tz = "America/New_York") expect_equal(warp_distance(x, period = "mday", every = 2L, origin = origin), c(-171, -170, -1, 0, 13, 14, 14, 15, 16, 16, 17)) expect_equal(warp_distance(x, period = "mday", every = 3L, origin = origin), c(-117, -116, -1, 0, 9, 9, 9, 10, 11, 11, 11)) expect_equal(warp_distance(x, period = "mday", every = 4L, origin = origin), c(-88, -87, -1, 0, 6, 7, 7, 7, 8, 8, 8)) }) test_that("going backwards in time still uses groups computed from the first of the year", { # The 53rd mday of 1969 x <- as.POSIXct("1969-12-31", "UTC") # The 52nd mday of 1969 y <- as.POSIXct("1969-12-30", "UTC") expect_identical(warp_distance(x, "mday"), -1) expect_identical(warp_distance(y, "mday"), -2) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "mday"), warp_distance(y, period = "mday") ) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "mday") test_that("can warp_distance() by mday with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "mday"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "mday"), 365) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "day") test_that("can warp_distance() by day with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "day"), 0) x <- as.Date("1970-01-02") expect_identical(warp_distance(x, "day"), 1) x <- as.Date("1971-01-01") expect_identical(warp_distance(x, "day"), 365) }) test_that("can warp_distance() by day with 'negative' Dates", { x <- as.Date("1969-12-31") expect_identical(warp_distance(x, "day"), -1) x <- as.Date("1969-12-30") expect_identical(warp_distance(x, "day"), -2) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "day", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "day", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "day", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "day"), 0) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, class = "Date") expect_identical(warp_distance(x, "day"), NA_real_) x <- structure(NA_integer_, class = "Date") expect_identical(warp_distance(x, "day"), NA_real_) }) test_that("can handle `every` with default origin - integer Dates", { x <- structure(-3L:3L, class = "Date") expect_equal(warp_distance(x, period = "day", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "day", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "day", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer Dates", { x <- structure(-3L:3L, class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "day", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "day", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "day", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") expect_equal(warp_distance(x, period = "day", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "day", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "day", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "day", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "day", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "day", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("fractional Date pieces are ignored", { # "1969-12-31 23:59:52 UTC" # .POSIXct(-0.0001 * 86400, "UTC") x <- structure(-0.0001, class = "Date") # But we really treat this as `new_date(0)` expect_equal(warp_distance(x, period = "day"), 0) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_equal(warp_distance(x, period = "day"), numeric()) expect_equal(warp_distance(x, period = "day", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_equal(warp_distance(x, period = "day"), numeric()) expect_equal(warp_distance(x, period = "day", every = 2), numeric()) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "day") test_that("can warp_distance() by day with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "day"), 0) x <- as.POSIXct("1970-01-02", tz = "UTC") expect_identical(warp_distance(x, "day"), 1) x <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "day"), 365) }) # In terms of inclusion/exclusion, we define the cutoffs like: # [1969-12-30 00:00:00 -> 1969-12-31 00:00:00) = -2 days from epoch # [1969-12-31 00:00:00 -> 1970-01-01 00:00:00) = -1 days from epoch # [1970-01-01 00:00:00 -> 1970-01-02 00:00:00) = 0 days from epoch # [1970-01-02 00:00:00 -> 1970-01-03 00:00:00) = 1 days from epoch test_that("can warp_distance() by day with 'negative' POSIXct", { x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "day"), -2) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "day"), -2) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "day"), -1) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "day"), -1) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "day"), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "day"), 0) x <- as.POSIXct("1970-01-02 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "day"), 1) x <- as.POSIXct("1969-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "day"), -365) x <- as.POSIXct("1968-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "day"), -366) }) test_that("can warp_distance() by day with 'negative' POSIXct and different UTC origins", { origin <- as.POSIXct("1969-12-31", tz = "UTC") x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "day", origin = origin), -1) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "day", origin = origin), -1) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "day", origin = origin), 0) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "day", origin = origin), 0) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "day", origin = origin), 1) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "day", origin = origin), 1) }) test_that("can warp_distance() by day with 'negative' POSIXct and non-UTC origins", { origin <- as.POSIXct("1970-01-01", tz = "America/New_York") x <- as.POSIXct("1969-12-30 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "day", origin = origin), -2) x <- as.POSIXct("1969-12-30 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "day", origin = origin), -2) x <- as.POSIXct("1969-12-31 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "day", origin = origin), -1) x <- as.POSIXct("1969-12-31 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "day", origin = origin), -1) x <- as.POSIXct("1970-01-01 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "day", origin = origin), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "day", origin = origin), 0) x <- as.POSIXct("1970-01-02 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "day", origin = origin), 1) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "day"), NA) expect_identical(warp_distance(x, "day"), 365) expect_identical(warp_distance(x, "day", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "day", origin = origin1), NA) expect_identical(warp_distance(x, "day", origin = origin1), 0) expect_identical(warp_distance(x, "day", origin = origin2), -365) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "day", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "day", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971-01-01 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "day", origin = origin)), 0 ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "day"), -1) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "day"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "day"), NA_real_) }) test_that("can handle `every` with default origin - integer POSIXct", { x <- as.POSIXct(c( "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03", "1970-01-04" ), tz = "UTC") x <- structure(as.integer(unclass(x)), tzone = "UTC", class = class(x)) expect_equal(warp_distance(x, period = "day", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "day", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "day", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer POSIXct", { x <- as.POSIXct(c( "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03", "1970-01-04" ), tz = "UTC") x <- structure(as.integer(unclass(x)), tzone = "UTC", class = class(x)) origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "day", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "day", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "day", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03", "1970-01-04" ), tz = "UTC") expect_equal(warp_distance(x, period = "day", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "day", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "day", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-29", "1969-12-30", "1969-12-31", "1970-01-01", "1970-01-02", "1970-01-03", "1970-01-04" ), tz = "UTC") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "day", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "day", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "day", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("fractional negative seconds are handled correctly", { # Since we don't test all R-devel versions in CI, lets be extra safe here and # just not run this on CRAN skip_on_cran() skip_if(getRversion() < "4.4.0", "Used to be broken on everything except Linux") # `as.POSIXlt()` was wrong on (except on Linux, I think) until this was fixed: # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17667 # If working correctly, this should print as: # "1969-12-31T23:59:59.5" x <- .POSIXct(-0.5, "UTC") # This is # "1969-12-30T23:59:59.5" y <- .POSIXct(-86400.5, "UTC") # `as.POSIXlt()` used to give the wrong result by ignoring the negative # fractional part expect_identical(warp_distance(x, "day"), -1) expect_identical(warp_distance(y, "day"), -2) }) test_that("DST is respected", { origin <- as.POSIXct("2018-03-11", "America/New_York") x <- as.POSIXct("2018-03-11 01:59:59", "America/New_York") # `x + 1` crosses the DST gap, so this day actually has 1 less hour. # We ensure that the 23:59:59 hour does not look like it has creeped into # the next day. If we used the pure POSIXct seconds, ignoring the time zone, # then we would have a problem! x <- x + c(0:1, 75600, 75601) expect_equal(warp_distance(x, "day", origin = origin), c(0, 0, 0, 1)) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "day"), warp_distance(y, period = "day") ) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "day") test_that("can warp_distance() by day with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "day"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "day"), 365) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "hour") test_that("can warp_distance() by hour with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "hour"), 0) x <- as.Date("1970-01-02") expect_identical(warp_distance(x, "hour"), 24) x <- as.Date("1971-01-01") expect_identical(warp_distance(x, "hour"), 24 * 365) }) test_that("can warp_distance() by hour with 'negative' Dates", { x <- as.Date("1969-12-31") expect_identical(warp_distance(x, "hour"), -24) x <- as.Date("1969-12-30") expect_identical(warp_distance(x, "hour"), -48) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "hour", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { # America/New_York is 5 hours before UTC x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "hour", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "hour", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "hour"), 0) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, class = "Date") expect_identical(warp_distance(x, "hour"), NA_real_) x <- structure(NA_integer_, class = "Date") expect_identical(warp_distance(x, "hour"), NA_real_) }) test_that("can handle `every` with default origin - integer Dates", { x <- structure(-3L:3L, class = "Date") expect_equal(warp_distance(x, period = "hour", every = 48L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "hour", every = 72L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "hour", every = 96L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer Dates", { x <- structure(-3L:3L, class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "hour", every = 48L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "hour", every = 72L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "hour", every = 96L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") expect_equal(warp_distance(x, period = "hour", every = 48L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "hour", every = 72L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "hour", every = 96L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "hour", every = 48L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "hour", every = 72L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "hour", every = 96L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can ignore fractional pieces in Dates", { # "1970-01-01 02:24:00 UTC" # structure(.1 * 86400, tzone = "UTC", class = c("POSIXct", "POSIXt")) x <- structure(.1, class = "Date") # "1969-12-31 23:52:48 UTC" # structure(-.005 * 86400, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.005, class = "Date") expect_identical(warp_distance(x, period = "hour"), 0) expect_identical(warp_distance(y, period = "hour"), 0) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_identical(warp_distance(x, period = "hour"), numeric()) expect_identical(warp_distance(x, period = "hour", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_identical(warp_distance(x, period = "hour"), numeric()) expect_identical(warp_distance(x, period = "hour", every = 2), numeric()) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "hour") test_that("can warp_distance() by hour with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "hour"), 0) x <- as.POSIXct("1970-01-02", tz = "UTC") expect_identical(warp_distance(x, "hour"), 24) x <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "hour"), 24 * 365) }) # In terms of inclusion/exclusion, we define the cutoffs like: # [1969-12-30 00:00:00 -> 1969-12-31 00:00:00) = -48 hours from epoch # [1969-12-31 00:00:00 -> 1970-01-01 00:00:00) = -24 hours from epoch # [1970-01-01 00:00:00 -> 1970-01-02 00:00:00) = 0 hours from epoch # [1970-01-02 00:00:00 -> 1970-01-03 00:00:00) = 24 hours from epoch test_that("can warp_distance() by hour with 'negative' POSIXct", { x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour"), -48) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "hour"), -25) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour"), -24) x <- as.POSIXct("1969-12-31 01:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour"), -23) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "hour"), -1) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour"), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "hour"), 23) x <- as.POSIXct("1970-01-02 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour"), 24) x <- as.POSIXct("1969-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour"), -8760) x <- as.POSIXct("1968-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "hour"), -8761) }) test_that("can warp_distance() by hour with 'negative' POSIXct and different UTC origins", { origin <- as.POSIXct("1969-12-31", tz = "UTC") x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour", origin = origin), -24) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "hour", origin = origin), -1) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour", origin = origin), 0) x <- as.POSIXct("1969-12-31 01:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour", origin = origin), 1) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "hour", origin = origin), 23) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "hour", origin = origin), 24) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "hour", origin = origin), 47) }) test_that("can warp_distance() by hour with 'negative' POSIXct and non-UTC origins", { origin <- as.POSIXct("1970-01-01", tz = "America/New_York") x <- as.POSIXct("1969-12-30 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "hour", origin = origin), -48) x <- as.POSIXct("1969-12-30 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "hour", origin = origin), -25) x <- as.POSIXct("1969-12-31 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "hour", origin = origin), -24) x <- as.POSIXct("1969-12-31 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "hour", origin = origin), -1) x <- as.POSIXct("1970-01-01 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "hour", origin = origin), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "hour", origin = origin), 23) x <- as.POSIXct("1970-01-02 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "hour", origin = origin), 24) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "hour"), NA) expect_identical(warp_distance(x, "hour"), 8760) expect_identical(warp_distance(x, "hour", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "hour", origin = origin1), NA) expect_identical(warp_distance(x, "hour", origin = origin1), 0) expect_identical(warp_distance(x, "hour", origin = origin2), -8760) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "hour", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "hour", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971-01-01 04:00:00 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "hour", origin = origin)), 4 ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "hour"), -1) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "hour"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "hour"), NA_real_) }) test_that("can handle `every` with default origin - integer POSIXct", { x <- as.POSIXct(c( "1969-12-31 21:00:00", "1969-12-31 22:00:00", "1969-12-31 23:00:00", "1970-01-01 00:00:00", "1970-01-01 01:00:00", "1970-01-01 02:00:00", "1970-01-01 03:00:00" ), tz = "UTC") x <- structure(as.integer(unclass(x)), tzone = "UTC", class = class(x)) expect_equal(warp_distance(x, period = "hour", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "hour", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "hour", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer POSIXct", { x <- as.POSIXct(c( "1969-12-31 21:00:00", "1969-12-31 22:00:00", "1969-12-31 23:00:00", "1970-01-01 00:00:00", "1970-01-01 01:00:00", "1970-01-01 02:00:00", "1970-01-01 03:00:00" ), tz = "UTC") x <- structure(as.integer(unclass(x)), tzone = "UTC", class = class(x)) origin <- as.POSIXct("1970-01-01 01:00:00", tz = "UTC") expect_equal(warp_distance(x, period = "hour", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "hour", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "hour", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 21:00:00", "1969-12-31 22:00:00", "1969-12-31 23:00:00", "1970-01-01 00:00:00", "1970-01-01 01:00:00", "1970-01-01 02:00:00", "1970-01-01 03:00:00" ), tz = "UTC") expect_equal(warp_distance(x, period = "hour", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "hour", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "hour", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 21:00:00", "1969-12-31 22:00:00", "1969-12-31 23:00:00", "1970-01-01 00:00:00", "1970-01-01 01:00:00", "1970-01-01 02:00:00", "1970-01-01 03:00:00" ), tz = "UTC") origin <- as.POSIXct("1970-01-01 01:00:00", tz = "UTC") expect_equal(warp_distance(x, period = "hour", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "hour", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "hour", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle fractional seconds before the epoch correctly", { # Base R printing is wrong, because as.POSIXlt() is wrong # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17667 # I don't care what base R prints this as, this is: # "1969-12-31T23:59:59.5" x <- .POSIXct(-0.5, "UTC") # This is # "1969-12-31T22:59:59.5" y <- .POSIXct(-3600.5, "UTC") expect_identical(warp_distance(x, "hour"), -1) expect_identical(warp_distance(y, "hour"), -2) }) test_that("values past microseconds are ignored", { x <- structure(-.000002, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.0000002, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_equal(warp_distance(x, "hour"), -1) expect_equal(warp_distance(y, "hour"), 0) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "hour"), warp_distance(y, period = "hour") ) }) test_that("half-hour offset time zones are correct (#13)", { chr <- c( "1970-01-01 00:00:00", "1970-01-01 00:50:00", "1970-01-01 01:00:00", "1970-01-01 01:20:00", "1970-01-01 01:30:00" ) x <- as.POSIXct(chr, "Asia/Kolkata") y <- as.POSIXct(chr, "UTC") expect_equal( warp_distance(x, period = "hour"), warp_distance(y, period = "hour") ) }) test_that("can have an integer POSIXct origin", { x <- new_datetime(60 * 60, "UTC") origin <- structure(0L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical( warp_distance(x, period = "hour", origin = origin), 1 ) }) test_that("integer Date `origin` cannot be NA_integer_", { x <- new_datetime(0, "UTC") origin <- structure(NA_integer_, class = "Date") expect_error(warp_distance(x, period = "hour", origin = origin), "`origin` must be finite") }) test_that("double Date `origin` cannot be NA_real_ / NaN / Inf", { x <- new_datetime(0, "UTC") origin <- structure(NA_real_, class = "Date") expect_error(warp_distance(x, period = "hour", origin = origin), "`origin` must be finite") origin <- structure(NaN, class = "Date") expect_error(warp_distance(x, period = "hour", origin = origin), "`origin` must be finite") origin <- structure(Inf, class = "Date") expect_error(warp_distance(x, period = "hour", origin = origin), "`origin` must be finite") }) test_that("double POSIXct `origin` cannot be NA_real_ / NaN / Inf", { x <- new_datetime(0, "UTC") origin <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_error(warp_distance(x, period = "hour", origin = origin), "`origin` must be finite") origin <- structure(NaN, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_error(warp_distance(x, period = "hour", origin = origin), "`origin` must be finite") origin <- structure(Inf, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_error(warp_distance(x, period = "hour", origin = origin), "`origin` must be finite") }) test_that("integer POSIXct `origin` cannot be NA_integer_", { x <- new_datetime(0, "UTC") origin <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_error(warp_distance(x, period = "hour", origin = origin), "`origin` must be finite") }) # ------------------------------------------------------------------------------ # warp_distance(, period = "hour") test_that("can warp_distance() by hour with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "hour"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "hour"), 8760) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "minute") test_that("can warp_distance() by minute with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "minute"), 0) x <- as.Date("1970-01-02") expect_identical(warp_distance(x, "minute"), 1440) x <- as.Date("1971-01-01") expect_identical(warp_distance(x, "minute"), 60 * 24 * 365) }) test_that("can warp_distance() by minute with 'negative' Dates", { x <- as.Date("1969-12-31") expect_identical(warp_distance(x, "minute"), -1440) x <- as.Date("1969-12-30") expect_identical(warp_distance(x, "minute"), -1440 * 2) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "minute", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { # America/New_York is 5 minutes before UTC x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "minute", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "minute", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "minute"), 0) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, class = "Date") expect_identical(warp_distance(x, "minute"), NA_real_) x <- structure(NA_integer_, class = "Date") expect_identical(warp_distance(x, "minute"), NA_real_) }) test_that("can handle `every` with default origin - integer Dates", { x <- structure(-3L:3L, class = "Date") expect_equal(warp_distance(x, period = "minute", every = 2880L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "minute", every = 4320L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "minute", every = 5760L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer Dates", { x <- structure(-3L:3L, class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "minute", every = 2880L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "minute", every = 4320L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "minute", every = 5760L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") expect_equal(warp_distance(x, period = "minute", every = 2880L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "minute", every = 4320L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "minute", every = 5760L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "minute", every = 2880L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "minute", every = 4320L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "minute", every = 5760L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can ignore fractional pieces in Dates", { # "1970-01-01 00:07:12 UTC" # structure(.005 * 86400, tzone = "UTC", class = c("POSIXct", "POSIXt")) x <- structure(.005, class = "Date") # "1969-12-31 23:52:48 UTC" # structure(-.005 * 86400, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.005, class = "Date") expect_identical(warp_distance(x, period = "minute"), 0) expect_identical(warp_distance(y, period = "minute"), 0) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_equal(warp_distance(x, period = "minute"), numeric()) expect_equal(warp_distance(x, period = "minute", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_equal(warp_distance(x, period = "minute"), numeric()) expect_equal(warp_distance(x, period = "minute", every = 2), numeric()) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "minute") test_that("can warp_distance() by minute with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "minute"), 0) x <- as.POSIXct("1970-01-02", tz = "UTC") expect_identical(warp_distance(x, "minute"), 1440) x <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "minute"), 60 * 24 * 365) }) # In terms of inclusion/exclusion, we define the cutoffs like: # [1969-12-30 00:00:00 -> 1969-12-31 00:00:00) = -2880 minutes from epoch # [1969-12-31 00:00:00 -> 1970-01-01 00:00:00) = -1440 minutes from epoch # [1970-01-01 00:00:00 -> 1970-01-02 00:00:00) = 0 minutes from epoch # [1970-01-02 00:00:00 -> 1970-01-03 00:00:00) = 1440 minutes from epoch test_that("can warp_distance() by minute with 'negative' POSIXct", { x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute"), -2880) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "minute"), -1441) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute"), -1440) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "minute"), -1) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute"), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "minute"), 1439) x <- as.POSIXct("1970-01-02 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute"), 1440) x <- as.POSIXct("1969-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute"), -(60 * 24 * 365)) }) test_that("can warp_distance() by minute with 'negative' POSIXct and different UTC origins", { origin <- as.POSIXct("1969-12-31", tz = "UTC") x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute", origin = origin), -1440) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "minute", origin = origin), -1) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute", origin = origin), 0) x <- as.POSIXct("1969-12-31 01:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute", origin = origin), 60) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "minute", origin = origin), 1439) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "minute", origin = origin), 1440) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "minute", origin = origin), 2880 - 1) }) test_that("can warp_distance() by minute with 'negative' POSIXct and non-UTC origins", { origin <- as.POSIXct("1970-01-01", tz = "America/New_York") x <- as.POSIXct("1969-12-30 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "minute", origin = origin), -2880) x <- as.POSIXct("1969-12-30 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "minute", origin = origin), -1441) x <- as.POSIXct("1969-12-31 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "minute", origin = origin), -1440) x <- as.POSIXct("1969-12-31 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "minute", origin = origin), -1) x <- as.POSIXct("1970-01-01 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "minute", origin = origin), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "minute", origin = origin), 1439) x <- as.POSIXct("1970-01-02 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "minute", origin = origin), 1440) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "minute"), NA) expect_identical(warp_distance(x, "minute"), 525600) expect_identical(warp_distance(x, "minute", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "minute", origin = origin1), NA) expect_identical(warp_distance(x, "minute", origin = origin1), 0) expect_identical(warp_distance(x, "minute", origin = origin2), -525600) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { # America/New_York is 5 hours behind UTC, or 300 minutes x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "minute", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "minute", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971-01-01 04:00:00 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "minute", origin = origin)), 240 # 4 hr * 60 min ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "minute"), -1) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "minute"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "minute"), NA_real_) }) test_that("can handle `every` with default origin - integer POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:57:00", "1969-12-31 23:58:00", "1969-12-31 23:59:00", "1970-01-01 00:00:00", "1970-01-01 00:01:00", "1970-01-01 00:02:00", "1970-01-01 00:03:00" ), tz = "UTC") x <- structure(as.integer(unclass(x)), tzone = "UTC", class = class(x)) expect_equal(warp_distance(x, period = "minute", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "minute", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "minute", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:57:00", "1969-12-31 23:58:00", "1969-12-31 23:59:00", "1970-01-01 00:00:00", "1970-01-01 00:01:00", "1970-01-01 00:02:00", "1970-01-01 00:03:00" ), tz = "UTC") x <- structure(as.integer(unclass(x)), tzone = "UTC", class = class(x)) origin <- as.POSIXct("1970-01-01 00:01:00", tz = "UTC") expect_equal(warp_distance(x, period = "minute", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "minute", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "minute", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:57:00", "1969-12-31 23:58:00", "1969-12-31 23:59:00", "1970-01-01 00:00:00", "1970-01-01 00:01:00", "1970-01-01 00:02:00", "1970-01-01 00:03:00" ), tz = "UTC") expect_equal(warp_distance(x, period = "minute", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "minute", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "minute", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:57:00", "1969-12-31 23:58:00", "1969-12-31 23:59:00", "1970-01-01 00:00:00", "1970-01-01 00:01:00", "1970-01-01 00:02:00", "1970-01-01 00:03:00" ), tz = "UTC") origin <- as.POSIXct("1970-01-01 00:01:00", tz = "UTC") expect_equal(warp_distance(x, period = "minute", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "minute", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "minute", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle fractional seconds before the epoch correctly", { # Base R printing is wrong, because as.POSIXlt() is wrong # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17667 # I don't care what base R prints this as, this is: # "1969-12-31T23:59:59.5" x <- .POSIXct(-0.5, "UTC") # This is # "1969-12-31T22:59:59.5" y <- .POSIXct(-3600.5, "UTC") expect_identical(warp_distance(x, "minute"), -1) expect_identical(warp_distance(y, "minute"), -61) }) test_that("`origin` could have fractional components - integer POSIXct", { origin <- as.POSIXct("1969-12-31 23:59:59.998", "UTC") x <- structure(c(-120L, -60L, 0L, 58L, 59L, 60L), tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "minute", origin = origin), c(-2, -1, 0, 0, 1, 1)) }) test_that("values past microseconds are essentially ignored", { x <- structure(-.000002, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.0000002, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_equal(warp_distance(x, "minute"), -1) expect_equal(warp_distance(y, "minute"), 0) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "minute"), warp_distance(y, period = "minute") ) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "minute") test_that("can warp_distance() by minute with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "minute"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "minute"), 525600) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "second") test_that("can warp_distance() by second with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "second"), 0) x <- as.Date("1970-01-02") expect_identical(warp_distance(x, "second"), 86400) x <- as.Date("1971-01-01") expect_identical(warp_distance(x, "second"), 60 * 60 * 24 * 365) }) test_that("can warp_distance() by second with 'negative' Dates", { x <- as.Date("1969-12-31") expect_identical(warp_distance(x, "second"), -86400) x <- as.Date("1969-12-30") expect_identical(warp_distance(x, "second"), -86400 * 2L) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "second", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { # America/New_York is 5 seconds before UTC x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "second", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "second", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "second"), 0) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, class = "Date") expect_identical(warp_distance(x, "second"), NA_real_) x <- structure(NA_integer_, class = "Date") expect_identical(warp_distance(x, "second"), NA_real_) }) test_that("can handle `every` with default origin - integer Dates", { x <- structure(-3L:3L, class = "Date") expect_equal(warp_distance(x, period = "second", every = 172800), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "second", every = 259200), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "second", every = 345600), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer Dates", { x <- structure(-3L:3L, class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "second", every = 172800, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "second", every = 259200, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "second", every = 345600, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") expect_equal(warp_distance(x, period = "second", every = 172800), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "second", every = 259200), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "second", every = 345600), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "second", every = 172800, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "second", every = 259200, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "second", every = 345600, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can ignore fractional pieces in Dates", { # "1970-01-01 00:07:12 UTC" # structure(.005 * 86400, tzone = "UTC", class = c("POSIXct", "POSIXt")) x <- structure(.005, class = "Date") # "1969-12-31 23:52:48 UTC" # structure(-.005 * 86400, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.005, class = "Date") expect_identical(warp_distance(x, period = "second"), 0) expect_identical(warp_distance(y, period = "second"), 0) }) test_that("can handle second values larger than max int value", { x <- as.Date("2100-01-01") expect_equal(warp_distance(x, "second"), 4102444800) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_equal(warp_distance(x, period = "second"), numeric()) expect_equal(warp_distance(x, period = "second", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_equal(warp_distance(x, period = "second"), numeric()) expect_equal(warp_distance(x, period = "second", every = 2), numeric()) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "second") test_that("can warp_distance() by second with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "second"), 0) x <- as.POSIXct("1970-01-02", tz = "UTC") expect_identical(warp_distance(x, "second"), 86400) x <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "second"), 60 * 60 * 24 * 365) }) # In terms of inclusion/exclusion, we define the cutoffs like: # [1969-12-30 00:00:00 -> 1969-12-31 00:00:00) # [1969-12-31 00:00:00 -> 1970-01-01 00:00:00) # [1970-01-01 00:00:00 -> 1970-01-02 00:00:00) # [1970-01-02 00:00:00 -> 1970-01-03 00:00:00) test_that("can warp_distance() by second with 'negative' POSIXct", { x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "second"), -172800) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "second"), -86401) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "second"), -86400) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "second"), -1) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "second"), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "second"), 86399) x <- as.POSIXct("1970-01-02 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "second"), 86400) x <- as.POSIXct("1969-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "second"), -(60 * 60 * 24 * 365)) }) test_that("can warp_distance() by second with 'negative' POSIXct and different UTC origins", { origin <- as.POSIXct("1969-12-31", tz = "UTC") x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "second", origin = origin), -86400) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "second", origin = origin), -1) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "second", origin = origin), 0) x <- as.POSIXct("1969-12-31 01:00:00", tz = "UTC") expect_identical(warp_distance(x, "second", origin = origin), 3600) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "second", origin = origin), 86399) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "second", origin = origin), 86400) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "second", origin = origin), 172800 - 1) }) test_that("can warp_distance() by second with 'negative' POSIXct and non-UTC origins", { origin <- as.POSIXct("1970-01-01", tz = "America/New_York") x <- as.POSIXct("1969-12-30 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "second", origin = origin), -172800) x <- as.POSIXct("1969-12-30 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "second", origin = origin), -86401) x <- as.POSIXct("1969-12-31 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "second", origin = origin), -86400) x <- as.POSIXct("1969-12-31 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "second", origin = origin), -1) x <- as.POSIXct("1970-01-01 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "second", origin = origin), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "second", origin = origin), 86399) x <- as.POSIXct("1970-01-02 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "second", origin = origin), 86400) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "second"), NA) expect_identical(warp_distance(x, "second"), 31536000) expect_identical(warp_distance(x, "second", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "second", origin = origin1), NA) expect_identical(warp_distance(x, "second", origin = origin1), 0) expect_identical(warp_distance(x, "second", origin = origin2), -31536000) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { # America/New_York is 5 hours behind UTC, or 300 seconds x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "second", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "second", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971-01-01 04:00:00 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "second", origin = origin)), 14400 # 4 hr * 60 min * 60 sec ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "second"), -1) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "second"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "second"), NA_real_) }) test_that("can handle `every` with default origin - integer POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:59:57", "1969-12-31 23:59:58", "1969-12-31 23:59:59", "1970-01-01 00:00:00", "1970-01-01 00:00:01", "1970-01-01 00:00:02", "1970-01-01 00:00:03" ), tz = "UTC") x <- structure(as.integer(unclass(x)), tzone = "UTC", class = class(x)) expect_identical(warp_distance(x, period = "second", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_identical(warp_distance(x, period = "second", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_identical(warp_distance(x, period = "second", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:59:57", "1969-12-31 23:59:58", "1969-12-31 23:59:59", "1970-01-01 00:00:00", "1970-01-01 00:00:01", "1970-01-01 00:00:02", "1970-01-01 00:00:03" ), tz = "UTC") x <- structure(as.integer(unclass(x)), tzone = "UTC", class = class(x)) origin <- as.POSIXct("1970-01-01 00:00:01", tz = "UTC") expect_identical(warp_distance(x, period = "second", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_identical(warp_distance(x, period = "second", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_identical(warp_distance(x, period = "second", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:59:57", "1969-12-31 23:59:58", "1969-12-31 23:59:59", "1970-01-01 00:00:00", "1970-01-01 00:00:01", "1970-01-01 00:00:02", "1970-01-01 00:00:03" ), tz = "UTC") expect_identical(warp_distance(x, period = "second", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_identical(warp_distance(x, period = "second", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_identical(warp_distance(x, period = "second", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:59:57", "1969-12-31 23:59:58", "1969-12-31 23:59:59", "1970-01-01 00:00:00", "1970-01-01 00:00:01", "1970-01-01 00:00:02", "1970-01-01 00:00:03" ), tz = "UTC") origin <- as.POSIXct("1970-01-01 00:00:01", tz = "UTC") expect_equal(warp_distance(x, period = "second", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "second", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "second", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle fractional seconds before the epoch correctly", { # Base R printing is wrong, because as.POSIXlt() is wrong # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17667 # I don't care what base R prints this as, this is: # "1969-12-31T23:59:59.5" x <- .POSIXct(-0.5, "UTC") # This is # "1969-12-31T22:59:59.5" y <- .POSIXct(-3600.5, "UTC") expect_equal(warp_distance(x, "second"), -1) expect_equal(warp_distance(y, "second"), -3601) }) test_that("can handle second values larger than max int value", { x <- as.POSIXct("2100-01-01", "UTC") expect_equal(warp_distance(x, "second"), 4102444800) }) test_that("`origin` could have fractional components (ignore them) - integer POSIXct", { origin <- as.POSIXct("1969-12-31 23:59:59.998", "UTC") x <- structure(c(-2L, -1L, 0L, 1L), tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "second", origin = origin), c(-1, 0, 1, 2)) }) test_that("values past microseconds are essentially ignored", { x <- structure(-.000002, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.0000002, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_equal(warp_distance(x, "second"), -1) expect_equal(warp_distance(y, "second"), 0) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "second"), warp_distance(y, period = "second") ) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "second") test_that("can warp_distance() by second with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "second"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "second"), 31536000) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "millisecond") test_that("can warp_distance() by millisecond with Date", { x <- as.Date("1970-01-01") expect_identical(warp_distance(x, "millisecond"), 0) x <- as.Date("1970-01-02") expect_identical(warp_distance(x, "millisecond"), 86400 * 1000) x <- as.Date("1971-01-01") expect_identical(warp_distance(x, "millisecond"), 60 * 60 * 24 * 365 * 1000) }) test_that("can warp_distance() by millisecond with 'negative' Dates", { x <- as.Date("1969-12-31") expect_identical(warp_distance(x, "millisecond"), -86400 * 1000) x <- as.Date("1969-12-30") expect_identical(warp_distance(x, "millisecond"), -86400 * 2 * 1000) }) test_that("Date + UTC origin does not emit a warning", { x <- as.Date("1971-01-01") origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "millisecond", origin = origin), 0) }) test_that("Date + non-UTC origin converts with a warning", { # America/New_York is 5 milliseconds before UTC x <- as.Date("1971-01-01") x_with_tz <- structure(unclass(x) * 86400, tzone = "America/New_York", class = c("POSIXct", "POSIXt")) origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "millisecond", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "millisecond", origin = origin) ) }) test_that("can use integer Dates", { x <- structure(0L, class = "Date") expect_identical(warp_distance(x, "millisecond"), 0) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, class = "Date") expect_identical(warp_distance(x, "millisecond"), NA_real_) x <- structure(NA_integer_, class = "Date") expect_identical(warp_distance(x, "millisecond"), NA_real_) }) test_that("can handle `every` with default origin - integer Dates", { x <- structure(-3L:3L, class = "Date") expect_equal(warp_distance(x, period = "millisecond", every = 172800 * 1000), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "millisecond", every = 259200 * 1000), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "millisecond", every = 345600 * 1000), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - integer Dates", { x <- structure(-3L:3L, class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "millisecond", every = 172800 * 1000, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "millisecond", every = 259200 * 1000, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "millisecond", every = 345600 * 1000, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle `every` with default origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") expect_equal(warp_distance(x, period = "millisecond", every = 172800 * 1000), c(-2, -1, -1, 0, 0, 1, 1)) expect_equal(warp_distance(x, period = "millisecond", every = 259200 * 1000), c(-1, -1, -1, 0, 0, 0, 1)) expect_equal(warp_distance(x, period = "millisecond", every = 345600 * 1000), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric Dates", { x <- structure(as.numeric(-3:3), class = "Date") origin <- as.Date("1970-01-02") expect_equal(warp_distance(x, period = "millisecond", every = 172800 * 1000, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "millisecond", every = 259200 * 1000, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "millisecond", every = 345600 * 1000, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can ignore fractional pieces in Dates", { # "1970-01-01T00:00:00.432 UTC" # structure(.000005 * 86400, tzone = "UTC", class = c("POSIXct", "POSIXt")) x <- structure(.000005, class = "Date") # "1969-12-31T23:59:59.568 UTC" # structure(-.005 * 86400, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.000005, class = "Date") # "1970-01-02T00:00:00.432 UTC" z <- structure(1.000005, class = "Date") expect_identical(warp_distance(x, period = "millisecond"), 0) expect_identical(warp_distance(y, period = "millisecond"), 0) expect_identical(warp_distance(z, period = "millisecond"), 86400000) }) test_that("can handle millisecond values larger than max int value", { x <- as.Date("2100-01-01") expect_equal(warp_distance(x, "millisecond"), 4102444800 * 1000) }) test_that("size 0 input works - integer Dates", { x <- structure(integer(), class = "Date") expect_equal(warp_distance(x, period = "millisecond"), numeric()) expect_equal(warp_distance(x, period = "millisecond", every = 2), numeric()) }) test_that("size 0 input works - numeric Dates", { x <- structure(numeric(), class = "Date") expect_equal(warp_distance(x, period = "millisecond"), numeric()) expect_equal(warp_distance(x, period = "millisecond", every = 2), numeric()) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "millisecond") test_that("can warp_distance() by millisecond with POSIXct", { x <- as.POSIXct("1970-01-01", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), 0) x <- as.POSIXct("1970-01-02", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), 86400 * 1000) x <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), 60 * 60 * 24 * 365 * 1000) }) # In terms of inclusion/exclusion, we define the cutoffs like: # [1969-12-30 00:00:00 -> 1969-12-31 00:00:00) # [1969-12-31 00:00:00 -> 1970-01-01 00:00:00) # [1970-01-01 00:00:00 -> 1970-01-02 00:00:00) # [1970-01-02 00:00:00 -> 1970-01-03 00:00:00) test_that("can warp_distance() by millisecond with 'negative' POSIXct", { x <- as.POSIXct("1969-12-30 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), -172800 * 1000) x <- as.POSIXct("1969-12-30 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), -86401 * 1000) x <- as.POSIXct("1969-12-31 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), -86400 * 1000) x <- as.POSIXct("1969-12-31 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), -1 * 1000) x <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), 86399 * 1000) x <- as.POSIXct("1970-01-02 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), 86400 * 1000) x <- as.POSIXct("1969-01-01 00:00:00", tz = "UTC") expect_identical(warp_distance(x, "millisecond"), -(60 * 60 * 24 * 365) * 1000) }) test_that("can warp_distance() by millisecond with 'negative' POSIXct and non-UTC origins", { origin <- as.POSIXct("1970-01-01", tz = "America/New_York") x <- as.POSIXct("1969-12-30 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "millisecond", origin = origin), -172800 * 1000) x <- as.POSIXct("1969-12-30 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "millisecond", origin = origin), -86401 * 1000) x <- as.POSIXct("1969-12-31 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "millisecond", origin = origin), -86400 * 1000) x <- as.POSIXct("1969-12-31 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "millisecond", origin = origin), -1 * 1000) x <- as.POSIXct("1970-01-01 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "millisecond", origin = origin), 0) x <- as.POSIXct("1970-01-01 23:59:59", tz = "America/New_York") expect_identical(warp_distance(x, "millisecond", origin = origin), 86399 * 1000) x <- as.POSIXct("1970-01-02 00:00:00", tz = "America/New_York") expect_identical(warp_distance(x, "millisecond", origin = origin), 86400 * 1000) }) test_that("UTC POSIXct + UTC origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") expect_warning(warp_distance(x, "millisecond"), NA) expect_identical(warp_distance(x, "millisecond"), 31536000 * 1000) expect_identical(warp_distance(x, "millisecond", origin = x), 0) }) test_that("UTC POSIXct + Date origin does not emit a warning", { x <- as.POSIXct("1971-01-01", tz = "UTC") origin1 <- as.Date("1971-01-01") origin2 <- as.Date("1972-01-01") expect_warning(warp_distance(x, "millisecond", origin = origin1), NA) expect_identical(warp_distance(x, "millisecond", origin = origin1), 0) expect_identical(warp_distance(x, "millisecond", origin = origin2), -31536000 * 1000) }) test_that("UTC POSIXct + non-UTC origin converts with a warning", { # America/New_York is 5 hours behind UTC, or 300 milliseconds x <- as.POSIXct("1971-01-01", tz = "UTC") x_with_tz <- structure(x, tzone = "America/New_York") origin <- as.POSIXct("1971-01-01", tz = "America/New_York") expect_identical( expect_warning( warp_distance(x, "millisecond", origin = origin), "`x` [(]UTC[)] and `origin` [(]America/New_York[)]" ), warp_distance(x_with_tz, "millisecond", origin = origin) ) }) test_that("local time POSIXct + UTC origin converts with a warning", { with_envvar(list(TZ = "America/New_York"), { x <- as.POSIXct("1970-12-31 23:00:00") # in UTC this is in 1971-01-01 04:00:00 origin <- as.POSIXct("1971-01-01", tz = "UTC") expect_identical( expect_warning(warp_distance(x, "millisecond", origin = origin)), 14400 * 1000 # 4 hr * 60 min * 60 sec * 1000 milliseconds ) }) }) test_that("can use integer POSIXct", { x <- structure(-1L, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "millisecond"), -1 * 1000) }) test_that("can handle `NA` dates", { x <- structure(NA_real_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "millisecond"), NA_real_) x <- structure(NA_integer_, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "millisecond"), NA_real_) }) test_that("can handle `every` with default origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:59:59.997", "1969-12-31 23:59:59.998", "1969-12-31 23:59:59.999", "1970-01-01 00:00:00.000", "1970-01-01 00:00:00.001", "1970-01-01 00:00:00.002", "1970-01-01 00:00:00.003" ), tz = "UTC") expect_identical(warp_distance(x, period = "millisecond", every = 2L), c(-2, -1, -1, 0, 0, 1, 1)) expect_identical(warp_distance(x, period = "millisecond", every = 3L), c(-1, -1, -1, 0, 0, 0, 1)) expect_identical(warp_distance(x, period = "millisecond", every = 4L), c(-1, -1, -1, 0, 0, 0, 0)) }) test_that("can handle `every` with altered origin - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:59:59.997", "1969-12-31 23:59:59.998", "1969-12-31 23:59:59.999", "1970-01-01 00:00:00.000", "1970-01-01 00:00:00.001", "1970-01-01 00:00:00.002", "1970-01-01 00:00:00.003" ), tz = "UTC") origin <- as.POSIXct("1970-01-01 00:00:00.001", tz = "UTC") expect_equal(warp_distance(x, period = "millisecond", every = 2L, origin = origin), c(-2, -2, -1, -1, 0, 0, 1)) expect_equal(warp_distance(x, period = "millisecond", every = 3L, origin = origin), c(-2, -1, -1, -1, 0, 0, 0)) expect_equal(warp_distance(x, period = "millisecond", every = 4L, origin = origin), c(-1, -1, -1, -1, 0, 0, 0)) }) test_that("can handle fractional pieces with decimilliseconds correctly", { x <- as.POSIXct("1969-12-31 23:59:59.9989", "UTC") expect_identical(warp_distance(x, period = "millisecond"), -2) x <- as.POSIXct("1969-12-31 23:59:59.9995", "UTC") expect_identical(warp_distance(x, period = "millisecond"), -1) x <- as.POSIXct("1969-12-31 23:59:59.9999", "UTC") expect_identical(warp_distance(x, period = "millisecond"), -1) x <- as.POSIXct("1970-01-01 00:00:00.0000", "UTC") expect_identical(warp_distance(x, period = "millisecond"), 0) x <- as.POSIXct("1970-01-01 00:00:00.0009", "UTC") expect_identical(warp_distance(x, period = "millisecond"), 0) x <- as.POSIXct("1970-01-01 00:00:00.0010", "UTC") expect_identical(warp_distance(x, period = "millisecond"), 1) x <- as.POSIXct("1970-01-01 00:00:00.0011", "UTC") expect_identical(warp_distance(x, period = "millisecond"), 1) }) test_that("can handle fractional pieces with centimilliseconds correctly", { # Base R is going to print these wrong, use {nanotime} if you need to # print them correctly x <- as.POSIXct("1969-12-31 23:59:59.99809", "UTC") expect_identical(warp_distance(x, period = "millisecond"), -2) x <- as.POSIXct("1969-12-31 23:59:59.99905", "UTC") expect_identical(warp_distance(x, period = "millisecond"), -1) x <- as.POSIXct("1969-12-31 23:59:59.99909", "UTC") expect_identical(warp_distance(x, period = "millisecond"), -1) x <- as.POSIXct("1970-01-01 00:00:00.00000", "UTC") expect_identical(warp_distance(x, period = "millisecond"), 0) x <- as.POSIXct("1970-01-01 00:00:00.00009", "UTC") expect_identical(warp_distance(x, period = "millisecond"), 0) x <- as.POSIXct("1970-01-01 00:00:00.00100", "UTC") expect_identical(warp_distance(x, period = "millisecond"), 1) x <- as.POSIXct("1970-01-01 00:00:00.00101", "UTC") expect_identical(warp_distance(x, period = "millisecond"), 1) }) test_that("`origin` could have floating point error values that need guarding - numeric POSIXct", { x <- as.POSIXct(c( "1969-12-31 23:59:59.997", "1969-12-31 23:59:59.998", "1969-12-31 23:59:59.999", "1970-01-01 00:00:00.000", "1970-01-01 00:00:00.001", "1970-01-01 00:00:00.002", "1970-01-01 00:00:00.003" ), tz = "UTC") # We know this one can't be represented exactly in floating point origin <- as.POSIXct("1969-12-31 23:59:59.998", "UTC") expect_identical(warp_distance(x, period = "millisecond", every = 1L, origin = origin), c(-1, 0, 1, 2, 3, 4, 5)) expect_identical(warp_distance(x, period = "millisecond", every = 2L, origin = origin), c(-1, 0, 0, 1, 1, 2, 2)) }) test_that("`origin` could have floating point error values that need guarding - integer POSIXct", { # "1970-01-01 00:00:00 UTC" "1969-12-31 23:59:59 UTC" x <- structure(c(0L, -1L), tzone = "UTC", class = c("POSIXct", "POSIXt")) # We know this one can't be represented exactly in floating point origin <- as.POSIXct("1969-12-31 23:59:59.998", "UTC") expect_identical(warp_distance(x, period = "millisecond", every = 1L, origin = origin), c(2, -998)) }) test_that("values past microseconds are essentially ignored", { x <- structure(-.000002, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.0000002, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_equal(warp_distance(x, "millisecond"), -1) expect_equal(warp_distance(y, "millisecond"), 0) x <- structure(-.001002, tzone = "UTC", class = c("POSIXct", "POSIXt")) y <- structure(-.0010002, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_equal(warp_distance(x, "millisecond"), -2) expect_equal(warp_distance(y, "millisecond"), -1) }) test_that("proof that the +1e-7 guard is necessary", { # Found this through trial and error # I was looking for a place where the scaling up then down by 1e6 # produces a value that is represented as being `< x` # Here we get: # 1.000000001327000021935e+09 (start) # *1e6 # 1.000000001327000000000e+15 # trunc # 1.000000001327000000000e+15 # *1e-6 # 1.000000001326999902725e+09 (here is the problem! guard required!) # +1e-7 # 1.000000001327000021935e+09 (no guard: 1.000000001326999902725e+09) # *1e3 # 1.000000001327000000000e+12 (no guard: 1.000000001326999877930e+12) # floor # 1.000000001327000000000e+12 (no guard: 1.000000001326000000000e+12) x <- structure(1000000001.327, tzone = "UTC", class = c("POSIXct", "POSIXt")) expect_identical(warp_distance(x, "millisecond"), 1000000001327) }) test_that("default `origin` results in epoch in the time zone of `x`", { x <- as.POSIXct("1969-12-31 23:00:00", tz = "America/New_York") y <- as.POSIXct("1969-12-31 23:00:00", tz = "UTC") expect_equal( warp_distance(x, period = "millisecond"), warp_distance(y, period = "millisecond") ) }) # ------------------------------------------------------------------------------ # warp_distance(, period = "millisecond") test_that("can warp_distance() by millisecond with POSIXlt", { x <- as.POSIXct("1970-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "millisecond"), 0) x <- as.POSIXct("1971-01-01", tz = "UTC") x <- as.POSIXlt(x) expect_identical(warp_distance(x, "millisecond"), 31536000 * 1000) }) # ------------------------------------------------------------------------------ # warp_distance() misc test_that("`x` is validated", { expect_error(warp_distance(1, period = "year"), "must inherit from") }) test_that("`origin` is validated", { expect_error(warp_distance(new_date(0), period = "year", origin = 1), "must inherit from") expect_error(warp_distance(new_date(0), period = "year", origin = new_date(c(0, 1))), "size 1, not 2") expect_error(warp_distance(new_date(0), period = "year", origin = new_date(NA_real_)), "cannot be `NA`") expect_error(warp_distance(new_date(0), period = "month", origin = new_date(NA_real_)), "cannot be `NA`") }) test_that("`every` is validated", { expect_error(warp_distance(new_date(0), period = "year", every = 0), "greater than 0, not 0") expect_error(warp_distance(new_date(0), period = "year", every = -1), "greater than 0, not -1") expect_error(warp_distance(new_date(0), period = "year", every = structure(1, class = "foobar")), "bare integer-ish") expect_error(warp_distance(new_date(0), period = "year", every = "x"), "integer-ish, not character") expect_error(warp_distance(new_date(0), period = "year", every = c(1, 1)), "size 1, not 2") expect_error(warp_distance(new_date(0), period = "year", every = integer()), "size 1, not 0") expect_error(warp_distance(new_date(0), period = "year", every = NA_integer_), "`every` must not be `NA`") }) test_that("`period` is validated", { expect_error(warp_distance(new_date(0), period = 1), "single string") expect_error(warp_distance(new_date(0), period = c("x", "y")), "single string") expect_error(warp_distance(new_date(0), period = "yr"), "Unknown `period` value 'yr'") }) test_that("optional arguments must be specified by name", { expect_error( warp_distance(new_date(0), "year", 1), "`...` is not empty in `warp_distance[(][)]`." ) }) warp/tests/testthat/helper-with-option.R0000644000176200001440000000172213571627547020131 0ustar liggesusers# withr::with_envvar() with_envvar <- function (new, code) { old <- set_envvar(envs = new) on.exit(set_envvar(old)) force(code) } set_envvar <- function(envs, action = "replace") { if (length(envs) == 0) return() stopifnot(is.named(envs)) stopifnot(is.character(action), length(action) == 1) action <- match.arg(action, c("replace", "prefix", "suffix")) envs <- envs[!duplicated(names(envs), fromLast = TRUE)] old <- Sys.getenv(names(envs), names = TRUE, unset = NA) set <- !is.na(envs) both_set <- set & !is.na(old) if (any(both_set)) { if (action == "prefix") { envs[both_set] <- paste(envs[both_set], old[both_set]) } else if (action == "suffix") { envs[both_set] <- paste(old[both_set], envs[both_set]) } } if (any(set)) do.call("Sys.setenv", as.list(envs[set])) if (any(!set)) Sys.unsetenv(names(envs)[!set]) invisible(old) } is.named <- function (x) { !is.null(names(x)) && all(names(x) != "") } warp/tests/testthat/test-boundaries.R0000644000176200001440000000270413743336661017477 0ustar liggesuserstest_that("warp_boundary() works", { x <- as.Date(c("1969-12-31", "1970-01-02", "1970-01-03", "1970-01-04")) expect <- data.frame(start = c(1, 2, 3), stop = c(1, 2, 4)) expect_equal(warp_boundary(x, "day", every = 2), expect) origin <- as.Date("1970-01-02") expect <- data.frame(start = c(1, 2, 4), stop = c(1, 3, 4)) expect_equal(warp_boundary(x, "day", every = 2, origin = origin), expect) }) test_that("warp_boundary() only allows date like inputs", { expect_error(warp_boundary(1, period = "year"), "must inherit from") }) test_that("the first value is always included as the first `start`", { x <- new_date(c(1, 1, 2, 2)) expect <- data.frame(start = c(1, 3), stop = c(2, 4)) expect_equal(warp_boundary(x, "day"), expect) }) test_that("duplicate non-contiguous values are allowed, and show up in different groups", { x <- new_date(c(1, 2, 1)) expect <- data.frame(start = 1:3, stop = 1:3) expect_equal(warp_boundary(x, "day"), expect) }) test_that("size 0 input works", { expect <- data.frame(start = numeric(), stop = numeric()) expect_equal(warp_boundary(new_date(numeric()), period = "year"), expect) }) test_that("size 1 input works", { expect <- data.frame(start = 1, stop = 1) expect_equal(warp_boundary(new_date(2), period = "year"), expect) }) test_that("optional arguments must be specified by name", { expect_error( warp_boundary(new_date(0), "year", 1), "`...` is not empty in `warp_boundary[(][)]`." ) }) warp/tests/testthat/test-date.R0000644000176200001440000000437713601415540016254 0ustar liggesusers# as.POSIXlt.Date() is unbearably slow, this is much faster as_posixlt_from_date <- function(x) { origin <- structure(0, class = "Date") x <- unclass(x) # Ignore fractional Date pieces by truncating towards 0 if (typeof(x) == "double") { x <- trunc(x) } out <- as.POSIXlt(x * 86400, tz = "UTC", origin = origin) out } test_that("getting the year is identical to as.POSIXlt - integer Date", { x <- structure(-1e7:1e7, class = "Date") expect <- unclass(as_posixlt_from_date(x)) expect <- expect$year - 70L expect_identical(date_get_year_offset(x), expect) }) test_that("getting the year is identical to as.POSIXlt - double Date", { x <- structure(-1e7:1e7 + 0, class = "Date") expect <- unclass(as_posixlt_from_date(x)) expect <- expect$year - 70L expect_identical(date_get_year_offset(x), expect) }) test_that("getting the year month is identical to as.POSIXlt - integer Date", { x <- structure(-1e7:1e7, class = "Date") expect <- unclass(as_posixlt_from_date(x)) expect <- (expect$year - 70L) * 12L + expect$mon expect_identical(date_get_month_offset(x), expect) }) test_that("getting the year month is identical to as.POSIXlt - double Date", { x <- structure(-1e7:1e7 + 0, class = "Date") expect <- unclass(as_posixlt_from_date(x)) expect <- (expect$year - 70L) * 12L + expect$mon expect_identical(date_get_month_offset(x), expect) }) test_that("can get the year offset of the maximum integer value", { x <- structure(.Machine$integer.max, class = "Date") expect <- unclass(as_posixlt_from_date(x)) expect <- expect$year - 70L expect_identical(date_get_year_offset(x), expect) }) test_that("can get the year offset of a value close to the minimum integer value", { minimum_allowed_date <- -.Machine$integer.max + unclass(as.Date("2001-01-01")) x <- structure(minimum_allowed_date, class = "Date") expect <- unclass(as_posixlt_from_date(x)) expect <- expect$year - 70L expect_identical(date_get_year_offset(x), expect) }) test_that("going below the minimum allowed date is an error", { minimum_allowed_date_minus_one <- -.Machine$integer.max + unclass(as.Date("2001-01-01")) - 1L x <- structure(minimum_allowed_date_minus_one, class = "Date") expect_error(date_get_year_offset(x), "Integer overflow") }) warp/tests/testthat.R0000644000176200001440000000060414520264502014350 0ustar liggesusers# This file is part of the standard setup for testthat. # It is recommended that you do not modify it. # # Where should you do additional test configuration? # Learn more about the roles of various files in: # * https://r-pkgs.org/testing-design.html#sec-tests-files-overview # * https://testthat.r-lib.org/articles/special-files.html library(testthat) library(warp) test_check("warp") warp/src/0000755000176200001440000000000014520724062012014 5ustar liggesuserswarp/src/warp.h0000644000176200001440000000201113743334270013134 0ustar liggesusers#ifndef WARP_H #define WARP_H #define R_NO_REMAP #include #include #include #include #include "utils.h" #define PROTECT_N(x, n) (++*n, PROTECT(x)) // Functionality ------------------------------------------------ SEXP warp_distance(SEXP x, enum warp_period_type type, int every, SEXP origin); SEXP warp_change(SEXP x, enum warp_period_type period, int every, SEXP origin, bool last, bool endpoint); SEXP warp_boundary(SEXP x, enum warp_period_type type, int every, SEXP origin); // Compatibility ------------------------------------------------ #if (R_VERSION < R_Version(3, 5, 0)) # define LOGICAL_RO(x) ((const int*) LOGICAL(x)) # define INTEGER_RO(x) ((const int*) INTEGER(x)) # define REAL_RO(x) ((const double*) REAL(x)) # define COMPLEX_RO(x) ((const Rcomplex*) COMPLEX(x)) # define STRING_PTR_RO(x) ((const SEXP*) STRING_PTR(x)) # define RAW_RO(x) ((const Rbyte*) RAW(x)) #endif #endif warp/src/boundary.c0000644000176200001440000000402314302216121013770 0ustar liggesusers#include "warp.h" #include "utils.h" // ----------------------------------------------------------------------------- static SEXP warp_boundary_impl(SEXP stops); // [[ include("warp.h") ]] SEXP warp_boundary(SEXP x, enum warp_period_type type, int every, SEXP origin) { static const bool last = true; static const bool endpoint = false; SEXP stops = PROTECT(warp_change(x, type, every, origin, last, endpoint)); SEXP out = warp_boundary_impl(stops); UNPROTECT(1); return out; } // [[ register() ]] SEXP warp_warp_boundary(SEXP x, SEXP period, SEXP every, SEXP origin) { enum warp_period_type type = as_period_type(period); int every_ = pull_every(every); return warp_boundary(x, type, every_, origin); } // ----------------------------------------------------------------------------- static SEXP new_boundary_df(R_len_t size); static SEXP compute_starts(SEXP x, R_xlen_t size); static SEXP warp_boundary_impl(SEXP stops) { R_xlen_t size = Rf_xlength(stops); SEXP out = PROTECT(new_boundary_df(size)); SET_VECTOR_ELT(out, 0, compute_starts(stops, size)); SET_VECTOR_ELT(out, 1, stops); UNPROTECT(1); return out; } static SEXP compute_starts(SEXP x, R_xlen_t size) { if (size == 0) { return Rf_allocVector(REALSXP, 0); } if (size == 1) { return Rf_ScalarReal(1); } double* p_x = REAL(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); p_out[0] = 1; for (R_xlen_t i = 1; i < size; ++i) { p_out[i] = p_x[i - 1] + 1; } UNPROTECT(1); return out; } static SEXP new_row_name_info(R_len_t size) { SEXP out = PROTECT(Rf_allocVector(INTSXP, 2)); int* p_out = INTEGER(out); p_out[0] = NA_INTEGER; p_out[1] = -size; UNPROTECT(1); return out; } static SEXP new_boundary_df(R_len_t size) { SEXP out = PROTECT(Rf_allocVector(VECSXP, 2)); Rf_setAttrib(out, R_NamesSymbol, strings_start_stop); Rf_setAttrib(out, R_ClassSymbol, classes_data_frame); Rf_setAttrib(out, R_RowNamesSymbol, new_row_name_info(size)); UNPROTECT(1); return out; } warp/src/coercion.c0000644000176200001440000000670613605446615014002 0ustar liggesusers#include "warp.h" #include "utils.h" // ----------------------------------------------------------------------------- // `as_datetime()` ensures that Dates are converted to POSIXct without changing // the clock time. A UTC time zone is always attached. POSIXlt is converted to // POSIXct by calling `as.POSIXct()` on the R side through // `as_posixct_from_posixlt()`. static SEXP as_datetime_from_date(SEXP x); static SEXP as_datetime_from_posixct(SEXP x); static SEXP as_datetime_from_posixlt(SEXP x); // [[ include("utils.h") ]] SEXP as_datetime(SEXP x) { switch(time_class_type(x)) { case warp_class_date: return as_datetime_from_date(x); case warp_class_posixct: return as_datetime_from_posixct(x); case warp_class_posixlt: return as_datetime_from_posixlt(x); case warp_class_unknown: r_error("as_datetime", "Internal error: Unknown date time class."); } never_reached("as_datetime"); } #define AS_DATETIME_FROM_DATE_LOOP(CTYPE, CONST_DEREF, NA_CHECK) { \ const CTYPE* p_x = CONST_DEREF(x); \ \ for (R_xlen_t i = 0; i < x_size; ++i) { \ const CTYPE elt = p_x[i]; \ \ if (NA_CHECK) { \ p_out[i] = NA_REAL; \ continue; \ } \ \ p_out[i] = p_x[i] * 86400; \ } \ } static SEXP as_datetime_from_date(SEXP x) { R_xlen_t x_size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); switch (TYPEOF(x)) { case INTSXP: AS_DATETIME_FROM_DATE_LOOP(int, INTEGER_RO, elt == NA_INTEGER); break; case REALSXP: AS_DATETIME_FROM_DATE_LOOP(double, REAL_RO, !R_FINITE(elt)); break; default: Rf_errorcall(R_NilValue, "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } SEXP strings_utc = PROTECT(Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(strings_utc, 0, Rf_mkChar("UTC")); Rf_setAttrib(out, Rf_install("tzone"), strings_utc); SEXP classes_posixct = PROTECT(Rf_allocVector(STRSXP, 2)); SET_STRING_ELT(classes_posixct, 0, Rf_mkChar("POSIXct")); SET_STRING_ELT(classes_posixct, 1, Rf_mkChar("POSIXt")); Rf_setAttrib(out, R_ClassSymbol, classes_posixct); UNPROTECT(3); return out; } #undef AS_DATETIME_FROM_DATE_LOOP // Convert integer POSIXct (if they ever happen) to double static SEXP as_datetime_from_posixct(SEXP x) { SEXPTYPE type = TYPEOF(x); if (type == REALSXP) { return x; } if (type != INTSXP) { Rf_errorcall(R_NilValue, "A 'POSIXct' can only be an integer or double."); } R_xlen_t x_size = Rf_xlength(x); const int* p_x = INTEGER_RO(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); for (R_xlen_t i = 0; i < x_size; ++i) { int elt = p_x[i]; if (elt == NA_INTEGER) { p_out[i] = NA_REAL; } else { p_out[i] = (double) elt; } } SET_ATTRIB(out, ATTRIB(x)); UNPROTECT(1); return out; } static SEXP as_datetime_from_posixlt(SEXP x) { return as_posixct_from_posixlt(x); } warp/src/timezone.c0000644000176200001440000000744713607330163014026 0ustar liggesusers#include "warp.h" #include "utils.h" // ----------------------------------------------------------------------------- static const char* datetime_get_time_zone(SEXP x); const char* get_time_zone(SEXP x) { switch(time_class_type(x)) { case warp_class_date: return "UTC"; case warp_class_posixct: case warp_class_posixlt: return datetime_get_time_zone(x); default: r_error("get_time_zone", "Internal error: Unknown date time class."); } } static const char* datetime_get_time_zone(SEXP x) { SEXP tzone = Rf_getAttrib(x, syms_tzone); // Local time if (tzone == R_NilValue) { return ""; } if (TYPEOF(tzone) != STRSXP) { r_error( "datetime_get_time_zone", "`tzone` attribute must be a character vector, or `NULL`." ); } // Always grab the first element of the character vector. // For POSIXct it should always be length 1 // For POSIXlt it can be length 1 (UTC) or length 3 (America/New_York, EST, EDT) // but we always want the first value. const char* time_zone = CHAR(STRING_ELT(tzone, 0)); return time_zone; } const char* get_printable_time_zone(const char* time_zone) { if (strlen(time_zone) == 0) { return "local"; } return time_zone; } // ----------------------------------------------------------------------------- static SEXP make_tzone(const char* time_zone); SEXP get_origin_epoch_in_time_zone(SEXP x) { const char* time_zone = get_time_zone(x); // Continue using `NULL` if `x` is UTC, no origin adjustment required if (str_equal(time_zone, "UTC") || str_equal(time_zone, "GMT")) { return R_NilValue; } SEXP dummy = PROTECT(Rf_ScalarReal(0)); Rf_setAttrib(dummy, syms_tzone, make_tzone(time_zone)); Rf_setAttrib(dummy, syms_class, classes_posixct); dummy = PROTECT(as_posixlt_from_posixct(dummy)); // gmtoff is optional, it may not be there. In those cases assume UTC. if (Rf_length(dummy) != 11) { UNPROTECT(2); return R_NilValue; } SEXP offset_sexp = VECTOR_ELT(dummy, 10); int offset = INTEGER(offset_sexp)[0]; // Documented as "unknown", assume UTC. if (offset == NA_INTEGER || offset == 0) { UNPROTECT(2); return R_NilValue; } double epoch_seconds = offset * -1.0; SEXP out = PROTECT(Rf_ScalarReal(epoch_seconds)); Rf_setAttrib(out, syms_tzone, make_tzone(time_zone)); Rf_setAttrib(out, syms_class, classes_posixct); UNPROTECT(3); return out; } static SEXP make_tzone(const char* time_zone) { SEXP out = PROTECT(Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(out, 0, Rf_mkChar(time_zone)); UNPROTECT(1); return out; } // ----------------------------------------------------------------------------- // Converts `x` to a POSIXct with the correct time zone if required // - Does nothing if `x` is a Date and time_zone is UTC // - Converts Dates to POSIXct if local time is requested // [[ include("utils.h") ]] SEXP convert_time_zone(SEXP x, SEXP origin) { const char* x_time_zone = get_time_zone(x); const char* origin_time_zone = get_time_zone(origin); if (str_equal(x_time_zone, origin_time_zone)) { return(x); } Rf_warningcall( R_NilValue, "`x` (%s) and `origin` (%s) do not have the same time zone. " "Converting `x` to the time zone of `origin`. " "It is highly advised to provide `x` and `origin` with the same time zone.", get_printable_time_zone(x_time_zone), get_printable_time_zone(origin_time_zone) ); SEXP out = PROTECT(as_datetime(x)); out = PROTECT(r_maybe_duplicate(out)); // Set to NULL for local time if (strlen(origin_time_zone) == 0) { Rf_setAttrib(out, syms_tzone, R_NilValue); UNPROTECT(2); return(out); } SEXP strings_tzone = PROTECT(Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(strings_tzone, 0, Rf_mkChar(origin_time_zone)); Rf_setAttrib(out, syms_tzone, strings_tzone); UNPROTECT(3); return out; } warp/src/date.c0000644000176200001440000002721213605240257013103 0ustar liggesusers#include "utils.h" #include "divmod.h" /* * This file implements a VERY fast getter for year and year-month offsets for * a Date object. It does not go through POSIXlt, and uses an algorithm from * Python's datetime library for the computation of the year and month * components. It is both much faster and highly memory efficient. */ // ----------------------------------------------------------------------------- static SEXP int_date_get_year_offset(SEXP x); static SEXP dbl_date_get_year_offset(SEXP x); // [[ include("utils.h") ]] SEXP date_get_year_offset(SEXP x) { switch (TYPEOF(x)) { case INTSXP: return int_date_get_year_offset(x); case REALSXP: return dbl_date_get_year_offset(x); default: r_error("date_get_year_offset", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } // [[ register() ]] SEXP warp_date_get_year_offset(SEXP x) { return date_get_year_offset(x); } static SEXP int_date_get_year_offset(SEXP x) { int* p_x = INTEGER(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); int* p_out = INTEGER(out); for (R_xlen_t i = 0; i < size; ++i) { int elt = p_x[i]; if (elt == NA_INTEGER) { p_out[i] = NA_INTEGER; continue; } struct warp_components components = convert_days_to_components(elt); p_out[i] = components.year_offset; } UNPROTECT(1); return out; } static SEXP dbl_date_get_year_offset(SEXP x) { double* p_x = REAL(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); int* p_out = INTEGER(out); for (R_xlen_t i = 0; i < size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_INTEGER; continue; } // Truncate fractional pieces towards 0 int elt = x_elt; struct warp_components components = convert_days_to_components(elt); p_out[i] = components.year_offset; } UNPROTECT(1); return out; } // ----------------------------------------------------------------------------- static SEXP int_date_get_month_offset(SEXP x); static SEXP dbl_date_get_month_offset(SEXP x); // [[ include("utils.h") ]] SEXP date_get_month_offset(SEXP x) { switch (TYPEOF(x)) { case INTSXP: return int_date_get_month_offset(x); case REALSXP: return dbl_date_get_month_offset(x); default: r_error("date_get_month_offset", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } // [[ register() ]] SEXP warp_date_get_month_offset(SEXP x) { return date_get_month_offset(x); } static SEXP int_date_get_month_offset(SEXP x) { int* p_x = INTEGER(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); int* p_out = INTEGER(out); for (R_xlen_t i = 0; i < size; ++i) { int elt = p_x[i]; if (elt == NA_INTEGER) { p_out[i] = NA_INTEGER; continue; } struct warp_components components = convert_days_to_components(elt); p_out[i] = components.year_offset * 12 + components.month; } UNPROTECT(1); return out; } static SEXP dbl_date_get_month_offset(SEXP x) { double* p_x = REAL(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); int* p_out = INTEGER(out); for (R_xlen_t i = 0; i < size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_INTEGER; continue; } // Truncate fractional pieces towards 0 int elt = x_elt; struct warp_components components = convert_days_to_components(elt); p_out[i] = components.year_offset * 12 + components.month; } UNPROTECT(1); return out; } // ----------------------------------------------------------------------------- static struct warp_yday_components int_date_get_origin_yday_components(SEXP origin); static struct warp_yday_components dbl_date_get_origin_yday_components(SEXP origin); // [[ include("utils.h") ]] struct warp_yday_components date_get_origin_yday_components(SEXP origin) { switch (TYPEOF(origin)) { case INTSXP: return int_date_get_origin_yday_components(origin); case REALSXP: return dbl_date_get_origin_yday_components(origin); default: r_error("date_get_origin_yday_components", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(origin))); } } static struct warp_yday_components int_date_get_origin_yday_components(SEXP origin) { int elt = INTEGER(origin)[0]; if (elt == NA_INTEGER) { r_error( "int_date_get_origin_yday_components", "The `origin` cannot be `NA`." ); } struct warp_components components = convert_days_to_components(elt); struct warp_yday_components out; out.year_offset = components.year_offset; out.yday = components.yday; return out; } static struct warp_yday_components dbl_date_get_origin_yday_components(SEXP origin) { double origin_elt = REAL(origin)[0]; if (!R_FINITE(origin_elt)) { r_error( "dbl_date_get_origin_yday_components", "The `origin` must be finite." ); } // Drop fractional part int elt = origin_elt; struct warp_components components = convert_days_to_components(elt); struct warp_yday_components out; out.year_offset = components.year_offset; out.yday = components.yday; return out; } // ----------------------------------------------------------------------------- static struct warp_mday_components int_date_get_origin_mday_components(SEXP origin); static struct warp_mday_components dbl_date_get_origin_mday_components(SEXP origin); // [[ include("utils.h") ]] struct warp_mday_components date_get_origin_mday_components(SEXP origin) { switch (TYPEOF(origin)) { case INTSXP: return int_date_get_origin_mday_components(origin); case REALSXP: return dbl_date_get_origin_mday_components(origin); default: r_error("date_get_origin_mday_components", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(origin))); } } static struct warp_mday_components int_date_get_origin_mday_components(SEXP origin) { int elt = INTEGER(origin)[0]; if (elt == NA_INTEGER) { r_error( "int_date_get_origin_mday_components", "The `origin` cannot be `NA`." ); } struct warp_components components = convert_days_to_components(elt); struct warp_mday_components out; out.year_offset = components.year_offset; out.month = components.month; return out; } static struct warp_mday_components dbl_date_get_origin_mday_components(SEXP origin) { double origin_elt = REAL(origin)[0]; if (!R_FINITE(origin_elt)) { r_error( "dbl_date_get_origin_mday_components", "The `origin` must be finite." ); } // Drop fractional part int elt = origin_elt; struct warp_components components = convert_days_to_components(elt); struct warp_mday_components out; out.year_offset = components.year_offset; out.month = components.month; return out; } // ----------------------------------------------------------------------------- static const int DAYS_IN_MONTH[12] = {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}; static const int DAYS_UP_TO_MONTH[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; #define YEAR_OFFSET_FROM_EPOCH 30 #define MONTH_ADJUSTMENT_TO_0_TO_11_RANGE -1 #define DAY_ADJUSTMENT_TO_0_TO_30_RANGE -1 // unclass(as.Date("2001-01-01")) #define DAYS_FROM_2001_01_01_TO_EPOCH -11323 // -.Machine$integer.max - (DAYS_FROM_2001_01_01_TO_EPOCH) // -.Machine$integer.max == (INT_MIN + 1) #define SMALLEST_POSSIBLE_DAYS_FROM_EPOCH (INT_MIN + 1 - DAYS_FROM_2001_01_01_TO_EPOCH) #define DAYS_IN_1_YEAR_CYCLE 365 // 4 * DAYS_IN_1_YEAR_CYCLE + 1 #define DAYS_IN_4_YEAR_CYCLE 1461 // 25 * DAYS_IN_4_YEAR_CYCLE - 1 #define DAYS_IN_100_YEAR_CYCLE 36524 // 4 * DAYS_IN_100_YEAR_CYCLE + 1 #define DAYS_IN_400_YEAR_CYCLE 146097 // ----------------------------------------------------------------------------- /* * `convert_days_to_components()` * * @param n * A 0-based number of days since 1970-01-01, i.e. unclass(). */ /* * Python's datetime `_ord2ymd()` * https://github.com/python/cpython/blob/b0d4949f1fb04f83691e10a5453d1e10e4598bb9/Lib/datetime.py#L87 * * Many of the comments are copied over from this function. */ /* * The challenging thing about finding the year/month is the presence of leap * years. The leap year pattern repeats exactly every 400 years. We adjust the * date to be the number of days since 2001-01-01 because that is the closest * 400 year boundary to 1970-01-01. This is important because it gives us the * maximum amount of values before hitting any integer overflow. * * The basic strategy is to find the closest 400 year boundary at or _before_ * `n`, and then work with the offset (in number of days) from that boundary to * `n`. It is further divided into 100 / 4 / 1 year cycles, which reduce `n` * down to the "day of the year" in the year of interest. We compute the actual * year from the number of 400 / 100 / 4 / 1 year cycles, with an adjustment if * we are exactly on a 4 or 400 year boundary. Then the rest of the code is * dedicated to finding the month. There is an "educated guess" of * `(n + 50) >> 5` that gets us either exactly right or 1 too far. If we are too * far, we adjust it back by 1 month. */ struct warp_components convert_days_to_components(int n) { struct warp_components components; int n_1_year_cycles; int n_4_year_cycles; int n_100_year_cycles; int n_400_year_cycles; // The smallest possible value of `n` before overflow from // addition of DAYS_FROM_2001_01_01_TO_EPOCH if (n < SMALLEST_POSSIBLE_DAYS_FROM_EPOCH) { r_error( "convert_days_to_components", "Integer overflow! " "The smallest possible value for `n` is %i", SMALLEST_POSSIBLE_DAYS_FROM_EPOCH ); } // Adjust to be days since 2001-01-01 (so `n = 0 == 2001-01-01`) n = DAYS_FROM_2001_01_01_TO_EPOCH + n; divmod(n, DAYS_IN_400_YEAR_CYCLE, &n_400_year_cycles, &n); divmod(n, DAYS_IN_100_YEAR_CYCLE, &n_100_year_cycles, &n); divmod(n, DAYS_IN_4_YEAR_CYCLE, &n_4_year_cycles, &n); divmod(n, DAYS_IN_1_YEAR_CYCLE, &n_1_year_cycles, &n); int year = 1 + n_400_year_cycles * 400 + n_100_year_cycles * 100 + n_4_year_cycles * 4 + n_1_year_cycles; // Edge case adjustment required if we are on the border of a // 4 year or 400 year cycle boundary (i.e. `n = -1L`) if (n_1_year_cycles == 4 || n_100_year_cycles == 4) { components.year_offset = (year - 1) + YEAR_OFFSET_FROM_EPOCH; components.month = 12 + MONTH_ADJUSTMENT_TO_0_TO_11_RANGE; components.day = 31 + DAY_ADJUSTMENT_TO_0_TO_30_RANGE; components.yday = 365; return components; } components.yday = n; bool is_leap_year = (n_1_year_cycles == 3) && (n_4_year_cycles != 24 || n_100_year_cycles == 3); // Gets us either exactly right, or 1 month too far int month = (n + 50) >> 5; // Number of days up to this month, computed using our `month` guess int preceding = DAYS_UP_TO_MONTH[month - 1] + (is_leap_year && month > 2); // If the number of `preceding` days is greater than the `n` yday // position in the year, then we obviously went too far. So subtract 1 // month and recompute the number of days up to the (now correct) month. if (preceding > n) { --month; preceding -= DAYS_IN_MONTH[month - 1] + (is_leap_year && month == 2); } // Substract `position in year` - `days up to current month` = `day in month` // It will be 0-30 based already n -= preceding; components.year_offset = year + YEAR_OFFSET_FROM_EPOCH; components.month = month + MONTH_ADJUSTMENT_TO_0_TO_11_RANGE; components.day = n; return components; } #undef YEAR_OFFSET_FROM_EPOCH #undef MONTH_ADJUSTMENT_TO_0_TO_11_RANGE #undef DAY_ADJUSTMENT_TO_0_TO_30_RANGE #undef DAYS_FROM_2001_01_01_TO_EPOCH #undef SMALLEST_POSSIBLE_DAYS_FROM_EPOCH #undef DAYS_IN_1_YEAR_CYCLE #undef DAYS_IN_4_YEAR_CYCLE #undef DAYS_IN_100_YEAR_CYCLE #undef DAYS_IN_400_YEAR_CYCLE warp/src/init.c0000644000176200001440000000266113743334270013134 0ustar liggesusers#include #include #include // for NULL #include /* .Call calls */ extern SEXP warp_warp_distance(SEXP, SEXP, SEXP, SEXP); extern SEXP warp_warp_change(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP warp_warp_boundary(SEXP, SEXP, SEXP, SEXP); extern SEXP warp_class_type(SEXP); extern SEXP warp_date_get_year_offset(SEXP); extern SEXP warp_date_get_month_offset(SEXP); extern SEXP warp_divmod(SEXP, SEXP); extern SEXP warp_div(SEXP, SEXP); // Defined below SEXP warp_init_library(SEXP); static const R_CallMethodDef CallEntries[] = { {"warp_warp_distance", (DL_FUNC) &warp_warp_distance, 4}, {"warp_warp_change", (DL_FUNC) &warp_warp_change, 6}, {"warp_warp_boundary", (DL_FUNC) &warp_warp_boundary, 4}, {"warp_class_type", (DL_FUNC) &warp_class_type, 1}, {"warp_date_get_year_offset", (DL_FUNC) &warp_date_get_year_offset, 1}, {"warp_date_get_month_offset", (DL_FUNC) &warp_date_get_month_offset, 1}, {"warp_divmod", (DL_FUNC) &warp_divmod, 2}, {"warp_div", (DL_FUNC) &warp_div, 2}, {"warp_init_library", (DL_FUNC) &warp_init_library, 1}, {NULL, NULL, 0} }; void R_init_warp(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } void warp_init_utils(SEXP ns); SEXP warp_init_library(SEXP ns) { warp_init_utils(ns); return R_NilValue; } warp/src/utils.c0000644000176200001440000003014313743334270013325 0ustar liggesusers#include "utils.h" #include "divmod.h" // ----------------------------------------------------------------------------- SEXP warp_ns_env = NULL; SEXP syms_x = NULL; SEXP syms_tzone = NULL; SEXP syms_class = NULL; SEXP syms_as_posixct_from_posixlt = NULL; SEXP syms_as_posixlt_from_posixct = NULL; SEXP syms_as_date = NULL; SEXP fns_as_posixct_from_posixlt = NULL; SEXP fns_as_posixlt_from_posixct = NULL; SEXP fns_as_date = NULL; SEXP classes_data_frame = NULL; SEXP classes_posixct = NULL; SEXP strings_start_stop = NULL; SEXP chars = NULL; SEXP char_posixlt = NULL; SEXP char_posixct = NULL; SEXP char_posixt = NULL; SEXP char_date = NULL; // ----------------------------------------------------------------------------- enum warp_class_type time_class_type(SEXP x); static enum warp_class_type time_class_type_impl(SEXP klass); static const char* class_type_as_str(enum warp_class_type type); // [[ register() ]] SEXP warp_class_type(SEXP x) { return Rf_mkString(class_type_as_str(time_class_type(x))); } enum warp_class_type time_class_type(SEXP x) { if (!OBJECT(x)) { return warp_class_unknown; } SEXP klass = PROTECT(Rf_getAttrib(x, R_ClassSymbol)); enum warp_class_type type = time_class_type_impl(klass); UNPROTECT(1); return type; } static enum warp_class_type time_class_type_impl(SEXP klass) { int n = Rf_length(klass); SEXP const* p_klass = STRING_PTR(klass); p_klass += n - 2; SEXP butlast = *p_klass++; SEXP last = *p_klass++; if (last == char_date) { return warp_class_date; } if (last == char_posixt) { if (butlast == char_posixlt) { return warp_class_posixlt; } else if (butlast == char_posixct) { return warp_class_posixct; } } return warp_class_unknown; } static const char* class_type_as_str(enum warp_class_type type) { switch (type) { case warp_class_date: return "date"; case warp_class_posixct: return "posixct"; case warp_class_posixlt: return "posixlt"; case warp_class_unknown: return "unknown"; } never_reached("class_type_as_str"); } // ----------------------------------------------------------------------------- // TODO - Could be lossy...really should use vctrs? Callable from C? int pull_every(SEXP every) { if (Rf_length(every) != 1) { r_error("pull_every", "`every` must have size 1, not %i", Rf_length(every)); } if (OBJECT(every) != 0) { r_error("pull_every", "`every` must be a bare integer-ish value."); } switch (TYPEOF(every)) { case INTSXP: return INTEGER(every)[0]; case REALSXP: return Rf_asInteger(every); default: r_error("pull_every", "`every` must be integer-ish, not %s", Rf_type2char(TYPEOF(every))); } } // ----------------------------------------------------------------------------- // [[ include("utils.h") ]] bool pull_endpoint(SEXP endpoint) { if (Rf_length(endpoint) != 1) { r_error("pull_endpoint", "`endpoint` must have size 1, not %i", Rf_length(endpoint)); } if (OBJECT(endpoint) != 0) { r_error("pull_endpoint", "`endpoint` must be a bare logical value."); } switch (TYPEOF(endpoint)) { case LGLSXP: return LOGICAL(endpoint)[0]; default: r_error("pull_endpoint", "`endpoint` must be logical, not %s", Rf_type2char(TYPEOF(endpoint))); } } // ----------------------------------------------------------------------------- // [[ include("utils.h") ]] bool pull_last(SEXP last) { if (Rf_length(last) != 1) { r_error("pull_last", "`last` must have size 1, not %i", Rf_length(last)); } if (OBJECT(last) != 0) { r_error("pull_last", "`last` must be a bare logical value."); } switch (TYPEOF(last)) { case LGLSXP: return LOGICAL(last)[0]; default: r_error("pull_last", "`last` must be logical, not %s", Rf_type2char(TYPEOF(last))); } } // ----------------------------------------------------------------------------- #define YEARS_FROM_0001_01_01_TO_EPOCH 1969 #define LEAP_YEARS_FROM_0001_01_01_TO_EPOCH 477 int leap_years_before_and_including_year(int year_offset) { int year = year_offset + YEARS_FROM_0001_01_01_TO_EPOCH; int n_leap_years = int_div(year, 4) - int_div(year, 100) + int_div(year, 400); n_leap_years -= LEAP_YEARS_FROM_0001_01_01_TO_EPOCH; return n_leap_years; } #undef YEARS_FROM_0001_01_01_TO_EPOCH #undef LEAP_YEARS_FROM_0001_01_01_TO_EPOCH // ----------------------------------------------------------------------------- // [[ include("utils.h") ]] bool str_equal(const char* x, const char* y) { return strcmp(x, y) == 0; } // ----------------------------------------------------------------------------- // [[ include("utils.h") ]] enum warp_period_type as_period_type(SEXP period) { if (TYPEOF(period) != STRSXP || Rf_length(period) != 1) { Rf_errorcall(R_NilValue, "`period` must be a single string."); } const char* type = CHAR(STRING_ELT(period, 0)); if (str_equal(type, "year")) { return warp_period_year; } if (str_equal(type, "quarter")) { return warp_period_quarter; } if (str_equal(type, "month")) { return warp_period_month; } if (str_equal(type, "week")) { return warp_period_week; } if (str_equal(type, "yweek")) { return warp_period_yweek; } if (str_equal(type, "mweek")) { return warp_period_mweek; } if (str_equal(type, "day")) { return warp_period_day; } if (str_equal(type, "yday")) { return warp_period_yday; } if (str_equal(type, "mday")) { return warp_period_mday; } if (str_equal(type, "hour")) { return warp_period_hour; } if (str_equal(type, "minute")) { return warp_period_minute; } if (str_equal(type, "second")) { return warp_period_second; } if (str_equal(type, "millisecond")) { return warp_period_millisecond; } Rf_errorcall(R_NilValue, "Unknown `period` value '%s'.", type); } // ----------------------------------------------------------------------------- #define BUFSIZE 8192 // [[ include("utils.h") ]] void __attribute__((noreturn)) r_error(const char* where, const char* why, ...) { char buf[BUFSIZE]; va_list dots; va_start(dots, why); vsnprintf(buf, BUFSIZE, why, dots); va_end(dots); buf[BUFSIZE - 1] = '\0'; Rf_errorcall(R_NilValue, "In C function `%s()`: %s", where, buf); } #undef BUFSIZE // [[ include("utils.h") ]] void __attribute__((noreturn)) never_reached(const char* fn) { r_error("never_reached", "Internal error in `%s()`: Reached the unreachable.", fn); } // ----------------------------------------------------------------------------- static SEXP r_env_get(SEXP env, SEXP sym) { SEXP obj = PROTECT(Rf_findVarInFrame3(env, sym, FALSE)); // Force lazy loaded bindings if (TYPEOF(obj) == PROMSXP) { obj = Rf_eval(obj, R_BaseEnv); } UNPROTECT(1); return obj; } // [[ include("utils.h") ]] SEXP r_maybe_duplicate(SEXP x) { if (MAYBE_REFERENCED(x)) { return Rf_shallow_duplicate(x); } else { return x; } } // ----------------------------------------------------------------------------- #include static void abort_parse(SEXP code, const char* why) { if (Rf_GetOption1(Rf_install("rlang__verbose_errors")) != R_NilValue) { Rf_PrintValue(code); } Rf_error("Internal error: %s", why); } static SEXP r_parse(const char* str) { SEXP str_ = PROTECT(Rf_mkString(str)); ParseStatus status; SEXP out = PROTECT(R_ParseVector(str_, -1, &status, R_NilValue)); if (status != PARSE_OK) { abort_parse(str_, "Parsing failed"); } if (Rf_length(out) != 1) { abort_parse(str_, "Expected a single expression"); } out = VECTOR_ELT(out, 0); UNPROTECT(2); return out; } static SEXP r_parse_eval(const char* str, SEXP env) { SEXP out = Rf_eval(PROTECT(r_parse(str)), env); UNPROTECT(1); return out; } static SEXP new_env_call = NULL; static SEXP new_env__parent_node = NULL; static SEXP new_env__size_node = NULL; static SEXP r_new_environment(SEXP parent, R_len_t size) { parent = parent ? parent : R_EmptyEnv; SETCAR(new_env__parent_node, parent); size = size ? size : 29; SETCAR(new_env__size_node, Rf_ScalarInteger(size)); SEXP env = Rf_eval(new_env_call, R_BaseEnv); // Free for gc SETCAR(new_env__parent_node, R_NilValue); return env; } // ----------------------------------------------------------------------------- /** * Create a call or pairlist * * @param tags Optional. If not `NULL`, a null-terminated array of symbols. * @param cars Mandatory. A null-terminated array of CAR values. * @param fn The first CAR value of the language list. * */ static SEXP r_pairlist(SEXP* tags, SEXP* cars) { if (!cars) { Rf_error("Internal error: Null `cars` in `r_pairlist()`"); } SEXP list = PROTECT(Rf_cons(R_NilValue, R_NilValue)); SEXP node = list; while (*cars) { SEXP next_node = Rf_cons(*cars, R_NilValue); SETCDR(node, next_node); node = next_node; if (tags) { SET_TAG(next_node, *tags); ++tags; } ++cars; } UNPROTECT(1); return CDR(list); } static SEXP r_call(SEXP fn, SEXP* tags, SEXP* cars) { return Rf_lcons(fn, r_pairlist(tags, cars)); } static SEXP warp_eval_mask_n_impl(SEXP fn, SEXP* syms, SEXP* args, SEXP mask) { SEXP call = PROTECT(r_call(fn, syms, syms)); while (*syms) { Rf_defineVar(*syms, *args, mask); ++syms; ++args; } SEXP out = Rf_eval(call, mask); UNPROTECT(1); return out; } SEXP warp_dispatch_n(SEXP fn_sym, SEXP fn, SEXP* syms, SEXP* args) { // Mask `fn` with `fn_sym`. We dispatch in the global environment. SEXP mask = PROTECT(r_new_environment(R_GlobalEnv, 4)); Rf_defineVar(fn_sym, fn, mask); SEXP out = warp_eval_mask_n_impl(fn_sym, syms, args, mask); UNPROTECT(1); return out; } SEXP warp_dispatch1(SEXP fn_sym, SEXP fn, SEXP x_sym, SEXP x) { SEXP syms[2] = { x_sym, NULL }; SEXP args[2] = { x, NULL }; return warp_dispatch_n(fn_sym, fn, syms, args); } // ----------------------------------------------------------------------------- // [[ include("utils.h") ]] SEXP as_posixct_from_posixlt(SEXP x) { return warp_dispatch1( syms_as_posixct_from_posixlt, fns_as_posixct_from_posixlt, syms_x, x ); } // [[ include("utils.h") ]] SEXP as_posixlt_from_posixct(SEXP x) { return warp_dispatch1( syms_as_posixlt_from_posixct, fns_as_posixlt_from_posixct, syms_x, x ); } // [[ include("utils.h") ]] SEXP as_date(SEXP x) { return warp_dispatch1( syms_as_date, fns_as_date, syms_x, x ); } // ----------------------------------------------------------------------------- void warp_init_utils(SEXP ns) { warp_ns_env = ns; syms_x = Rf_install("x"); syms_tzone = Rf_install("tzone"); syms_class = Rf_install("class"); new_env_call = r_parse_eval("as.call(list(new.env, TRUE, NULL, NULL))", R_BaseEnv); R_PreserveObject(new_env_call); new_env__parent_node = CDDR(new_env_call); new_env__size_node = CDR(new_env__parent_node); syms_as_posixct_from_posixlt = Rf_install("as_posixct_from_posixlt"); syms_as_posixlt_from_posixct = Rf_install("as_posixlt_from_posixct"); syms_as_date = Rf_install("as_date"); fns_as_posixct_from_posixlt = r_env_get(warp_ns_env, syms_as_posixct_from_posixlt); fns_as_posixlt_from_posixct = r_env_get(warp_ns_env, syms_as_posixlt_from_posixct); fns_as_date = r_env_get(warp_ns_env, syms_as_date); classes_data_frame = Rf_allocVector(STRSXP, 1); R_PreserveObject(classes_data_frame); SET_STRING_ELT(classes_data_frame, 0, Rf_mkChar("data.frame")); classes_posixct = Rf_allocVector(STRSXP, 2); R_PreserveObject(classes_posixct); SET_STRING_ELT(classes_posixct, 0, Rf_mkChar("POSIXct")); SET_STRING_ELT(classes_posixct, 1, Rf_mkChar("POSIXt")); strings_start_stop = Rf_allocVector(STRSXP, 2); R_PreserveObject(strings_start_stop); SET_STRING_ELT(strings_start_stop, 0, Rf_mkChar("start")); SET_STRING_ELT(strings_start_stop, 1, Rf_mkChar("stop")); // Holds the CHARSXP objects because they can be garbage collected chars = Rf_allocVector(STRSXP, 4); R_PreserveObject(chars); char_posixlt = Rf_mkChar("POSIXlt"); SET_STRING_ELT(chars, 0, char_posixlt); char_posixct = Rf_mkChar("POSIXct"); SET_STRING_ELT(chars, 1, char_posixct); char_posixt = Rf_mkChar("POSIXt"); SET_STRING_ELT(chars, 2, char_posixt); char_date = Rf_mkChar("Date"); SET_STRING_ELT(chars, 3, char_date); } warp/src/distance.c0000644000176200001440000016001213741063210013745 0ustar liggesusers#include "warp.h" #include "utils.h" #include "divmod.h" #include // For int64_t (especially on Windows) // Helpers defined at the bottom of the file static void validate_every(int every); static void validate_origin(SEXP origin); static int origin_to_days_from_epoch(SEXP origin); static int64_t origin_to_seconds_from_epoch(SEXP origin); static int64_t origin_to_milliseconds_from_epoch(SEXP origin); static inline int64_t guarded_floor(double x); static inline int64_t guarded_floor_to_millisecond(double x); // ----------------------------------------------------------------------------- static SEXP warp_distance_year(SEXP x, int every, SEXP origin); static SEXP warp_distance_quarter(SEXP x, int every, SEXP origin); static SEXP warp_distance_month(SEXP x, int every, SEXP origin); static SEXP warp_distance_week(SEXP x, int every, SEXP origin); static SEXP warp_distance_yweek(SEXP x, int every, SEXP origin); static SEXP warp_distance_mweek(SEXP x, int every, SEXP origin); static SEXP warp_distance_day(SEXP x, int every, SEXP origin); static SEXP warp_distance_yday(SEXP x, int every, SEXP origin); static SEXP warp_distance_mday(SEXP x, int every, SEXP origin); static SEXP warp_distance_hour(SEXP x, int every, SEXP origin); static SEXP warp_distance_minute(SEXP x, int every, SEXP origin); static SEXP warp_distance_second(SEXP x, int every, SEXP origin); static SEXP warp_distance_millisecond(SEXP x, int every, SEXP origin); // [[ include("warp.h") ]] SEXP warp_distance(SEXP x, enum warp_period_type type, int every, SEXP origin) { validate_origin(origin); validate_every(every); if (time_class_type(x) == warp_class_unknown) { r_error("warp_distance", "`x` must inherit from 'Date', 'POSIXct', or 'POSIXlt'."); } if (origin == R_NilValue) { origin = PROTECT(get_origin_epoch_in_time_zone(x)); } else { x = PROTECT(convert_time_zone(x, origin)); } SEXP out; switch (type) { case warp_period_year: out = PROTECT(warp_distance_year(x, every, origin)); break; case warp_period_quarter: out = PROTECT(warp_distance_quarter(x, every, origin)); break; case warp_period_month: out = PROTECT(warp_distance_month(x, every, origin)); break; case warp_period_week: out = PROTECT(warp_distance_week(x, every, origin)); break; case warp_period_yweek: out = PROTECT(warp_distance_yweek(x, every, origin)); break; case warp_period_mweek: out = PROTECT(warp_distance_mweek(x, every, origin)); break; case warp_period_day: out = PROTECT(warp_distance_day(x, every, origin)); break; case warp_period_yday: out = PROTECT(warp_distance_yday(x, every, origin)); break; case warp_period_mday: out = PROTECT(warp_distance_mday(x, every, origin)); break; case warp_period_hour: out = PROTECT(warp_distance_hour(x, every, origin)); break; case warp_period_minute: out = PROTECT(warp_distance_minute(x, every, origin)); break; case warp_period_second: out = PROTECT(warp_distance_second(x, every, origin)); break; case warp_period_millisecond: out = PROTECT(warp_distance_millisecond(x, every, origin)); break; default: r_error("warp_distance", "Internal error: unknown `type`."); } UNPROTECT(2); return out; } // [[ register() ]] SEXP warp_warp_distance(SEXP x, SEXP period, SEXP every, SEXP origin) { enum warp_period_type type = as_period_type(period); int every_ = pull_every(every); return warp_distance(x, type, every_, origin); } // ----------------------------------------------------------------------------- static SEXP warp_distance_year(SEXP x, int every, SEXP origin) { int n_prot = 0; bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { SEXP origin_offset_sexp = PROTECT_N(get_year_offset(origin), &n_prot); origin_offset = INTEGER(origin_offset_sexp)[0]; if (origin_offset == NA_INTEGER) { r_error("warp_distance_year", "`origin` cannot be `NA`."); } } bool needs_every = (every != 1); SEXP year = PROTECT_N(get_year_offset(x), &n_prot); int* p_year = INTEGER(year); R_xlen_t n_out = Rf_xlength(year); SEXP out = PROTECT_N(Rf_allocVector(REALSXP, n_out), &n_prot); double* p_out = REAL(out); for (R_xlen_t i = 0; i < n_out; ++i) { int elt = p_year[i]; if (elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } if (needs_offset) { elt -= origin_offset; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { p_out[i] = (elt - (every - 1)) / every; } else { p_out[i] = elt / every; } } UNPROTECT(n_prot); return out; } // ----------------------------------------------------------------------------- static SEXP warp_distance_quarter(SEXP x, int every, SEXP origin) { return warp_distance_month(x, every * 3, origin); } // ----------------------------------------------------------------------------- static SEXP warp_distance_month(SEXP x, int every, SEXP origin) { int n_prot = 0; bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { SEXP origin_offset_sexp = PROTECT_N(get_month_offset(origin), &n_prot); origin_offset = INTEGER(origin_offset_sexp)[0]; if (origin_offset == NA_INTEGER) { r_error("warp_distance_month", "`origin` cannot be `NA`."); } } bool needs_every = (every != 1); SEXP month = PROTECT_N(get_month_offset(x), &n_prot); const int* p_month = INTEGER_RO(month); R_xlen_t size = Rf_xlength(month); SEXP out = PROTECT_N(Rf_allocVector(REALSXP, size), &n_prot); double* p_out = REAL(out); for (R_xlen_t i = 0; i < size; ++i) { int elt = p_month[i]; if (elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } if (needs_offset) { elt -= origin_offset; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(n_prot); return out; } // ----------------------------------------------------------------------------- static SEXP warp_distance_week(SEXP x, int every, SEXP origin) { return warp_distance_day(x, every * 7, origin); } // ----------------------------------------------------------------------------- static SEXP warp_distance_yweek(SEXP x, int every, SEXP origin) { if (every > 52) { r_error( "warp_distance_yweek", "The maximum allowed value of `every` for `period = 'yweek'` is 52." ); } return warp_distance_yday(x, every * 7, origin); } // ----------------------------------------------------------------------------- static SEXP warp_distance_mweek(SEXP x, int every, SEXP origin) { if (every > 4) { r_error( "warp_distance_mweek", "The maximum allowed value of `every` for `period = 'mweek'` is 4." ); } return warp_distance_mday(x, every * 7, origin); } // ----------------------------------------------------------------------------- static SEXP warp_distance_day(SEXP x, int every, SEXP origin) { int n_prot = 0; bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { SEXP origin_offset_sexp = PROTECT_N(get_day_offset(origin), &n_prot); origin_offset = INTEGER(origin_offset_sexp)[0]; if (origin_offset == NA_INTEGER) { r_error("warp_distance_day", "`origin` cannot be `NA`."); } } bool needs_every = (every != 1); SEXP day = PROTECT_N(get_day_offset(x), &n_prot); const int* p_day = INTEGER_RO(day); R_xlen_t size = Rf_xlength(day); SEXP out = PROTECT_N(Rf_allocVector(REALSXP, size), &n_prot); double* p_out = REAL(out); for (R_xlen_t i = 0; i < size; ++i) { int elt = p_day[i]; if (elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } if (needs_offset) { elt -= origin_offset; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(n_prot); return out; } // ----------------------------------------------------------------------------- static SEXP date_warp_distance_yday(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_yday(SEXP x, int every, SEXP origin); static SEXP posixlt_warp_distance_yday(SEXP x, int every, SEXP origin); static SEXP warp_distance_yday(SEXP x, int every, SEXP origin) { if (every > 364) { r_error( "warp_distance_yday", "The maximum allowed value of `every` for `period = 'yday'` is 364." ); } switch (time_class_type(x)) { case warp_class_date: return date_warp_distance_yday(x, every, origin); case warp_class_posixct: return posixct_warp_distance_yday(x, every, origin); case warp_class_posixlt: return posixlt_warp_distance_yday(x, every, origin); default: r_error("warp_distance_yday", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_date_warp_distance_yday(SEXP x, int every, SEXP origin); static SEXP dbl_date_warp_distance_yday(SEXP x, int every, SEXP origin); static SEXP date_warp_distance_yday(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_date_warp_distance_yday(x, every, origin); case REALSXP: return dbl_date_warp_distance_yday(x, every, origin); default: r_error("date_warp_distance_yday", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP posixct_warp_distance_yday(SEXP x, int every, SEXP origin) { x = PROTECT(as_posixlt_from_posixct(x)); SEXP out = posixlt_warp_distance_yday(x, every, origin); UNPROTECT(1); return out; } #define DAYS_IN_YEAR 365 #define DAYS_IN_LEAP_YEAR 366 #define is_leap_year(year) ((((year) % 4) == 0 && ((year) % 100) != 0) || ((year) % 400) == 0) static int compute_yday_distance(int days_since_epoch, int year_offset, int yday, int origin_year_offset, int origin_yday, int origin_leap, int units_in_leap_year, int units_in_non_leap_year, int leap_years_before_and_including_origin_year, int every); static inline int days_before_year(int year_offset); static SEXP posixlt_warp_distance_yday(SEXP x, int every, SEXP origin) { SEXP year = VECTOR_ELT(x, 5); SEXP yday = VECTOR_ELT(x, 7); if (TYPEOF(year) != INTSXP) { r_error( "posixlt_warp_distance_yday", "Internal error: The 6th element of the POSIXlt object should be an integer." ); } if (TYPEOF(yday) != INTSXP) { r_error( "posixlt_warp_distance_yday", "Internal error: The 8th element of the POSIXlt object should be an integer." ); } int* p_year = INTEGER(year); int* p_yday = INTEGER(yday); R_xlen_t size = Rf_xlength(year); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); int units_in_non_leap_year = (DAYS_IN_YEAR - 1) / every + 1; int units_in_leap_year = (DAYS_IN_LEAP_YEAR - 1) / every + 1; struct warp_yday_components origin_components = get_origin_yday_components(origin); int origin_year_offset = origin_components.year_offset; int origin_yday = origin_components.yday; bool origin_leap = is_leap_year(origin_year_offset + 1970); int leap_years_before_and_including_origin_year = leap_years_before_and_including_year(origin_year_offset); for (R_xlen_t i = 0; i < size; ++i) { if (p_year[i] == NA_INTEGER) { p_out[i] = NA_REAL; continue; } int year_offset = p_year[i] - 70; int yday = p_yday[i]; int days_since_epoch = days_before_year(year_offset) + yday; p_out[i] = compute_yday_distance( days_since_epoch, year_offset, yday, origin_year_offset, origin_yday, origin_leap, units_in_leap_year, units_in_non_leap_year, leap_years_before_and_including_origin_year, every ); } UNPROTECT(1); return out; } static SEXP int_date_warp_distance_yday(SEXP x, int every, SEXP origin) { int* p_x = INTEGER(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); int units_in_non_leap_year = (DAYS_IN_YEAR - 1) / every + 1; int units_in_leap_year = (DAYS_IN_LEAP_YEAR - 1) / every + 1; struct warp_yday_components origin_components = get_origin_yday_components(origin); int origin_year_offset = origin_components.year_offset; int origin_yday = origin_components.yday; bool origin_leap = is_leap_year(origin_year_offset + 1970); int leap_years_before_and_including_origin_year = leap_years_before_and_including_year(origin_year_offset); for (R_xlen_t i = 0; i < size; ++i) { int elt = p_x[i]; if (elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } struct warp_components components = convert_days_to_components(elt); p_out[i] = compute_yday_distance( elt, components.year_offset, components.yday, origin_year_offset, origin_yday, origin_leap, units_in_leap_year, units_in_non_leap_year, leap_years_before_and_including_origin_year, every ); } UNPROTECT(1); return out; } static SEXP dbl_date_warp_distance_yday(SEXP x, int every, SEXP origin) { double* p_x = REAL(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); int units_in_non_leap_year = (DAYS_IN_YEAR - 1) / every + 1; int units_in_leap_year = (DAYS_IN_LEAP_YEAR - 1) / every + 1; struct warp_yday_components origin_components = get_origin_yday_components(origin); int origin_year_offset = origin_components.year_offset; int origin_yday = origin_components.yday; bool origin_leap = is_leap_year(origin_year_offset + 1970); int leap_years_before_and_including_origin_year = leap_years_before_and_including_year(origin_year_offset); for (R_xlen_t i = 0; i < size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } // Truncate fractional pieces towards 0 int elt = x_elt; struct warp_components components = convert_days_to_components(elt); p_out[i] = compute_yday_distance( elt, components.year_offset, components.yday, origin_year_offset, origin_yday, origin_leap, units_in_leap_year, units_in_non_leap_year, leap_years_before_and_including_origin_year, every ); } UNPROTECT(1); return out; } #undef DAYS_IN_YEAR #undef DAYS_IN_LEAP_YEAR static inline int yday_leap_adjustment(int year_offset, int yday, bool origin_leap); static int compute_yday_distance(int days_since_epoch, int year_offset, int yday, int origin_year_offset, int origin_yday, int origin_leap, int units_in_leap_year, int units_in_non_leap_year, int leap_years_before_and_including_origin_year, int every) { int origin_yday_adjusted = origin_yday + yday_leap_adjustment(year_offset, yday, origin_leap); int last_origin_year_offset = year_offset; if (yday < origin_yday_adjusted) { --last_origin_year_offset; } int last_origin = days_before_year(last_origin_year_offset) + origin_yday + yday_leap_adjustment(last_origin_year_offset, origin_yday, origin_leap); int days_since_last_origin = days_since_epoch - last_origin; int units_in_year = int_div(days_since_last_origin, every); int years_between_origins = last_origin_year_offset - origin_year_offset; int leap_years_between_origins = leap_years_before_and_including_year(last_origin_year_offset) - leap_years_before_and_including_origin_year; int non_leap_years_between_origins = years_between_origins - leap_years_between_origins; int units_between_origins = units_in_leap_year * leap_years_between_origins + units_in_non_leap_year * non_leap_years_between_origins; int out = units_between_origins + units_in_year; return out; } // Returns the number of days between 1970-01-01 and the beginning of the `year` // defined as the number of `year_offset` from 1970, 0-based #define YEARS_FROM_0001_01_01_TO_EPOCH 1969 #define DAYS_FROM_0001_01_01_TO_EPOCH 719162 static inline int days_before_year(int year_offset) { int year = year_offset + YEARS_FROM_0001_01_01_TO_EPOCH; int days = year * 365 + int_div(year, 4) - int_div(year, 100) + int_div(year, 400); days -= DAYS_FROM_0001_01_01_TO_EPOCH; return days; } #undef YEARS_FROM_0001_01_01_TO_EPOCH #undef DAYS_FROM_0001_01_01_TO_EPOCH static inline int yday_leap_adjustment(int year_offset, int yday, bool origin_leap) { // No adjustment to make if before or equal to Feb 28th if (yday < 58) { return 0; } int year = year_offset + 1970; bool year_is_leap = is_leap_year(year); if (origin_leap) { if (year_is_leap) { return 0; } else { return -1; } } else { if (year_is_leap) { return 1; } else { return 0; } } } #undef is_leap_year // ----------------------------------------------------------------------------- static SEXP date_warp_distance_mday(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_mday(SEXP x, int every, SEXP origin); static SEXP posixlt_warp_distance_mday(SEXP x, int every, SEXP origin); static SEXP warp_distance_mday(SEXP x, int every, SEXP origin) { if (every > 30) { r_error( "warp_distance_mday", "The maximum allowed value of `every` for `period = 'mday'` is 30." ); } switch (time_class_type(x)) { case warp_class_date: return date_warp_distance_mday(x, every, origin); case warp_class_posixct: return posixct_warp_distance_mday(x, every, origin); case warp_class_posixlt: return posixlt_warp_distance_mday(x, every, origin); default: r_error("warp_distance_mday", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_date_warp_distance_mday(SEXP x, int every, SEXP origin); static SEXP dbl_date_warp_distance_mday(SEXP x, int every, SEXP origin); static SEXP date_warp_distance_mday(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_date_warp_distance_mday(x, every, origin); case REALSXP: return dbl_date_warp_distance_mday(x, every, origin); default: r_error("date_warp_distance_mday", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP posixct_warp_distance_mday(SEXP x, int every, SEXP origin) { x = PROTECT(as_posixlt_from_posixct(x)); SEXP out = posixlt_warp_distance_mday(x, every, origin); UNPROTECT(1); return out; } #define is_leap_year(year) ((((year) % 4) == 0 && ((year) % 100) != 0) || ((year) % 400) == 0) static inline void fill_units_per_month(int* x, int every); static inline void fill_units_per_month_leap(int* x, int every); static inline int units_per_year(int* x); static inline int units_up_to_month(int month, const int* units_in_month, int every); static inline int compute_mday_distance(int day, int month, int year_offset, int origin_year_offset, int units_per_year_leap_year, int units_per_year_non_leap_year, int* units_per_month_leap_year, int* units_per_month_non_leap_year, int units_up_to_origin_month, int leap_years_before_and_including_origin_year, int every); static SEXP posixlt_warp_distance_mday(SEXP x, int every, SEXP origin) { SEXP year = VECTOR_ELT(x, 5); SEXP month = VECTOR_ELT(x, 4); SEXP day = VECTOR_ELT(x, 3); if (TYPEOF(year) != INTSXP) { r_error( "posixlt_warp_distance_mday", "Internal error: The 5th element of the POSIXlt object should be an integer." ); } if (TYPEOF(month) != INTSXP) { r_error( "posixlt_warp_distance_mday", "Internal error: The 4th element of the POSIXlt object should be an integer." ); } if (TYPEOF(day) != INTSXP) { r_error( "posixlt_warp_distance_mday", "Internal error: The 3rd element of the POSIXlt object should be an integer." ); } int* p_year = INTEGER(year); int* p_month = INTEGER(month); int* p_day = INTEGER(day); R_xlen_t size = Rf_xlength(year); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); int units_per_month_non_leap_year[12]; int units_per_month_leap_year[12]; fill_units_per_month(units_per_month_non_leap_year, every); fill_units_per_month_leap(units_per_month_leap_year, every); int units_per_year_non_leap_year = units_per_year(units_per_month_non_leap_year); int units_per_year_leap_year = units_per_year(units_per_month_leap_year); struct warp_mday_components origin_components = get_origin_mday_components(origin); int origin_year_offset = origin_components.year_offset; int origin_year = origin_year_offset + 1970; int origin_month = origin_components.month; int* units_per_month = is_leap_year(origin_year) ? units_per_month_leap_year : units_per_month_non_leap_year; int units_up_to_origin_month = units_up_to_month( origin_month, units_per_month, every ); int leap_years_before_and_including_origin_year = leap_years_before_and_including_year(origin_year_offset); for (R_xlen_t i = 0; i < size; ++i) { int year_offset = p_year[i]; int month = p_month[i]; int day = p_day[i]; if (year_offset == NA_INTEGER) { p_out[i] = NA_REAL; continue; } year_offset -= 70; day -= 1; p_out[i] = compute_mday_distance( day, month, year_offset, origin_year_offset, units_per_year_leap_year, units_per_year_non_leap_year, units_per_month_leap_year, units_per_month_non_leap_year, units_up_to_origin_month, leap_years_before_and_including_origin_year, every ); } UNPROTECT(1); return out; } static SEXP int_date_warp_distance_mday(SEXP x, int every, SEXP origin) { int* p_x = INTEGER(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); int units_per_month_non_leap_year[12]; int units_per_month_leap_year[12]; fill_units_per_month(units_per_month_non_leap_year, every); fill_units_per_month_leap(units_per_month_leap_year, every); int units_per_year_non_leap_year = units_per_year(units_per_month_non_leap_year); int units_per_year_leap_year = units_per_year(units_per_month_leap_year); struct warp_mday_components origin_components = get_origin_mday_components(origin); int origin_year_offset = origin_components.year_offset; int origin_year = origin_year_offset + 1970; int origin_month = origin_components.month; int* units_per_month = is_leap_year(origin_year) ? units_per_month_leap_year : units_per_month_non_leap_year; int units_up_to_origin_month = units_up_to_month( origin_month, units_per_month, every ); int leap_years_before_and_including_origin_year = leap_years_before_and_including_year(origin_year_offset); for (R_xlen_t i = 0; i < size; ++i) { int elt = p_x[i]; if (elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } struct warp_components components = convert_days_to_components(elt); p_out[i] = compute_mday_distance( components.day, components.month, components.year_offset, origin_year_offset, units_per_year_leap_year, units_per_year_non_leap_year, units_per_month_leap_year, units_per_month_non_leap_year, units_up_to_origin_month, leap_years_before_and_including_origin_year, every ); } UNPROTECT(1); return out; } static SEXP dbl_date_warp_distance_mday(SEXP x, int every, SEXP origin) { double* p_x = REAL(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); int units_per_month_non_leap_year[12]; int units_per_month_leap_year[12]; fill_units_per_month(units_per_month_non_leap_year, every); fill_units_per_month_leap(units_per_month_leap_year, every); int units_per_year_non_leap_year = units_per_year(units_per_month_non_leap_year); int units_per_year_leap_year = units_per_year(units_per_month_leap_year); struct warp_mday_components origin_components = get_origin_mday_components(origin); int origin_year_offset = origin_components.year_offset; int origin_year = origin_year_offset + 1970; int origin_month = origin_components.month; int* units_per_month = is_leap_year(origin_year) ? units_per_month_leap_year : units_per_month_non_leap_year; int units_up_to_origin_month = units_up_to_month( origin_month, units_per_month, every ); int leap_years_before_and_including_origin_year = leap_years_before_and_including_year(origin_year_offset); for (R_xlen_t i = 0; i < size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } // Truncate fractional pieces towards 0 int elt = x_elt; struct warp_components components = convert_days_to_components(elt); p_out[i] = compute_mday_distance( components.day, components.month, components.year_offset, origin_year_offset, units_per_year_leap_year, units_per_year_non_leap_year, units_per_month_leap_year, units_per_month_non_leap_year, units_up_to_origin_month, leap_years_before_and_including_origin_year, every ); } UNPROTECT(1); return out; } static inline int compute_mday_distance(int day, int month, int year_offset, int origin_year_offset, int units_per_year_leap_year, int units_per_year_non_leap_year, int* units_per_month_leap_year, int* units_per_month_non_leap_year, int units_up_to_origin_month, int leap_years_before_and_including_origin_year, int every) { int years_between = year_offset - origin_year_offset; int leap_years_between = leap_years_before_and_including_year(year_offset) - leap_years_before_and_including_origin_year; int non_leap_years_between = years_between - leap_years_between; int units_between_years = leap_years_between * units_per_year_leap_year + non_leap_years_between * units_per_year_non_leap_year; int year = year_offset + 1970; bool is_leap = is_leap_year(year); int* units_per_month = is_leap ? units_per_month_leap_year : units_per_month_non_leap_year; int units_up_to_elt_month = units_up_to_month( month, units_per_month, every ); int units_in_month = day / every; int out = units_between_years - units_up_to_origin_month + units_up_to_elt_month + units_in_month; return out; } #undef is_leap_year static const int DAYS_IN_MONTH[12] = {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}; static const int DAYS_IN_MONTH_LEAP[12] = {31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}; static inline void fill_units_per_month(int* x, int every) { for (int i = 0; i < 12; ++i) { x[i] = (DAYS_IN_MONTH[i] - 1) / every + 1; } } static inline void fill_units_per_month_leap(int* x, int every) { for (int i = 0; i < 12; ++i) { x[i] = (DAYS_IN_MONTH_LEAP[i] - 1) / every + 1; } } static inline int units_per_year(int* x) { int out = 0; for (int i = 0; i < 12; ++i) { out += x[i]; } return out; } static inline int units_up_to_month(int month, const int* units_per_month, int every) { int out = 0; for (int i = 0; i < month; ++i) { out += units_per_month[i]; } return out; } // ----------------------------------------------------------------------------- static SEXP date_warp_distance_hour(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_hour(SEXP x, int every, SEXP origin); static SEXP posixlt_warp_distance_hour(SEXP x, int every, SEXP origin); static SEXP warp_distance_hour(SEXP x, int every, SEXP origin) { switch (time_class_type(x)) { case warp_class_date: return date_warp_distance_hour(x, every, origin); case warp_class_posixct: return posixct_warp_distance_hour(x, every, origin); case warp_class_posixlt: return posixlt_warp_distance_hour(x, every, origin); default: r_error("warp_distance_hour", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_date_warp_distance_hour(SEXP x, int every, SEXP origin); static SEXP dbl_date_warp_distance_hour(SEXP x, int every, SEXP origin); static SEXP date_warp_distance_hour(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_date_warp_distance_hour(x, every, origin); case REALSXP: return dbl_date_warp_distance_hour(x, every, origin); default: r_error("date_warp_distance_hour", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_posixct_warp_distance_hour(SEXP x, int every, SEXP origin); static SEXP dbl_posixct_warp_distance_hour(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_hour(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_posixct_warp_distance_hour(x, every, origin); case REALSXP: return dbl_posixct_warp_distance_hour(x, every, origin); default: r_error("posixct_warp_distance_hour", "Unknown `POSIXct` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP posixlt_warp_distance_hour(SEXP x, int every, SEXP origin) { x = PROTECT(as_datetime(x)); SEXP out = PROTECT(posixct_warp_distance_hour(x, every, origin)); UNPROTECT(2); return out; } #define HOURS_IN_DAY 24 static SEXP int_date_warp_distance_hour(SEXP x, int every, SEXP origin) { R_xlen_t size = Rf_xlength(x); int* p_x = INTEGER(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { origin_offset = origin_to_days_from_epoch(origin); } for (R_xlen_t i = 0; i < size; ++i) { int elt = p_x[i]; if (elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } if (needs_offset) { elt -= origin_offset; } elt *= HOURS_IN_DAY; if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } static SEXP dbl_date_warp_distance_hour(SEXP x, int every, SEXP origin) { R_xlen_t size = Rf_xlength(x); double* p_x = REAL(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { origin_offset = origin_to_days_from_epoch(origin); } for (R_xlen_t i = 0; i < size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } // Truncate to completely ignore fractional Date parts int elt = x_elt; if (needs_offset) { elt -= origin_offset; } elt *= HOURS_IN_DAY; if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } #undef HOURS_IN_DAY #define SECONDS_IN_HOUR 3600 static SEXP int_posixct_warp_distance_hour(SEXP x, int every, SEXP origin) { R_xlen_t size = Rf_xlength(x); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int64_t origin_offset; if (needs_offset) { origin_offset = origin_to_seconds_from_epoch(origin); } SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); int* p_x = INTEGER(x); for (R_xlen_t i = 0; i < size; ++i) { int x_elt = p_x[i]; if (x_elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } // Avoid overflow int64_t elt = x_elt; if (needs_offset) { elt -= origin_offset; } if (elt < 0) { elt = (elt - (SECONDS_IN_HOUR - 1)) / SECONDS_IN_HOUR; } else { elt = elt / SECONDS_IN_HOUR; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } static SEXP dbl_posixct_warp_distance_hour(SEXP x, int every, SEXP origin) { R_xlen_t size = Rf_xlength(x); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int64_t origin_offset; if (needs_offset) { origin_offset = origin_to_seconds_from_epoch(origin); } SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); double* p_x = REAL(x); for (R_xlen_t i = 0; i < size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } int64_t elt = guarded_floor(x_elt); if (needs_offset) { elt -= origin_offset; } if (elt < 0) { elt = (elt - (SECONDS_IN_HOUR - 1)) / SECONDS_IN_HOUR; } else { elt = elt / SECONDS_IN_HOUR; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } #undef SECONDS_IN_HOUR // ----------------------------------------------------------------------------- static SEXP date_warp_distance_minute(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_minute(SEXP x, int every, SEXP origin); static SEXP posixlt_warp_distance_minute(SEXP x, int every, SEXP origin); static SEXP warp_distance_minute(SEXP x, int every, SEXP origin) { switch (time_class_type(x)) { case warp_class_date: return date_warp_distance_minute(x, every, origin); case warp_class_posixct: return posixct_warp_distance_minute(x, every, origin); case warp_class_posixlt: return posixlt_warp_distance_minute(x, every, origin); default: r_error("warp_distance_minute", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_date_warp_distance_minute(SEXP x, int every, SEXP origin); static SEXP dbl_date_warp_distance_minute(SEXP x, int every, SEXP origin); static SEXP date_warp_distance_minute(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_date_warp_distance_minute(x, every, origin); case REALSXP: return dbl_date_warp_distance_minute(x, every, origin); default: r_error("date_warp_distance_minute", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_posixct_warp_distance_minute(SEXP x, int every, SEXP origin); static SEXP dbl_posixct_warp_distance_minute(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_minute(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_posixct_warp_distance_minute(x, every, origin); case REALSXP: return dbl_posixct_warp_distance_minute(x, every, origin); default: r_error("posixct_warp_distance_minute", "Unknown `POSIXct` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP posixlt_warp_distance_minute(SEXP x, int every, SEXP origin) { x = PROTECT(as_datetime(x)); SEXP out = PROTECT(posixct_warp_distance_minute(x, every, origin)); UNPROTECT(2); return out; } #define MINUTES_IN_DAY 1440 static SEXP int_date_warp_distance_minute(SEXP x, int every, SEXP origin) { R_xlen_t size = Rf_xlength(x); int* p_x = INTEGER(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { origin_offset = origin_to_days_from_epoch(origin); } for (R_xlen_t i = 0; i < size; ++i) { int elt = p_x[i]; if (elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } if (needs_offset) { elt -= origin_offset; } elt *= MINUTES_IN_DAY; if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } static SEXP dbl_date_warp_distance_minute(SEXP x, int every, SEXP origin) { R_xlen_t size = Rf_xlength(x); double* p_x = REAL(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { origin_offset = origin_to_days_from_epoch(origin); } for (R_xlen_t i = 0; i < size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } // Truncate to completely ignore fractional Date parts int elt = x_elt; if (needs_offset) { elt -= origin_offset; } elt *= MINUTES_IN_DAY; if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } #undef MINUTES_IN_DAY #define SECONDS_IN_MINUTE 60 static SEXP int_posixct_warp_distance_minute(SEXP x, int every, SEXP origin) { R_xlen_t size = Rf_xlength(x); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int64_t origin_offset; if (needs_offset) { origin_offset = origin_to_seconds_from_epoch(origin); } SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); int* p_x = INTEGER(x); for (R_xlen_t i = 0; i < size; ++i) { int x_elt = p_x[i]; if (x_elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } // Avoid overflow int64_t elt = x_elt; if (needs_offset) { elt -= origin_offset; } if (elt < 0) { elt = (elt - (SECONDS_IN_MINUTE - 1)) / SECONDS_IN_MINUTE; } else { elt = elt / SECONDS_IN_MINUTE; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } static SEXP dbl_posixct_warp_distance_minute(SEXP x, int every, SEXP origin) { R_xlen_t size = Rf_xlength(x); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int64_t origin_offset; if (needs_offset) { origin_offset = origin_to_seconds_from_epoch(origin); } SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); double* p_x = REAL(x); for (R_xlen_t i = 0; i < size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } int64_t elt = guarded_floor(x_elt); if (needs_offset) { elt -= origin_offset; } if (elt < 0) { elt = (elt - (SECONDS_IN_MINUTE - 1)) / SECONDS_IN_MINUTE; } else { elt = elt / SECONDS_IN_MINUTE; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } #undef SECONDS_IN_MINUTE // ----------------------------------------------------------------------------- static SEXP date_warp_distance_second(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_second(SEXP x, int every, SEXP origin); static SEXP posixlt_warp_distance_second(SEXP x, int every, SEXP origin); static SEXP warp_distance_second(SEXP x, int every, SEXP origin) { switch (time_class_type(x)) { case warp_class_date: return date_warp_distance_second(x, every, origin); case warp_class_posixct: return posixct_warp_distance_second(x, every, origin); case warp_class_posixlt: return posixlt_warp_distance_second(x, every, origin); default: r_error("warp_distance_second", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_date_warp_distance_second(SEXP x, int every, SEXP origin); static SEXP dbl_date_warp_distance_second(SEXP x, int every, SEXP origin); static SEXP date_warp_distance_second(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_date_warp_distance_second(x, every, origin); case REALSXP: return dbl_date_warp_distance_second(x, every, origin); default: r_error("date_warp_distance_second", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_posixct_warp_distance_second(SEXP x, int every, SEXP origin); static SEXP dbl_posixct_warp_distance_second(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_second(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_posixct_warp_distance_second(x, every, origin); case REALSXP: return dbl_posixct_warp_distance_second(x, every, origin); default: r_error("posixct_warp_distance_second", "Unknown `POSIXct` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP posixlt_warp_distance_second(SEXP x, int every, SEXP origin) { x = PROTECT(as_datetime(x)); SEXP out = PROTECT(posixct_warp_distance_second(x, every, origin)); UNPROTECT(2); return out; } #define SECONDS_IN_DAY 86400 static SEXP int_date_warp_distance_second(SEXP x, int every, SEXP origin) { R_xlen_t x_size = Rf_xlength(x); int* p_x = INTEGER(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { origin_offset = origin_to_days_from_epoch(origin); } for (R_xlen_t i = 0; i < x_size; ++i) { int x_elt = p_x[i]; if (x_elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } // Avoid overflow int64_t elt = x_elt; if (needs_offset) { elt -= origin_offset; } elt *= SECONDS_IN_DAY; if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } static SEXP dbl_date_warp_distance_second(SEXP x, int every, SEXP origin) { R_xlen_t x_size = Rf_xlength(x); double* p_x = REAL(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { origin_offset = origin_to_days_from_epoch(origin); } for (R_xlen_t i = 0; i < x_size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } // Truncate to completely ignore fractional Date parts // `int64_t` to avoid overflow int64_t elt = x_elt; if (needs_offset) { elt -= origin_offset; } elt *= SECONDS_IN_DAY; if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } #undef SECONDS_IN_DAY static SEXP int_posixct_warp_distance_second(SEXP x, int every, SEXP origin) { R_xlen_t x_size = Rf_xlength(x); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int64_t origin_offset; if (needs_offset) { origin_offset = origin_to_seconds_from_epoch(origin); } SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); int* p_x = INTEGER(x); for (R_xlen_t i = 0; i < x_size; ++i) { int x_elt = p_x[i]; if (x_elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } // Avoid overflow int64_t elt = x_elt; if (needs_offset) { elt -= origin_offset; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } static SEXP dbl_posixct_warp_distance_second(SEXP x, int every, SEXP origin) { R_xlen_t x_size = Rf_xlength(x); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int64_t origin_offset; if (needs_offset) { origin_offset = origin_to_seconds_from_epoch(origin); } SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); double* p_x = REAL(x); for (R_xlen_t i = 0; i < x_size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } int64_t elt = guarded_floor(x_elt); if (needs_offset) { elt -= origin_offset; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } // ----------------------------------------------------------------------------- static SEXP date_warp_distance_millisecond(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin); static SEXP posixlt_warp_distance_millisecond(SEXP x, int every, SEXP origin); static SEXP warp_distance_millisecond(SEXP x, int every, SEXP origin) { switch (time_class_type(x)) { case warp_class_date: return date_warp_distance_millisecond(x, every, origin); case warp_class_posixct: return posixct_warp_distance_millisecond(x, every, origin); case warp_class_posixlt: return posixlt_warp_distance_millisecond(x, every, origin); default: r_error("warp_distance_millisecond", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_date_warp_distance_millisecond(SEXP x, int every, SEXP origin); static SEXP dbl_date_warp_distance_millisecond(SEXP x, int every, SEXP origin); static SEXP date_warp_distance_millisecond(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_date_warp_distance_millisecond(x, every, origin); case REALSXP: return dbl_date_warp_distance_millisecond(x, every, origin); default: r_error("date_warp_distance_millisecond", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin); static SEXP dbl_posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin); static SEXP posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin) { switch (TYPEOF(x)) { case INTSXP: return int_posixct_warp_distance_millisecond(x, every, origin); case REALSXP: return dbl_posixct_warp_distance_millisecond(x, every, origin); default: r_error("posixct_warp_distance_millisecond", "Unknown `POSIXct` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP posixlt_warp_distance_millisecond(SEXP x, int every, SEXP origin) { x = PROTECT(as_datetime(x)); SEXP out = PROTECT(posixct_warp_distance_millisecond(x, every, origin)); UNPROTECT(2); return out; } #define MILLISECONDS_IN_DAY 86400000 static SEXP int_date_warp_distance_millisecond(SEXP x, int every, SEXP origin) { R_xlen_t x_size = Rf_xlength(x); int* p_x = INTEGER(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { origin_offset = origin_to_days_from_epoch(origin); } for (R_xlen_t i = 0; i < x_size; ++i) { int x_elt = p_x[i]; if (x_elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } // `int64_t` to avoid overflow int64_t elt = x_elt; if (needs_offset) { elt -= origin_offset; } elt *= MILLISECONDS_IN_DAY; if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } static SEXP dbl_date_warp_distance_millisecond(SEXP x, int every, SEXP origin) { R_xlen_t x_size = Rf_xlength(x); double* p_x = REAL(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int origin_offset; if (needs_offset) { origin_offset = origin_to_days_from_epoch(origin); } for (R_xlen_t i = 0; i < x_size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } // Truncate to completely ignore fractional Date parts // `int64_t` to avoid overflow int64_t elt = x_elt; if (needs_offset) { elt -= origin_offset; } elt *= MILLISECONDS_IN_DAY; if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } #undef MILLISECONDS_IN_DAY #define MILLISECONDS_IN_SECOND 1000 static SEXP int_posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin) { R_xlen_t x_size = Rf_xlength(x); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int64_t origin_offset; if (needs_offset) { origin_offset = origin_to_milliseconds_from_epoch(origin); } SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); int* p_x = INTEGER(x); for (R_xlen_t i = 0; i < x_size; ++i) { int x_elt = p_x[i]; if (x_elt == NA_INTEGER) { p_out[i] = NA_REAL; continue; } // `int64_t` to avoid overflow // Note - Have to do `* MILLISECONDS_IN_SECOND` before the // offset subtraction because the offset is already in milliseconds int64_t elt = x_elt * MILLISECONDS_IN_SECOND; if (needs_offset) { elt -= origin_offset; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } static SEXP dbl_posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin) { R_xlen_t x_size = Rf_xlength(x); bool needs_every = (every != 1); bool needs_offset = (origin != R_NilValue); int64_t origin_offset; if (needs_offset) { origin_offset = origin_to_milliseconds_from_epoch(origin); } SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size)); double* p_out = REAL(out); double* p_x = REAL(x); for (R_xlen_t i = 0; i < x_size; ++i) { double x_elt = p_x[i]; if (!R_FINITE(x_elt)) { p_out[i] = NA_REAL; continue; } int64_t elt = guarded_floor_to_millisecond(x_elt); if (needs_offset) { elt -= origin_offset; } if (!needs_every) { p_out[i] = elt; continue; } if (elt < 0) { elt = (elt - (every - 1)) / every; } else { elt = elt / every; } p_out[i] = elt; } UNPROTECT(1); return out; } #undef MILLISECONDS_IN_SECOND // ----------------------------------------------------------------------------- static void validate_every(int every) { if (every == NA_INTEGER) { r_error("validate_every", "`every` must not be `NA`"); } if (every <= 0) { r_error("validate_every", "`every` must be an integer greater than 0, not %i", every); } } static void validate_origin(SEXP origin) { if (origin == R_NilValue) { return; } R_len_t n_origin = Rf_length(origin); if (n_origin != 1) { r_error("validate_origin", "`origin` must have size 1, not %i.", n_origin); } if (time_class_type(origin) == warp_class_unknown) { r_error("validate_origin", "`origin` must inherit from 'Date', 'POSIXct', or 'POSIXlt'."); } } // `as_date()` will always return a double with no fractional component, // and the double will always fit inside an int static int origin_to_days_from_epoch(SEXP origin) { origin = PROTECT(as_date(origin)); double out = REAL(origin)[0]; if (!R_FINITE(out)) { r_error("origin_to_days_from_epoch", "`origin` must not be `NA`."); } UNPROTECT(1); return (int) out; } static int64_t origin_to_seconds_from_epoch(SEXP origin) { origin = PROTECT(as_datetime(origin)); double origin_value = REAL(origin)[0]; if (!R_FINITE(origin_value)) { r_error("origin_to_seconds_from_epoch", "`origin` must be finite."); } int64_t out = guarded_floor(origin_value); UNPROTECT(1); return out; } static int64_t origin_to_milliseconds_from_epoch(SEXP origin) { origin = PROTECT(as_datetime(origin)); double origin_value = REAL(origin)[0]; if (!R_FINITE(origin_value)) { r_error("origin_to_milliseconds_from_epoch", "`origin` must be finite."); } int64_t out = guarded_floor_to_millisecond(origin_value); UNPROTECT(1); return out; } /* * `double` values are represented with 64 bits: * - 1 sign bit * - 11 exponent bits * - 52 significand bits * * The 52 significand bits are the ones that store the true value, this * corresponds to about ~16 significand digits, with everything after * that being garbage. * * Internally doubles are represented with scientific notation to put them in * the exponent-significand representation. So the following date, which * is represented as a double, really looks like this in scientific notation: * * unclass(as.POSIXct("2011-05-01 17:55:23.123456")) * = * 1304286923.1234560013 * = * 1.3042869231234560013e+09 * ^ 16th digit * * Because only ~16 digits are stable, this is where we draw the line on * assuming that the user might have some valuable information stored here. * This corresponds to microseconds. Sure, we could use * a date that has less digits before the decimal to get more fractional * precision (see below) but most dates are in this form: 10 digits before * the decimal representing whole seconds, meaning 6 stable digits after it. * * The other part of the story is that not all floating point numbers can be * represented exactly in binary. For example: * * unclass(as.POSIXct("1969-12-31 23:59:59.998", "UTC")) * = * -0.002000000000002444267 * * Because of this, `floor()` will give results that (to us) are incorrect if * we were to try and floor to milliseconds. We would first times by 1000 to * get milliseconds of `-2.000000000002444267`, and then `floor()` would give * us -3, not -2 which is the correct group. * * To get around this, we need to guard against this floating point error. The * best way I can come up with is to add a small value before flooring, which * would push us into the -1.9999999 range, which would floor correctly. * * I chose the value of just beyond 1 microsecond because that is generally * where the 17th digit falls for most dates * (10 digits of whole seconds, 5 of stable fractional seconds). This seems to * work well for the millisecond grouping, and we apply it to anywhere that * uses seconds "just in case", but it is hard to come up with tests for them. */ static inline int64_t guarded_floor(double x) { // Scale and trim past microseconds x *= 1e6; x = trunc(x); x *= 1e-6; // Add guard and floor x += 1e-7; x = floor(x); return (int64_t) x; } // The order here is slightly different. We want to convert // seconds to milliseconds while still guarding correctly. // - Scale and trim past microseconds // - Guard while still at the second level to put it on the right decimal // - Now scale to millisecond and floor static inline int64_t guarded_floor_to_millisecond(double x) { // Scale and trim past microseconds x *= 1e6; x = trunc(x); x *= 1e-6; // Add guard, scale to milliseconds, and floor x += 1e-7; x *= 1e3; x = floor(x); return (int64_t) x; } warp/src/utils.h0000644000176200001440000000556613743334270013345 0ustar liggesusers#ifndef WARP_UTILS_H #define WARP_UTILS_H #define R_NO_REMAP #include #include #include #include // ----------------------------------------------------------------------------- enum warp_period_type { warp_period_year, warp_period_quarter, warp_period_month, warp_period_week, warp_period_yweek, warp_period_mweek, warp_period_day, warp_period_yday, warp_period_mday, warp_period_hour, warp_period_minute, warp_period_second, warp_period_millisecond }; enum warp_period_type as_period_type(SEXP period); // ----------------------------------------------------------------------------- enum warp_class_type { warp_class_date, warp_class_posixct, warp_class_posixlt, warp_class_unknown }; enum warp_class_type time_class_type(SEXP x); // ----------------------------------------------------------------------------- /* * @member year_offset * The year offset. The number of years since 1970. * @member month * The month. Mapped to the range of 0-11, where 0 is January. * @member day * The day of month. Mapped to the range of 0-30. * @member yday * The day of the year. Mapped to the range of 0-365. */ struct warp_components { int year_offset; int month; int day; int yday; }; struct warp_components convert_days_to_components(int n); // ----------------------------------------------------------------------------- struct warp_yday_components { int year_offset; int yday; }; struct warp_mday_components { int year_offset; int month; }; // In `get.c` struct warp_yday_components get_origin_yday_components(SEXP origin); struct warp_mday_components get_origin_mday_components(SEXP origin); // In `date.c` struct warp_yday_components date_get_origin_yday_components(SEXP origin); struct warp_mday_components date_get_origin_mday_components(SEXP origin); // ----------------------------------------------------------------------------- int pull_every(SEXP every); bool pull_last(SEXP last); bool pull_endpoint(SEXP endpoint); void __attribute__((noreturn)) never_reached(const char* fn); void __attribute__((noreturn)) r_error(const char* where, const char* why, ...); SEXP r_maybe_duplicate(SEXP x); bool str_equal(const char* x, const char* y); int leap_years_before_and_including_year(int year_offset); SEXP as_posixct_from_posixlt(SEXP x); SEXP as_posixlt_from_posixct(SEXP x); SEXP as_date(SEXP x); // In `get.c` SEXP get_year_offset(SEXP x); SEXP get_month_offset(SEXP x); SEXP get_day_offset(SEXP x); // In `date.c` SEXP date_get_year_offset(SEXP x); SEXP date_get_month_offset(SEXP x); // In `coercion.c` SEXP as_datetime(SEXP x); // In `timezone.c` SEXP get_origin_epoch_in_time_zone(SEXP x); SEXP convert_time_zone(SEXP x, SEXP origin); extern SEXP syms_tzone; extern SEXP syms_class; extern SEXP classes_data_frame; extern SEXP classes_posixct; extern SEXP strings_start_stop; #endif warp/src/get.c0000644000176200001440000002375313605353427012757 0ustar liggesusers#include "warp.h" #include "utils.h" #include "divmod.h" /* * `get_year_offset()` * Extract the number of years offset from 1970. * Returns an integer vector. * * `get_month_offset()` * Extract the number of months offset from 1970. * Return an integer vecctor. * * `get_day_offset()` * Extract the number of days offset from 1970. * Return an integer vector. */ // ----------------------------------------------------------------------------- static SEXP posixct_get_year_offset(SEXP x); static SEXP posixlt_get_year_offset(SEXP x); // [[ "utils.h" ]] SEXP get_year_offset(SEXP x) { switch(time_class_type(x)) { case warp_class_date: return date_get_year_offset(x); case warp_class_posixct: return posixct_get_year_offset(x); case warp_class_posixlt: return posixlt_get_year_offset(x); default: r_error("get_year_offset", "Internal error: Unknown date time class."); } } static SEXP posixct_get_year_offset(SEXP x) { x = PROTECT(as_posixlt_from_posixct(x)); SEXP out = posixlt_get_year_offset(x); UNPROTECT(1); return out; } static SEXP posixlt_get_year_offset(SEXP x) { SEXP out = VECTOR_ELT(x, 5); out = PROTECT(r_maybe_duplicate(out)); if (TYPEOF(out) != INTSXP) { r_error( "posixlt_get_year_offset", "Internal error: The 6th element of the POSIXlt object should be an integer." ); } int* p_out = INTEGER(out); R_xlen_t n = Rf_xlength(out); for (R_xlen_t i = 0; i < n; ++i) { if (p_out[i] == NA_INTEGER) { continue; } p_out[i] -= 70; } UNPROTECT(1); return out; } // ----------------------------------------------------------------------------- static SEXP posixct_get_month_offset(SEXP x); static SEXP posixlt_get_month_offset(SEXP x); // [[ "utils.h" ]] SEXP get_month_offset(SEXP x) { switch(time_class_type(x)) { case warp_class_date: return date_get_month_offset(x); case warp_class_posixct: return posixct_get_month_offset(x); case warp_class_posixlt: return posixlt_get_month_offset(x); default: r_error("get_month_offset", "Internal error: Unknown date time class."); } } static SEXP posixct_get_month_offset(SEXP x) { x = PROTECT(as_posixlt_from_posixct(x)); SEXP out = posixlt_get_month_offset(x); UNPROTECT(1); return out; } #define YEARS_FROM_1900_TO_1970 70 #define MONTHS_IN_YEAR 12 static SEXP posixlt_get_month_offset(SEXP x) { SEXP year = VECTOR_ELT(x, 5); SEXP month = VECTOR_ELT(x, 4); if (TYPEOF(year) != INTSXP) { r_error( "posixlt_get_month_offset", "Internal error: The 6th element of the POSIXlt object should be an integer." ); } if (TYPEOF(month) != INTSXP) { r_error( "posixlt_get_month_offset", "Internal error: The 6th element of the POSIXlt object should be an integer." ); } int* p_year = INTEGER(year); int* p_month = INTEGER(month); R_xlen_t size = Rf_xlength(year); SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); int* p_out = INTEGER(out); for (R_xlen_t i = 0; i < size; ++i) { if (p_year[i] == NA_INTEGER) { p_out[i] = NA_INTEGER; continue; } p_out[i] = (p_year[i] - YEARS_FROM_1900_TO_1970) * MONTHS_IN_YEAR + p_month[i]; } UNPROTECT(1); return out; } #undef YEARS_FROM_1900_TO_1970 #undef MONTHS_IN_YEAR // ----------------------------------------------------------------------------- static SEXP date_get_day_offset(SEXP x); static SEXP posixct_get_day_offset(SEXP x); static SEXP posixlt_get_day_offset(SEXP x); // [[ "utils.h" ]] SEXP get_day_offset(SEXP x) { switch(time_class_type(x)) { case warp_class_date: return date_get_day_offset(x); case warp_class_posixct: return posixct_get_day_offset(x); case warp_class_posixlt: return posixlt_get_day_offset(x); default: r_error("get_day_offset", "Internal error: Unknown date time class."); } } static SEXP int_date_get_day_offset(SEXP x); static SEXP dbl_date_get_day_offset(SEXP x); static SEXP date_get_day_offset(SEXP x) { switch (TYPEOF(x)) { case INTSXP: return int_date_get_day_offset(x); case REALSXP: return dbl_date_get_day_offset(x); default: r_error("date_get_day_offset", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x))); } } static SEXP int_date_get_day_offset(SEXP x) { return x; } static SEXP dbl_date_get_day_offset(SEXP x) { double* p_x = REAL(x); R_xlen_t size = Rf_xlength(x); SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); int* p_out = INTEGER(out); // Truncate any fractional pieces towards 0 for (R_xlen_t i = 0; i < size; ++i) { if (!R_FINITE(p_x[i])) { p_out[i] = NA_INTEGER; continue; } p_out[i] = (int) p_x[i]; } UNPROTECT(1); return out; } static SEXP posixct_get_day_offset(SEXP x) { x = PROTECT(as_posixlt_from_posixct(x)); SEXP out = posixlt_get_day_offset(x); UNPROTECT(1); return out; } static inline int days_before_year(int year); static SEXP posixlt_get_day_offset(SEXP x) { SEXP year = VECTOR_ELT(x, 5); SEXP yday = VECTOR_ELT(x, 7); if (TYPEOF(year) != INTSXP) { r_error( "posixlt_get_day_offset", "Internal error: The 6th element of the POSIXlt object should be an integer." ); } if (TYPEOF(yday) != INTSXP) { r_error( "posixlt_get_day_offset", "Internal error: The 8th element of the POSIXlt object should be an integer." ); } int* p_year = INTEGER(year); int* p_yday = INTEGER(yday); R_xlen_t size = Rf_xlength(year); SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); int* p_out = INTEGER(out); for (R_xlen_t i = 0; i < size; ++i) { if (p_year[i] == NA_INTEGER) { p_out[i] = NA_INTEGER; continue; } p_out[i] = days_before_year(p_year[i]) + p_yday[i]; } UNPROTECT(1); return out; } // Not 1899 because `year` is 0 based already #define YEARS_FROM_0001_01_01_TO_1900 1900 #define DAYS_FROM_0001_01_01_TO_EPOCH 719162 static inline int days_before_year(int year) { year += YEARS_FROM_0001_01_01_TO_1900; year -= 1; int days = year * 365 + int_div(year, 4) - int_div(year, 100) + int_div(year, 400); days -= DAYS_FROM_0001_01_01_TO_EPOCH; return days; } #undef YEARS_FROM_0001_01_01_TO_1900 #undef DAYS_FROM_0001_01_01_TO_EPOCH // ----------------------------------------------------------------------------- static struct warp_yday_components posixct_get_origin_yday_components(SEXP origin); static struct warp_yday_components posixlt_get_origin_yday_components(SEXP origin); // [[ include("utils.h") ]] struct warp_yday_components get_origin_yday_components(SEXP origin) { if (origin == R_NilValue) { struct warp_yday_components out; out.year_offset = 0; out.yday = 0; return out; } switch(time_class_type(origin)) { case warp_class_date: return date_get_origin_yday_components(origin); case warp_class_posixct: return posixct_get_origin_yday_components(origin); case warp_class_posixlt: return posixlt_get_origin_yday_components(origin); default: r_error("get_origin_yday_components", "Internal error: Unknown date time class."); } } static struct warp_yday_components posixct_get_origin_yday_components(SEXP origin) { origin = PROTECT(as_posixlt_from_posixct(origin)); struct warp_yday_components out = posixlt_get_origin_yday_components(origin); UNPROTECT(1); return out; } static struct warp_yday_components posixlt_get_origin_yday_components(SEXP origin) { SEXP origin_year = VECTOR_ELT(origin, 5); SEXP origin_yday = VECTOR_ELT(origin, 7); if (TYPEOF(origin_year) != INTSXP) { r_error( "posixlt_get_origin_yday_components", "Internal error: The 6th element of the POSIXlt object should be an integer." ); } if (TYPEOF(origin_yday) != INTSXP) { r_error( "posixlt_get_origin_yday_components", "Internal error: The 8th element of the POSIXlt object should be an integer." ); } int year = INTEGER(origin_year)[0]; int yday = INTEGER(origin_yday)[0]; if (year == NA_INTEGER || yday == NA_INTEGER) { r_error( "posixlt_get_origin_yday_components", "The `origin` cannot be `NA`." ); } struct warp_yday_components out; out.year_offset = year - 70; out.yday = yday; return out; } // ----------------------------------------------------------------------------- static struct warp_mday_components posixct_get_origin_mday_components(SEXP origin); static struct warp_mday_components posixlt_get_origin_mday_components(SEXP origin); // [[ include("utils.h") ]] struct warp_mday_components get_origin_mday_components(SEXP origin) { if (origin == R_NilValue) { struct warp_mday_components out; out.year_offset = 0; out.month = 0; return out; } switch(time_class_type(origin)) { case warp_class_date: return date_get_origin_mday_components(origin); case warp_class_posixct: return posixct_get_origin_mday_components(origin); case warp_class_posixlt: return posixlt_get_origin_mday_components(origin); default: r_error("get_origin_mday_components", "Internal error: Unknown date time class."); } } static struct warp_mday_components posixct_get_origin_mday_components(SEXP origin) { origin = PROTECT(as_posixlt_from_posixct(origin)); struct warp_mday_components out = posixlt_get_origin_mday_components(origin); UNPROTECT(1); return out; } static struct warp_mday_components posixlt_get_origin_mday_components(SEXP origin) { SEXP origin_year = VECTOR_ELT(origin, 5); SEXP origin_month = VECTOR_ELT(origin, 4); if (TYPEOF(origin_year) != INTSXP) { r_error( "posixlt_get_origin_mday_components", "Internal error: The 6th element of the POSIXlt object should be an integer." ); } if (TYPEOF(origin_month) != INTSXP) { r_error( "posixlt_get_origin_mday_components", "Internal error: The 4th element of the POSIXlt object should be an integer." ); } int year = INTEGER(origin_year)[0]; int month = INTEGER(origin_month)[0]; if (year == NA_INTEGER || month == NA_INTEGER) { r_error( "posixlt_get_origin_mday_components", "The `origin` cannot be `NA`." ); } struct warp_mday_components out; out.year_offset = year - 70; out.month = month; return out; } warp/src/divmod.h0000644000176200001440000000032213601415540013441 0ustar liggesusers#ifndef WARP_DIVMOD_H #define WARP_DIVMOD_H #define R_NO_REMAP #include #include #include void divmod(int x, int y, int* p_quot, int* p_rem); int int_div(int x, int y); #endif warp/src/change.c0000644000176200001440000000615113743334270013414 0ustar liggesusers#include "warp.h" #include "utils.h" // ----------------------------------------------------------------------------- static SEXP warp_change_impl(SEXP x, bool last, bool endpoint); // [[ include("warp.h") ]] SEXP warp_change(SEXP x, enum warp_period_type period, int every, SEXP origin, bool last, bool endpoint) { SEXP distances = PROTECT(warp_distance(x, period, every, origin)); SEXP out = warp_change_impl(distances, last, endpoint); UNPROTECT(1); return out; } // [[ register() ]] SEXP warp_warp_change(SEXP x, SEXP period, SEXP every, SEXP origin, SEXP last, SEXP endpoint) { enum warp_period_type period_ = as_period_type(period); int every_ = pull_every(every); bool last_ = pull_last(last); bool endpoint_ = pull_endpoint(endpoint); return warp_change(x, period_, every_, origin, last_, endpoint_); } // ----------------------------------------------------------------------------- static inline bool dbl_equal(const double current, const double previous); static SEXP warp_change_impl(SEXP x, bool last, bool endpoint) { const R_xlen_t size = Rf_xlength(x); if (size == 0) { return Rf_allocVector(REALSXP, 0); } if (size == 1) { return Rf_ScalarReal(1); } R_xlen_t count = 0; // Maximum size is if all values are unique SEXP out = PROTECT(Rf_allocVector(REALSXP, size)); double* p_out = REAL(out); const double* p_x = REAL(x); if (last) { // If the location of the first changepoint // wasn't the first location in `x`, we need to forcibly add the endpoint if (endpoint && dbl_equal(p_x[0], p_x[1])) { p_out[count] = 1; ++count; } } else { // Always include first value when returning starts p_out[count] = 1; ++count; } const R_xlen_t adjustment = (R_xlen_t) !last; double previous = p_x[0]; for (R_xlen_t i = 1; i < size; ++i) { const double current = p_x[i]; if (dbl_equal(current, previous)) { continue; } const R_xlen_t loc = i + adjustment; p_out[count] = loc; ++count; previous = current; } if (last) { // Always include last value when returning stops p_out[count] = size; ++count; } else { // If the location of the last changepoint // wasn't the last location in `x`, we need to forcibly add the endpoint if (endpoint && dbl_equal(p_x[size - 2], p_x[size - 1])) { p_out[count] = size; ++count; } } out = PROTECT(Rf_xlengthgets(out, count)); UNPROTECT(2); return out; } // Because the values come from `warp_distance()`, we can be confident that // they are doubles, possibly `NA_real_` (but not `NaN` or `Inf`!) // Order of checks // - If `current` is `NA_real_`, check if `previous` is too // - Otherwise just check the values static inline bool dbl_equal(const double current, const double previous) { if (isnan(current)) { if (isnan(previous)) { return true; } else { return false; } } return current == previous; } warp/src/divmod.c0000644000176200001440000001515013601530531013437 0ustar liggesusers#include "divmod.h" // ----------------------------------------------------------------------------- /* * `divmod()` * * `divmod()` is equivalent to `div()`, except in the important case where the * signs of `x` and `y` differ. Using floating point division in these cases * would generate a negative quotient. `divmod()` always rounds this quotient * "down" towards -Inf, rather than towards 0 like `div()` does. The remainder * is then computed from that, and it always works out that it has the same * sign as `y`. * * `divmod()` is useful for the calculations when computing the year/month/day * components. For example, with `n = -5L`, which is 5 days before `2001-01-01`, * for the first computation we would get: * [-1, 146092] = divmod(-5L, DAYS_IN_400_YEAR_CYCLE) * which is telling us that we are somewhere between the 0th and -1st 400 year * cycle. So somewhere between [1601-01-01, 2001-01-01). And we are at the * 146092th day in the cycle. So then we repeat for a 100 year cycle, 4 year * cycle, and 1 year cycle to finally end up with an `n` that tells us the * position in the year. Then we add that all back together to get the correct * year (with the one edge case that we might be at a 4 year or 400 year * boundary, like what `n = -1L` would give). The rest of the computation is * then about finding the month in that year, using an educated guess of * `(n + 50) >> 5` which is either exactly right or one too far. * * In the technical sense, it is defined as: * * - quot = x // y * - rem = x % y * - Where this holds: `(x // y) * y + (x % y) == x` * - Where `(x % y)` has the same sign as `y` * - Integer division of `(x // y)` always "rounds down" towards -Inf, not * towards 0. * * To compute it "by hand" the easiest way is to: * * 1) Compute the quotient as: * `quot = x // y = floor( (double) x, (double) y)` * Where `floor()` always rounds towards -Inf. So `floor(-0.5) = -1`. * 2) Compute the remainder by backsolving the invariant: * `rem = x % y = x - (x // y) * y = x - (quot) * y` * * This is in contrast to `div()` which would use the exact same procedure as * above but would substitute `floor()` for `trunc()`, so `trunc(-0.5) = 0`. * Because the remainder is then computed from that, it would also change. * * @param x * The numerator. * @param y * The denominator. * @param p_quot * A pointer to place the quotient value of the division in. * @param p_rem * A pointer to place the remainder value of the division in. */ /* * Examples of `div()` vs `divmod()` * * divmod: * 1) quot = 1 // 2 = floor(1.0 / 2.0) = floor(0.5) = 0 * 2) rem = 1 % 2 = 1 - (0) * 2 = 1 * * div: * 1) quot = 1 / 2 = trunc(1.0 / 2.0) = trunc(0.5) = 0 * 2) rem = 1 % 2 = 1 - (0) * 2 = 1 * * [0, 1] = divmod(1L, 2L) * [0, 1] = div(1L, 2L) * * divmod: * 1) quot = -1 // 2 = floor(-1.0 / 2.0) = floor(-0.5) = -1 * 2) rem = -1 % 2 = -1 - (-1) * 2 = 1 * * div: * 1) quot = -1 / 2 = trunc(-1.0 / 2.0) = trunc(-0.5) = 0 * 2) rem = -1 % 2 = -1 - (0) * 2 = -1 * * [-1, 1] = divmod(-1L, 2L) * [ 0, -1] = div(-1L, 2L) * * divmod: * 1) quot = 1 // -2 = floor(1.0 / -2.0) = floor(-0.5) = -1 * 2) rem = 1 % -2 = 1 - (-1) * -2 = -1 * * div: * 1) quot = 1 / -2 = trunc(1.0 / -2.0) = trunc(-0.5) = 0 * 2) rem = 1 % -2 = 1 - (0) * -2 = 1 * * [-1, -1] = divmod(1L, -2L) * [ 0, 1] = div(1L, -2L) * * divmod: * 1) quot = -1 // -2 = floor(-1.0 / -2.0) = floor(0.5) = 0 * 2) rem = -1 % -2 = -1 - (0) * -2 = -1 * * div: * 1) quot = -1 / -2 = trunc(-1.0 / -2.0) = trunc(0.5) = 0 * 2) rem = -1 % -2 = -1 - (0) * -2 = -1 * * [0, -1] = divmod(-1L, -2L) * [0, -1] = div(-1L, -2L) */ /* * Python's i_divmod() * http://svn.python.org/projects/python/trunk/Objects/intobject.c * * Implemented after finding this Stack Overflow answer * https://stackoverflow.com/questions/3895081/divide-and-get-remainder-at-the-same-time * * The notes below are all derived from the comments in the Python implementation */ /* * It is possible for `x - quot * y` to overflow on platforms where `x / y` * gives `floor(x / y)` and does not truncate towards 0. This is rare, and C99 * prohibits it, but it is technically possible on C89. One example would be: * x = INT_MIN = -.Machine$integer.max * y = 2L * * If this problematic behavior was in force, it would give: * quot = x / y = floor(-1073741823.5) = -1073741824 * quot * y = -2147483648 > INT_MIN so overflow * * With truncation towards 0 we get: * quot = x / y = trunc(-1073741823.5) = -1073741823 * quot * y = -2147483646 < INT_MIN so no overflow * * I do not expect any issues because R uses C99, but to be safe we cast * `quot` to an unsigned int in the middle to avoid overflow, then cast back * to int after the subtraction. */ /* * If the signs of `x` and `y` are different, and there is a non-0 remainder, * we generally expect that we will need to perform the adjustment to the * remainder and quotient to get the correct `divmod()` results. * * However, as mentioned above, C89 does not define whether `x / y` gives the * `floor(x / y)` or `trunc(x / y)`. If it happens to return the non-standard * result of `floor(x / y)`, then we don't need to perform the adjustment * because the result will already be correct. Because of this, we can't check * the sign of `x` and `y` directly. * * The universal trick to know if we need to perform the adjustment is to look * at the `rem` value and check if its sign is the same as `y`. If the signs * are different we need the adjustment. This works on problematic C89 platforms * and C99 and above. */ void divmod(int x, int y, int* p_quot, int* p_rem) { if (y == 0) { Rf_errorcall(R_NilValue, "Division by zero is not allowed."); } int quot = x / y; int rem = (int)(x - (unsigned int)quot * y); if (rem && ((y ^ rem) < 0)) { rem += y; --quot; } *p_quot = quot; *p_rem = rem; } int int_div(int x, int y) { int quot; int rem; divmod(x, y, ", &rem); return quot; } // ----------------------------------------------------------------------------- // Exposed for testing // [[ register() ]] SEXP warp_divmod(SEXP x, SEXP y) { int x_ = INTEGER(x)[0]; int y_ = INTEGER(y)[0]; int quot; int rem; divmod(x_, y_, ", &rem); SEXP out = PROTECT(Rf_allocVector(INTSXP, 2)); INTEGER(out)[0] = quot; INTEGER(out)[1] = rem; UNPROTECT(1); return out; } // Exposed for testing // [[ register() ]] SEXP warp_div(SEXP x, SEXP y) { int x_ = INTEGER(x)[0]; int y_ = INTEGER(y)[0]; div_t result = div(x_, y_); SEXP out = PROTECT(Rf_allocVector(INTSXP, 2)); INTEGER(out)[0] = result.quot; INTEGER(out)[1] = result.rem; UNPROTECT(1); return out; } warp/vignettes/0000755000176200001440000000000014520724062013235 5ustar liggesuserswarp/vignettes/hour.Rmd0000644000176200001440000001143413605501573014664 0ustar liggesusers--- title: "Hour Distances and Daylight Savings" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Hour Distances and Daylight Savings} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(warp) ``` If using `period = "hour"`, it should work as expected at all times when using a time zone that doesn't have daylight savings, like UTC or EST. If using a time zone with DST, like America/New_York, some additional explanation is required, especially when `every > 1`. ## Spring Forward Gap In America/New_York's time zone, as time was about to reach `1970-04-26 02:00:00`, daylight savings kicked in and time shifts forward 1 hour so that the next time is actually `1970-04-26 03:00:00`. ```{r} before_dst <- as.POSIXct("1970-04-26 01:59:59", tz = "America/New_York") before_dst before_dst + 1 ``` `warp_distance()` treats hours 1 and 3 as being side by side, since no hour 2 ever existed. This means that hours (0, 1) and (3, 4) get grouped together in the below example. ```{r} x <- as.POSIXct("1970-04-26 00:00:00", tz = "America/New_York") + 3600 * 0:7 data.frame( x = x, hour = warp_distance(x, "hour", every = 2) ) ``` Because `period = "hour"` just computes the running number of 2 hour periods from the `origin`, this pattern carries forward into the next day to have a contiguous stream of values. This can be somewhat confusing, since hours 0 and 1 don't get grouped together on the 27th. ```{r} y <- as.POSIXct("1970-04-26 22:00:00", tz = "America/New_York") + 3600 * 0:5 data.frame( y = y, hour = warp_distance(y, "hour", every = 2) ) ``` One way that you can sort of get around this is by using lubridate's `force_tz()` function to force a UTC time zone with the same clock time as your original date. I've mocked up a poor man's version of that function below. ```{r} # Or call `lubridate::force_tz(x, "UTC")` force_utc <- function(x) { x_lt <- as.POSIXlt(x) x_lt <- unclass(x_lt) attributes(x) <- NULL out <- x + x_lt$gmtoff as.POSIXct(out, tz = "UTC", origin = "1970-01-01") } x_utc <- force_utc(x) y_utc <- force_utc(y) x_utc ``` In UTC, hour 2 exists so groups are created as (0, 1), (2, 3), and so on, even though hour 2 doesn't actually exist in America/New_York because of the DST gap. This has the affect of limiting the (2, 3) group to a maximum size of 1, since only hour 3 is possible in the data. ```{r} data.frame( x_utc = x_utc, hour = warp_distance(x_utc, "hour", every = 2) ) data.frame( y_utc = y_utc, hour = warp_distance(y_utc, "hour", every = 2) ) ``` ## Fall Backwards Overlap In America/New_York's time zone, as time was about to reach `1970-10-25 02:00:00`, daylight savings kicked in and time shifts backwards 1 hour so that the next time is actually `1970-10-25 01:00:00`. This means there are 2 full hours with an hour value of 1 in that day. ```{r} before_fallback <- as.POSIXct("1970-10-25 01:00:00", tz = "America/New_York") before_fallback # add 1 hour of seconds before_fallback + 3600 ``` Because these are two distinct hours, `warp_distance()` treats them as such, so in the example below a group of (1 EDT, 1 EST) gets created. Since daylight savings is currently active, we also have the situation described above where hour 0 and hour 1 are not grouped together. ```{r} x <- as.POSIXct("1970-10-25 00:00:00", tz = "America/New_York") + 3600 * 0:7 x data.frame( x = x, hour = warp_distance(x, "hour", every = 2) ) ``` This fallback adjustment actually realigns hours 0 and 1 in the next day, since the 25th has 25 hours. ```{r} y <- as.POSIXct("1970-10-25 22:00:00", tz = "America/New_York") + 3600 * 0:5 y data.frame( y = y, hour = warp_distance(y, "hour", every = 2) ) ``` As before, one way to sort of avoid this is to force a UTC time zone. ```{r} x_utc <- force_utc(x) x_utc ``` The consequences of this are that you have two dates with an hour value of 1. When forced to UTC, these look identical. The groups are as you probably expect with buckets of hours (0, 1), (2, 3), and so on, but now the two dates with hour values of 1 are identical so they fall in the same hour group. ```{r} data.frame( x_utc = x_utc, hour = warp_distance(x_utc, "hour", every = 2) ) ``` ## Conclusion While the implementation of `period = "hour"` is _technically_ correct, I recognize that it isn't the most intuitive operation. More intuitive would be a period value of `"dhour"`, which would correspond to the "hour of the day". This would count the number of hour groups from the origin, like `"hour"` does, but it would reset the `every`-hour counter every time you enter a new day. However, this has proved to be challenging to code up, but I hope to incorporate this eventually. warp/R/0000755000176200001440000000000013743336661011440 5ustar liggesuserswarp/R/utils.R0000644000176200001440000000246613605446615012731 0ustar liggesuserstime_class_type <- function(x) { .Call(warp_class_type, x) } # Callable from C as_posixct_from_posixlt <- function(x) { as.POSIXct.POSIXlt(x) } # Callable from C as_posixlt_from_posixct <- function(x) { as.POSIXlt.POSIXct(x) } # Callable from C, ensures that the resulting Date # is a double and has no fractional parts as_date <- function(x) { type <- time_class_type(x) if (type == "date") { if (typeof(x) == "integer") { return(structure(as.double(x), class = "Date")) } else { # Always truncate towards 0 to get rid of fractional date components return(structure(trunc(unclass(x)), class = "Date")) } } if (type == "posixct") { return(as.Date.POSIXct(x, tz = tz(x))) } if (type == "posixlt") { return(as.Date.POSIXlt(x)) } stop("Internal error: Unknown date time class", call. = FALSE) } # Used in `as_date()`, main thing to ensure of is that # `as_date()` on a POSIXct retains the year/month/day of that time zone tz <- function(x) { tzone <- attr(x, "tzone")[[1]] if (is.null(tzone) && !is_POSIXt(x)) { return("UTC") } if (is.character(tzone) && nzchar(tzone)) { return(tzone) } tzone <- attr(as.POSIXlt(x[0]), "tzone")[[1]] if (is.null(tzone)) { return("UTC") } tzone } is_POSIXt <- function(x) { inherits(x, "POSIXt") } warp/R/zzz.R0000644000176200001440000000016613576767204012430 0ustar liggesusers# nocov start .onLoad <- function(libname, pkgname) { .Call(warp_init_library, asNamespace("warp")) } # nocov end warp/R/boundary.R0000644000176200001440000000264213743336661013412 0ustar liggesusers#' Locate period boundaries for a date vector #' #' @description #' `warp_boundary()` detects a change in time period along `x`, for example, #' rolling from one month to the next. It returns the start and stop positions #' for each contiguous period chunk in `x`. #' #' @details #' The stop positions are just the [warp_change()] values, and the start #' positions are computed from these. #' #' @inheritParams warp_distance #' #' @return #' A two column data frame with the columns `start` and `stop`. Both are #' double vectors representing boundaries of the date time groups. #' #' @export #' @examples #' x <- as.Date("1970-01-01") + -4:5 #' x #' #' # Boundaries by month #' warp_boundary(x, "month") #' #' # Bound by every 5 days, relative to "1970-01-01" #' # Creates boundaries of: #' # [1969-12-27, 1970-01-01) #' # [1970-01-01, 1970-01-06) #' # [1970-01-06, 1970-01-11) #' warp_boundary(x, "day", every = 5) #' #' # Bound by every 5 days, relative to the smallest value in our vector #' origin <- min(x) #' origin #' #' # Creates boundaries of: #' # [1969-12-28, 1970-01-02) #' # [1970-01-02, 1970-01-07) #' warp_boundary(x, "day", every = 5, origin = origin) warp_boundary <- function(x, period, ..., every = 1L, origin = NULL) { check_dots_empty("warp_boundary", ...) .Call(warp_warp_boundary, x, period, every, origin) } warp/R/change.R0000644000176200001440000000407713743336661013020 0ustar liggesusers#' Detect changes in a date time vector #' #' @description #' `warp_change()` detects changes at the `period` level. #' #' If `last = TRUE`, it returns locations of the last value before a change, #' and the last location in `x` is always included. Additionally, if #' `endpoint = TRUE`, the first location in `x` will be included. #' #' If `last = FALSE`, it returns locations of the first value after a change, #' and the first location in `x` is always included. Additionally, if #' `endpoint = TRUE`, the last location in `x` will be included. #' #' @inheritParams warp_distance #' #' @param last `[logical(1)]` #' #' If `TRUE`, the _last_ location _before_ a change is returned. #' The last location of the input is always returned. #' #' If `FALSE`, the _first_ location _after_ a change is returned. #' The first location of the input is always returned. #' #' @param endpoint `[logical(1)]` #' #' If `TRUE` and `last = TRUE`, will additionally return the first location #' of the input. #' #' If `TRUE` and `last = FALSE`, will additionally return the last location #' of the input. #' #' If `FALSE`, does nothing. #' #' @return #' A double vector of locations. #' #' @export #' @examples #' x <- as.Date("2019-01-01") + 0:5 #' x #' #' # Last location before a change, last location of `x` is always included #' warp_change(x, period = "yday", every = 2, last = TRUE) #' #' # Also include first location #' warp_change(x, period = "yday", every = 2, last = TRUE, endpoint = TRUE) #' #' # First location after a change, first location of `x` is always included #' warp_change(x, period = "yday", every = 2, last = FALSE) #' #' # Also include last location #' warp_change(x, period = "yday", every = 2, last = FALSE, endpoint = TRUE) warp_change <- function(x, period, ..., every = 1L, origin = NULL, last = TRUE, endpoint = FALSE) { check_dots_empty("warp_change", ...) .Call(warp_warp_change, x, period, every, origin, last, endpoint) } warp/R/warp-package.R0000644000176200001440000000036313605446615014125 0ustar liggesusers#' @keywords internal "_PACKAGE" # The following block is used by usethis to automatically manage # roxygen namespace tags. Modify with care! ## usethis namespace: start #' @useDynLib warp, .registration = TRUE ## usethis namespace: end NULL warp/R/distance.R0000644000176200001440000002210213743336661013352 0ustar liggesusers#' Compute distances from a date time origin #' #' @description #' `warp_distance()` is a low level engine for computing date time distances. #' #' It returns the distance from `x` to the `origin` in units #' defined by the `period`. #' #' For example, `period = "year"` would return the number of years from #' the `origin`. Setting `every = 2` would return the number of 2 year groups #' from the `origin`. #' #' @details #' The return value of `warp_distance()` has a variety of uses. It can be used #' for: #' #' - A grouping column in a `dplyr::group_by()`. This is especially useful for #' grouping by a multitude of a particular period, such as "every 5 months". #' #' - Computing distances between values in `x`, in units of the `period`. #' By returning the distances from the `origin`, `warp_distance()` has also #' implicitly computed the distances between values of `x`. This is used #' by `slide::block()` to break the input into time blocks. #' #' When the time zone of `x` differs from the time zone of `origin`, a warning #' is issued, and `x` is coerced to the time zone of `origin` without changing #' the number of seconds of `x` from the epoch. In other words, the time zone #' of `x` is directly changed to the time zone of `origin` without changing the #' underlying numeric representation. __It is highly advised to specify an #' `origin` value with the same time zone as `x`.__ If a `Date` is used for #' `x`, its time zone is assumed to be `"UTC"`. #' #' @section Period: #' #' For `period` values of `"year"`, `"month"`, and `"day"`, the information #' provided in `origin` is truncated. Practically this means that if you #' specify: #' #' ``` #' warp_distance(period = "month", origin = as.Date("1970-01-15")) #' ``` #' #' then only `1970-01` will be used, and not the fact that the origin starts #' on the 15th of the month. #' #' The `period` value of `"quarter"` is internally #' `period = "month", every = every * 3`. This means that for `"quarter"` #' the month specified for the `origin` will be used as the month to start #' counting from to generate the 3 month quarter. #' #' To mimic the behavior of `lubridate::floor_date()`, use `period = "week"`. #' Internally this is just `period = "day", every = every * 7`. To mimic the #' `week_start` argument of `floor_date()`, set `origin` to a date #' with a week day identical to the one you want the week to start from. For #' example, the default origin of `1970-01-01` is a Thursday, so this would be #' generate groups identical to `floor_date(week_start = 4)`. #' #' The `period` value of `"yday"` is computed as complete `every`-day periods #' from the `origin`, with a forced reset of the `every`-day counter every #' time you hit the month-day value of the `origin`. `"yweek"` is built on top #' of this internally as `period = "yday", every = every * 7`. This ends up #' using an algorithm very similar to `lubridate::week()`, with the added #' benefit of being able to control the `origin` date. #' #' The `period` value of `"mday"` is computed as `every`-day periods within #' each month, with a forced reset of the `every`-day counter #' on the first day of each month. The most useful application of this is #' `"mweek"`, which is implemented as `period = "mday", every = every * 7`. This #' allows you to group by the "week of the month". For `"mday"` and `"mweek"`, #' only the year and month parts of the `origin` value are used. Because of #' this, the `origin` argument is not that interesting for these periods. #' #' The `"hour"` period (and more granular frequencies) can produce results #' that might be surprising, even if they are technically correct. See the #' vignette at `vignette("hour", package = "warp")` for more information. #' #' @section Precision: #' #' With `POSIXct`, the limit of precision is approximately the microsecond #' level. Only dates that are very close to the unix origin of 1970-01-01 can #' possibly represent microsecond resolution correctly (close being within #' about 40 years on either side). Otherwise, the values past the microsecond #' resolution are essentially random, and can cause problems for the distance #' calculations. Because of this, decimal digits past the microsecond range are #' zeroed out, so please do not attempt to rely on them. It should still be safe #' to work with microseconds, by, say, bucketing them by millisecond distances. #' #' @param x `[Date / POSIXct / POSIXlt]` #' #' A date time vector. #' #' @param period `[character(1)]` #' #' A string defining the period to group by. Valid inputs can be roughly #' broken into: #' #' - `"year"`, `"quarter"`, `"month"`, `"week"`, `"day"` #' - `"hour"`, `"minute"`, `"second"`, `"millisecond"` #' - `"yweek"`, `"mweek"` #' - `"yday"`, `"mday"` #' #' @param every `[positive integer(1)]` #' #' The number of periods to group together. #' #' For example, if the period was set to `"year"` with an every value of `2`, #' then the years 1970 and 1971 would be placed in the same group. #' #' @param origin `[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]` #' #' The reference date time value. The default when left as `NULL` is the #' epoch time of `1970-01-01 00:00:00`, _in the time zone of the index_. #' #' This is generally used to define the anchor time to count from, which is #' relevant when the every value is `> 1`. #' #' @param ... `[dots]` #' #' These dots are for future extensions and must be empty. #' #' @return #' A double vector containing the distances. #' #' @export #' @examples #' x <- as.Date("1970-01-01") + -4:4 #' x #' #' # Compute monthly distances (really, year + month) #' warp_distance(x, "month") #' #' # Compute distances every 2 days, relative to "1970-01-01" #' warp_distance(x, "day", every = 2) #' #' # Compute distances every 2 days, this time relative to "1970-01-02" #' warp_distance(x, "day", every = 2, origin = as.Date("1970-01-02")) #' #' y <- as.POSIXct("1970-01-01 00:00:01", "UTC") + c(0, 2, 3, 4, 5, 6, 10) #' #' # Compute distances every 5 seconds, starting from the unix epoch of #' # 1970-01-01 00:00:00 #' # So this buckets: #' # [1970-01-01 00:00:00, 1970-01-01 00:00:05) = 0 #' # [1970-01-01 00:00:05, 1970-01-01 00:00:10) = 1 #' # [1970-01-01 00:00:10, 1970-01-01 00:00:15) = 2 #' warp_distance(y, "second", every = 5) #' #' # Compute distances every 5 seconds, starting from the minimum of `x` #' # 1970-01-01 00:00:01 #' # So this buckets: #' # [1970-01-01 00:00:01, 1970-01-01 00:00:06) = 0 #' # [1970-01-01 00:00:06, 1970-01-01 00:00:11) = 1 #' # [1970-01-01 00:00:11, 1970-01-01 00:00:16) = 2 #' origin <- as.POSIXct("1970-01-01 00:00:01", "UTC") #' warp_distance(y, "second", every = 5, origin = origin) #' #' # --------------------------------------------------------------------------- #' # Time zones #' #' # When `x` is not UTC and `origin` is left as `NULL`, the origin is set as #' # 1970-01-01 00:00:00 in the time zone of `x`. This seems to be the most #' # practically useful default. #' z <- as.POSIXct("1969-12-31 23:00:00", "UTC") #' z_in_nyc <- as.POSIXct("1969-12-31 23:00:00", "America/New_York") #' #' # Practically this means that these give the same result, because their #' # `origin` values are defined in their respective time zones. #' warp_distance(z, "year") #' warp_distance(z_in_nyc, "year") #' #' # Compare that to what would happen if we used a static `origin` of #' # 1970-01-01 00:00:00 UTC. #' # America/New_York is 5 hours behind UTC, so when `z_in_nyc` is converted to #' # UTC the value becomes `1970-01-01 04:00:00 UTC`, a different year. Because #' # this is generally surprising, a warning is thrown. #' origin <- as.POSIXct("1970-01-01 00:00:00", tz = "UTC") #' warp_distance(z, "year", origin = origin) #' warp_distance(z_in_nyc, "year", origin = origin) #' #' # --------------------------------------------------------------------------- #' # `period = "yweek"` #' #' x <- as.Date("2019-12-23") + 0:16 #' origin <- as.Date("1970-01-01") #' #' # `"week"` counts the number of 7 day periods from the `origin` #' # `"yweek"` restarts the 7 day counter every time you hit the month-day #' # value of the `origin`. Notice how, for the `yweek` column, only 1 day was #' # in the week starting with `2019-12-31`. This is because the next day is #' # `2020-01-01`, which aligns with the month-day value of the `origin`. #' data.frame( #' x = x, #' week = warp_distance(x, "week", origin = origin), #' yweek = warp_distance(x, "yweek", origin = origin) #' ) #' #' # --------------------------------------------------------------------------- #' # `period = "mweek"` #' #' x <- as.Date("2019-12-23") + 0:16 #' #' # `"mweek"` breaks `x` up into weeks of the month. Notice how days 1-7 #' # of 2020-01 all have the same distance value. A forced reset of the 7 day #' # counter is done at the 1st of every month. This results in the 3 day #' # week of the month at the end of 2019-12, from 29-31. #' data.frame( #' x = x, #' mweek = warp_distance(x, "mweek") #' ) #' warp_distance <- function(x, period, ..., every = 1L, origin = NULL) { check_dots_empty("warp_distance", ...) .Call(warp_warp_distance, x, period, every, origin) } warp/R/date.R0000644000176200001440000000026713605147072012476 0ustar liggesusers# Exported for testing date_get_year_offset <- function(x) { .Call(warp_date_get_year_offset, x) } date_get_month_offset <- function(x) { .Call(warp_date_get_month_offset, x) } warp/R/divmod.R0000644000176200001440000000020313605147072013031 0ustar liggesusers# Exported for testing divmod <- function(x, y) { .Call(warp_divmod, x, y) } div <- function(x, y) { .Call(warp_div, x, y) } warp/R/dots.R0000644000176200001440000000064713743336661012543 0ustar liggesusersdots_n <- function(...) { nargs() } # Like `ellipsis::check_dots_empty()` but without the import check_dots_empty <- function(fn, ...) { n <- dots_n(...) if (n == 0L) { return(invisible()) } msg <- paste0( "`...` is not empty in `", fn, "()`.\n", "These dots only exist to allow for future extensions and should be empty.\n", "Did you misspecify an argument?" ) stop(msg, call. = FALSE) } warp/NEWS.md0000644000176200001440000000054714520722600012325 0ustar liggesusers# warp 0.2.1 * Fixed a test related to an R-devel bugfix in `as.POSIXlt()` (#36). # warp 0.2.0 * All optional arguments must now be specified by name. * `warp_change()` has two new arguments, `last` and `endpoint`, for controlling exactly what type of change points are returned. # warp 0.1.0 * Added a `NEWS.md` file to track changes to the package. warp/MD50000644000176200001440000000425514520757362011554 0ustar liggesusers0c6f63492e8bd3938c1c952aa08d07a7 *DESCRIPTION 7fe3b7520e38f4f0b3caefa8d229ae78 *LICENSE 73ac4c15c755b9d1555082ad53ab0909 *NAMESPACE a01d382148e28e66ffa8572893c5573b *NEWS.md 98a0693e714c4f48691276c1855aa047 *R/boundary.R 71ac4f25b6b2e5202c1fded5100b41a7 *R/change.R c180a345346dde264015c70ceb360332 *R/date.R 231fedf5cb3ed7abe7396119ca82d385 *R/distance.R a5f64f23c3a85bacb76d6db2c87a41c0 *R/divmod.R c45f86895c5e3c6d30615b3cbb336542 *R/dots.R 6c1f2e82813521343e9b612e03508b38 *R/utils.R 6fb450352e850f2c3e852f9a648f1822 *R/warp-package.R 56a10dc9178533f454b88bfa09ae7b08 *R/zzz.R 8355c9cb3f46c6a7bde1d3f2ef88b528 *README.md 926119323b5c52675f2457aa40ac22d2 *build/vignette.rds b4bfb0c4b4e1643551d8c73bf2845ba3 *inst/doc/hour.R c7c9b2ae8a33a1c3ec75c9b5474b182f *inst/doc/hour.Rmd 48274a2d2aa5f5ce81e98b15abc09698 *inst/doc/hour.html e38bddbfed67762f0b879e5bfbaf7b2c *man/warp-package.Rd a76227450e49a07e88add3872142e641 *man/warp_boundary.Rd 2e79fcafbc52763a1eef036ec66d6535 *man/warp_change.Rd 76e962f1fd23e9c803f14b7cffc3a0e2 *man/warp_distance.Rd c275773b9432b4de22f0c27b8bd9a6c1 *src/boundary.c 5a4a9745c645bc784709f65da8a909d3 *src/change.c 9ae7932a496bb4c9ead4c022b35649b6 *src/coercion.c bf3f1e90ce49b0e94c8d91220763d47a *src/date.c 7f49dec486aa3795f7cdbd00062620ec *src/distance.c 890e8dfad34523d91136cc58514d5a18 *src/divmod.c 17cd78c1506905c631498943a6edb2bc *src/divmod.h 6da4f05e7a99b107c85dd26f7d5b94b9 *src/get.c 1529c64fba5f5a1ea1ab72576d42bf34 *src/init.c a0e21a5aaf3c65a0df1a3658760a76f6 *src/timezone.c a963034bd2a58f47f94ce18042713845 *src/utils.c aee5c44f1d526e7f2f5d787686dba7d7 *src/utils.h bf902709130f2238ee9d8970a2264312 *src/warp.h 316b230436ea98216d103ddda8353c81 *tests/testthat.R 0d8d282bc2f54ffe60f0ac9616f61423 *tests/testthat/helper-constructor.R 5d3c9b6af4863600da9578b46623bff9 *tests/testthat/helper-with-option.R d5bafbda8080467cb3692b90b4e40595 *tests/testthat/test-boundaries.R e09f0c6d5d1128e65862b38abfeca736 *tests/testthat/test-change.R 2cfb514bcff2ed17be53c287ea6e971a *tests/testthat/test-date.R 2c6603a3fa7ef2cab89c9142f5b7e17c *tests/testthat/test-distance.R be545e0755739075cb8b06b4c232c13f *tests/testthat/test-divmod.R c7c9b2ae8a33a1c3ec75c9b5474b182f *vignettes/hour.Rmd warp/inst/0000755000176200001440000000000014520724062012202 5ustar liggesuserswarp/inst/doc/0000755000176200001440000000000014520724062012747 5ustar liggesuserswarp/inst/doc/hour.Rmd0000644000176200001440000001143413605501573014376 0ustar liggesusers--- title: "Hour Distances and Daylight Savings" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Hour Distances and Daylight Savings} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(warp) ``` If using `period = "hour"`, it should work as expected at all times when using a time zone that doesn't have daylight savings, like UTC or EST. If using a time zone with DST, like America/New_York, some additional explanation is required, especially when `every > 1`. ## Spring Forward Gap In America/New_York's time zone, as time was about to reach `1970-04-26 02:00:00`, daylight savings kicked in and time shifts forward 1 hour so that the next time is actually `1970-04-26 03:00:00`. ```{r} before_dst <- as.POSIXct("1970-04-26 01:59:59", tz = "America/New_York") before_dst before_dst + 1 ``` `warp_distance()` treats hours 1 and 3 as being side by side, since no hour 2 ever existed. This means that hours (0, 1) and (3, 4) get grouped together in the below example. ```{r} x <- as.POSIXct("1970-04-26 00:00:00", tz = "America/New_York") + 3600 * 0:7 data.frame( x = x, hour = warp_distance(x, "hour", every = 2) ) ``` Because `period = "hour"` just computes the running number of 2 hour periods from the `origin`, this pattern carries forward into the next day to have a contiguous stream of values. This can be somewhat confusing, since hours 0 and 1 don't get grouped together on the 27th. ```{r} y <- as.POSIXct("1970-04-26 22:00:00", tz = "America/New_York") + 3600 * 0:5 data.frame( y = y, hour = warp_distance(y, "hour", every = 2) ) ``` One way that you can sort of get around this is by using lubridate's `force_tz()` function to force a UTC time zone with the same clock time as your original date. I've mocked up a poor man's version of that function below. ```{r} # Or call `lubridate::force_tz(x, "UTC")` force_utc <- function(x) { x_lt <- as.POSIXlt(x) x_lt <- unclass(x_lt) attributes(x) <- NULL out <- x + x_lt$gmtoff as.POSIXct(out, tz = "UTC", origin = "1970-01-01") } x_utc <- force_utc(x) y_utc <- force_utc(y) x_utc ``` In UTC, hour 2 exists so groups are created as (0, 1), (2, 3), and so on, even though hour 2 doesn't actually exist in America/New_York because of the DST gap. This has the affect of limiting the (2, 3) group to a maximum size of 1, since only hour 3 is possible in the data. ```{r} data.frame( x_utc = x_utc, hour = warp_distance(x_utc, "hour", every = 2) ) data.frame( y_utc = y_utc, hour = warp_distance(y_utc, "hour", every = 2) ) ``` ## Fall Backwards Overlap In America/New_York's time zone, as time was about to reach `1970-10-25 02:00:00`, daylight savings kicked in and time shifts backwards 1 hour so that the next time is actually `1970-10-25 01:00:00`. This means there are 2 full hours with an hour value of 1 in that day. ```{r} before_fallback <- as.POSIXct("1970-10-25 01:00:00", tz = "America/New_York") before_fallback # add 1 hour of seconds before_fallback + 3600 ``` Because these are two distinct hours, `warp_distance()` treats them as such, so in the example below a group of (1 EDT, 1 EST) gets created. Since daylight savings is currently active, we also have the situation described above where hour 0 and hour 1 are not grouped together. ```{r} x <- as.POSIXct("1970-10-25 00:00:00", tz = "America/New_York") + 3600 * 0:7 x data.frame( x = x, hour = warp_distance(x, "hour", every = 2) ) ``` This fallback adjustment actually realigns hours 0 and 1 in the next day, since the 25th has 25 hours. ```{r} y <- as.POSIXct("1970-10-25 22:00:00", tz = "America/New_York") + 3600 * 0:5 y data.frame( y = y, hour = warp_distance(y, "hour", every = 2) ) ``` As before, one way to sort of avoid this is to force a UTC time zone. ```{r} x_utc <- force_utc(x) x_utc ``` The consequences of this are that you have two dates with an hour value of 1. When forced to UTC, these look identical. The groups are as you probably expect with buckets of hours (0, 1), (2, 3), and so on, but now the two dates with hour values of 1 are identical so they fall in the same hour group. ```{r} data.frame( x_utc = x_utc, hour = warp_distance(x_utc, "hour", every = 2) ) ``` ## Conclusion While the implementation of `period = "hour"` is _technically_ correct, I recognize that it isn't the most intuitive operation. More intuitive would be a period value of `"dhour"`, which would correspond to the "hour of the day". This would count the number of hour groups from the origin, like `"hour"` does, but it would reset the `every`-hour counter every time you enter a new day. However, this has proved to be challenging to code up, but I hope to incorporate this eventually. warp/inst/doc/hour.html0000644000176200001440000007557214520724062014632 0ustar liggesusers Hour Distances and Daylight Savings

Hour Distances and Daylight Savings

library(warp)

If using period = "hour", it should work as expected at all times when using a time zone that doesn’t have daylight savings, like UTC or EST. If using a time zone with DST, like America/New_York, some additional explanation is required, especially when every > 1.

Spring Forward Gap

In America/New_York’s time zone, as time was about to reach 1970-04-26 02:00:00, daylight savings kicked in and time shifts forward 1 hour so that the next time is actually 1970-04-26 03:00:00.

before_dst <- as.POSIXct("1970-04-26 01:59:59", tz = "America/New_York")
before_dst
#> [1] "1970-04-26 01:59:59 EST"

before_dst + 1
#> [1] "1970-04-26 03:00:00 EDT"

warp_distance() treats hours 1 and 3 as being side by side, since no hour 2 ever existed. This means that hours (0, 1) and (3, 4) get grouped together in the below example.

x <- as.POSIXct("1970-04-26 00:00:00", tz = "America/New_York") + 3600 * 0:7

data.frame(
  x = x,
  hour = warp_distance(x, "hour", every = 2)
)
#>                     x hour
#> 1 1970-04-26 00:00:00 1380
#> 2 1970-04-26 01:00:00 1380
#> 3 1970-04-26 03:00:00 1381
#> 4 1970-04-26 04:00:00 1381
#> 5 1970-04-26 05:00:00 1382
#> 6 1970-04-26 06:00:00 1382
#> 7 1970-04-26 07:00:00 1383
#> 8 1970-04-26 08:00:00 1383

Because period = "hour" just computes the running number of 2 hour periods from the origin, this pattern carries forward into the next day to have a contiguous stream of values. This can be somewhat confusing, since hours 0 and 1 don’t get grouped together on the 27th.

y <- as.POSIXct("1970-04-26 22:00:00", tz = "America/New_York") + 3600 * 0:5

data.frame(
  y = y,
  hour = warp_distance(y, "hour", every = 2)
)
#>                     y hour
#> 1 1970-04-26 22:00:00 1390
#> 2 1970-04-26 23:00:00 1391
#> 3 1970-04-27 00:00:00 1391
#> 4 1970-04-27 01:00:00 1392
#> 5 1970-04-27 02:00:00 1392
#> 6 1970-04-27 03:00:00 1393

One way that you can sort of get around this is by using lubridate’s force_tz() function to force a UTC time zone with the same clock time as your original date. I’ve mocked up a poor man’s version of that function below.

# Or call `lubridate::force_tz(x, "UTC")`
force_utc <- function(x) {
  x_lt <- as.POSIXlt(x)
  x_lt <- unclass(x_lt)
  
  attributes(x) <- NULL
  
  out <- x + x_lt$gmtoff
  
  as.POSIXct(out, tz = "UTC", origin = "1970-01-01")
}

x_utc <- force_utc(x)
y_utc <- force_utc(y)

x_utc
#> [1] "1970-04-26 00:00:00 UTC" "1970-04-26 01:00:00 UTC"
#> [3] "1970-04-26 03:00:00 UTC" "1970-04-26 04:00:00 UTC"
#> [5] "1970-04-26 05:00:00 UTC" "1970-04-26 06:00:00 UTC"
#> [7] "1970-04-26 07:00:00 UTC" "1970-04-26 08:00:00 UTC"

In UTC, hour 2 exists so groups are created as (0, 1), (2, 3), and so on, even though hour 2 doesn’t actually exist in America/New_York because of the DST gap. This has the affect of limiting the (2, 3) group to a maximum size of 1, since only hour 3 is possible in the data.

data.frame(
  x_utc = x_utc,
  hour = warp_distance(x_utc, "hour", every = 2)
)
#>                 x_utc hour
#> 1 1970-04-26 00:00:00 1380
#> 2 1970-04-26 01:00:00 1380
#> 3 1970-04-26 03:00:00 1381
#> 4 1970-04-26 04:00:00 1382
#> 5 1970-04-26 05:00:00 1382
#> 6 1970-04-26 06:00:00 1383
#> 7 1970-04-26 07:00:00 1383
#> 8 1970-04-26 08:00:00 1384

data.frame(
  y_utc = y_utc,
  hour = warp_distance(y_utc, "hour", every = 2)
)
#>                 y_utc hour
#> 1 1970-04-26 22:00:00 1391
#> 2 1970-04-26 23:00:00 1391
#> 3 1970-04-27 00:00:00 1392
#> 4 1970-04-27 01:00:00 1392
#> 5 1970-04-27 02:00:00 1393
#> 6 1970-04-27 03:00:00 1393

Fall Backwards Overlap

In America/New_York’s time zone, as time was about to reach 1970-10-25 02:00:00, daylight savings kicked in and time shifts backwards 1 hour so that the next time is actually 1970-10-25 01:00:00. This means there are 2 full hours with an hour value of 1 in that day.

before_fallback <- as.POSIXct("1970-10-25 01:00:00", tz = "America/New_York")
before_fallback
#> [1] "1970-10-25 01:00:00 EDT"

# add 1 hour of seconds
before_fallback + 3600
#> [1] "1970-10-25 01:00:00 EST"

Because these are two distinct hours, warp_distance() treats them as such, so in the example below a group of (1 EDT, 1 EST) gets created. Since daylight savings is currently active, we also have the situation described above where hour 0 and hour 1 are not grouped together.

x <- as.POSIXct("1970-10-25 00:00:00", tz = "America/New_York") + 3600 * 0:7
x
#> [1] "1970-10-25 00:00:00 EDT" "1970-10-25 01:00:00 EDT"
#> [3] "1970-10-25 01:00:00 EST" "1970-10-25 02:00:00 EST"
#> [5] "1970-10-25 03:00:00 EST" "1970-10-25 04:00:00 EST"
#> [7] "1970-10-25 05:00:00 EST" "1970-10-25 06:00:00 EST"

data.frame(
  x = x,
  hour = warp_distance(x, "hour", every = 2)
)
#>                     x hour
#> 1 1970-10-25 00:00:00 3563
#> 2 1970-10-25 01:00:00 3564
#> 3 1970-10-25 01:00:00 3564
#> 4 1970-10-25 02:00:00 3565
#> 5 1970-10-25 03:00:00 3565
#> 6 1970-10-25 04:00:00 3566
#> 7 1970-10-25 05:00:00 3566
#> 8 1970-10-25 06:00:00 3567

This fallback adjustment actually realigns hours 0 and 1 in the next day, since the 25th has 25 hours.

y <- as.POSIXct("1970-10-25 22:00:00", tz = "America/New_York") + 3600 * 0:5
y
#> [1] "1970-10-25 22:00:00 EST" "1970-10-25 23:00:00 EST"
#> [3] "1970-10-26 00:00:00 EST" "1970-10-26 01:00:00 EST"
#> [5] "1970-10-26 02:00:00 EST" "1970-10-26 03:00:00 EST"

data.frame(
  y = y,
  hour = warp_distance(y, "hour", every = 2)
)
#>                     y hour
#> 1 1970-10-25 22:00:00 3575
#> 2 1970-10-25 23:00:00 3575
#> 3 1970-10-26 00:00:00 3576
#> 4 1970-10-26 01:00:00 3576
#> 5 1970-10-26 02:00:00 3577
#> 6 1970-10-26 03:00:00 3577

As before, one way to sort of avoid this is to force a UTC time zone.

x_utc <- force_utc(x)
x_utc
#> [1] "1970-10-25 00:00:00 UTC" "1970-10-25 01:00:00 UTC"
#> [3] "1970-10-25 01:00:00 UTC" "1970-10-25 02:00:00 UTC"
#> [5] "1970-10-25 03:00:00 UTC" "1970-10-25 04:00:00 UTC"
#> [7] "1970-10-25 05:00:00 UTC" "1970-10-25 06:00:00 UTC"

The consequences of this are that you have two dates with an hour value of 1. When forced to UTC, these look identical. The groups are as you probably expect with buckets of hours (0, 1), (2, 3), and so on, but now the two dates with hour values of 1 are identical so they fall in the same hour group.

data.frame(
  x_utc = x_utc,
  hour = warp_distance(x_utc, "hour", every = 2)
)
#>                 x_utc hour
#> 1 1970-10-25 00:00:00 3564
#> 2 1970-10-25 01:00:00 3564
#> 3 1970-10-25 01:00:00 3564
#> 4 1970-10-25 02:00:00 3565
#> 5 1970-10-25 03:00:00 3565
#> 6 1970-10-25 04:00:00 3566
#> 7 1970-10-25 05:00:00 3566
#> 8 1970-10-25 06:00:00 3567

Conclusion

While the implementation of period = "hour" is technically correct, I recognize that it isn’t the most intuitive operation. More intuitive would be a period value of "dhour", which would correspond to the “hour of the day”. This would count the number of hour groups from the origin, like "hour" does, but it would reset the every-hour counter every time you enter a new day. However, this has proved to be challenging to code up, but I hope to incorporate this eventually.

warp/inst/doc/hour.R0000644000176200001440000000461014520724061014047 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(warp) ## ----------------------------------------------------------------------------- before_dst <- as.POSIXct("1970-04-26 01:59:59", tz = "America/New_York") before_dst before_dst + 1 ## ----------------------------------------------------------------------------- x <- as.POSIXct("1970-04-26 00:00:00", tz = "America/New_York") + 3600 * 0:7 data.frame( x = x, hour = warp_distance(x, "hour", every = 2) ) ## ----------------------------------------------------------------------------- y <- as.POSIXct("1970-04-26 22:00:00", tz = "America/New_York") + 3600 * 0:5 data.frame( y = y, hour = warp_distance(y, "hour", every = 2) ) ## ----------------------------------------------------------------------------- # Or call `lubridate::force_tz(x, "UTC")` force_utc <- function(x) { x_lt <- as.POSIXlt(x) x_lt <- unclass(x_lt) attributes(x) <- NULL out <- x + x_lt$gmtoff as.POSIXct(out, tz = "UTC", origin = "1970-01-01") } x_utc <- force_utc(x) y_utc <- force_utc(y) x_utc ## ----------------------------------------------------------------------------- data.frame( x_utc = x_utc, hour = warp_distance(x_utc, "hour", every = 2) ) data.frame( y_utc = y_utc, hour = warp_distance(y_utc, "hour", every = 2) ) ## ----------------------------------------------------------------------------- before_fallback <- as.POSIXct("1970-10-25 01:00:00", tz = "America/New_York") before_fallback # add 1 hour of seconds before_fallback + 3600 ## ----------------------------------------------------------------------------- x <- as.POSIXct("1970-10-25 00:00:00", tz = "America/New_York") + 3600 * 0:7 x data.frame( x = x, hour = warp_distance(x, "hour", every = 2) ) ## ----------------------------------------------------------------------------- y <- as.POSIXct("1970-10-25 22:00:00", tz = "America/New_York") + 3600 * 0:5 y data.frame( y = y, hour = warp_distance(y, "hour", every = 2) ) ## ----------------------------------------------------------------------------- x_utc <- force_utc(x) x_utc ## ----------------------------------------------------------------------------- data.frame( x_utc = x_utc, hour = warp_distance(x_utc, "hour", every = 2) )