1#' Round, floor and ceiling methods for date-time objects
2#'
3#' @description
4#' `round_date()` takes a date-time object and time unit, and rounds it to the nearest value
5#' of the specified time unit. For rounding date-times which are exactly halfway
6#' between two consecutive units, the convention is to round up. Note that this
7#' is in line with the behavior of R's [base::round.POSIXt()] function
8#' but does not follow the convention of the base [base::round()] function
9#' which "rounds to the even digit", as per IEC 60559.
10#'
11#' Rounding to the nearest unit or multiple of a unit is supported. All
12#' meaningful specifications in the English language are supported - secs, min,
13#' mins, 2 minutes, 3 years etc.
14#'
15#' Rounding to fractional seconds is also supported. Please note that rounding to
16#' fractions smaller than 1 second can lead to large precision errors due to the
17#' floating point representation of the POSIXct objects. See examples.
18#'
19#'
20#' @details In \pkg{lubridate}, functions that round date-time objects try to
21#'   preserve the class of the input object whenever possible. This is done by
22#'   first rounding to an instant, and then converting to the original class as per
23#'   usual R conventions.
24#'
25#'
26#' @section Rounding Up Date Objects:
27#'
28#' By default, rounding up `Date` objects follows 3 steps:
29#'
30#' 1. Convert to an instant representing lower bound of the Date:
31#'    `2000-01-01` --> `2000-01-01 00:00:00`
32#'
33#' 2. Round up to the \strong{next} closest rounding unit boundary. For example,
34#'    if the rounding unit is `month` then next closest boundary of `2000-01-01`
35#'    is `2000-02-01 00:00:00`.
36#'
37#'    The motivation for this is that the "partial" `2000-01-01` is conceptually
38#'    an interval (`2000-01-01 00:00:00` -- `2000-01-02 00:00:00`) and the day
39#'    hasn't started clocking yet at the exact boundary `00:00:00`. Thus, it
40#'    seems wrong to round a day to its lower boundary.
41#'
42#'    Behavior on the boundary can be changed by setting
43#'    `change_on_boundary` to `TRUE` or `FALSE`.
44#'
45#' 3. If the rounding unit is smaller than a day, return the instant from step 2
46#'     (`POSIXct`), otherwise convert to and return a `Date` object.
47#'
48#' @rdname round_date
49#' @param x a vector of date-time objects
50#' @param unit a character string specifying a time unit or a multiple of a unit
51#'   to be rounded to. Valid base units are `second`, `minute`, `hour`, `day`,
52#'   `week`, `month`, `bimonth`, `quarter`, `season`, `halfyear` and
53#'   `year`. Arbitrary unique English abbreviations as in the [period()]
54#'   constructor are allowed. Rounding to multiples of units (except weeks) is
55#'   supported.
56#' @param change_on_boundary if this is `NULL` (the default), instants on the boundary
57#'   remain unchanged, but `Date` objects are rounded up to the next boundary.
58#'   If this is `TRUE`, instants on the boundary are rounded up to the next boundary.
59#'   If this is `FALSE`, nothing on the boundary is rounded up at all. This was the
60#'   default for \pkg{lubridate} prior to `v1.6.0`.
61#'   See section `Rounding Up Date Objects` below for more details.
62#'
63#' @param week_start when unit is `week`, specify the reference day.
64#'   7 represents Sunday and 1 represents Monday.
65#' @keywords manip chron
66#' @seealso [base::round()]
67#' @examples
68#'
69#' ## print fractional seconds
70#' options(digits.secs=6)
71#'
72#' x <- ymd_hms("2009-08-03 12:01:59.23")
73#' round_date(x, ".5s")
74#' round_date(x, "sec")
75#' round_date(x, "second")
76#' round_date(x, "minute")
77#' round_date(x, "5 mins")
78#' round_date(x, "hour")
79#' round_date(x, "2 hours")
80#' round_date(x, "day")
81#' round_date(x, "week")
82#' round_date(x, "month")
83#' round_date(x, "bimonth")
84#' round_date(x, "quarter") == round_date(x, "3 months")
85#' round_date(x, "halfyear")
86#' round_date(x, "year")
87#'
88#' x <- ymd_hms("2009-08-03 12:01:59.23")
89#' floor_date(x, ".1s")
90#' floor_date(x, "second")
91#' floor_date(x, "minute")
92#' floor_date(x, "hour")
93#' floor_date(x, "day")
94#' floor_date(x, "week")
95#' floor_date(x, "month")
96#' floor_date(x, "bimonth")
97#' floor_date(x, "quarter")
98#' floor_date(x, "season")
99#' floor_date(x, "halfyear")
100#' floor_date(x, "year")
101#'
102#' x <- ymd_hms("2009-08-03 12:01:59.23")
103#' ceiling_date(x, ".1 sec") # imprecise representation at 0.1 sec !!!
104#' ceiling_date(x, "second")
105#' ceiling_date(x, "minute")
106#' ceiling_date(x, "5 mins")
107#' ceiling_date(x, "hour")
108#' ceiling_date(x, "day")
109#' ceiling_date(x, "week")
110#' ceiling_date(x, "month")
111#' ceiling_date(x, "bimonth") == ceiling_date(x, "2 months")
112#' ceiling_date(x, "quarter")
113#' ceiling_date(x, "season")
114#' ceiling_date(x, "halfyear")
115#' ceiling_date(x, "year")
116#'
117#' ## As of R 3.4.2 POSIXct printing of fractional numbers is wrong
118#' as.POSIXct("2009-08-03 12:01:59.3") ## -> "2009-08-03 12:01:59.2 CEST"
119#' ceiling_date(x, ".1 sec") ## -> "2009-08-03 12:01:59.2 CEST"
120#'
121#' ## behaviour of `change_on_boundary`
122#' ## As per default behaviour `NULL`, instants on the boundary remain the
123#' ## same but dates are rounded up
124#' ceiling_date(ymd_hms("2000-01-01 00:00:00"), "month")
125#' ceiling_date(ymd("2000-01-01"), "month")
126#'
127#' ## If `TRUE`, both instants and dates on the boundary are rounded up
128#' ceiling_date(ymd_hms("2000-01-01 00:00:00"), "month", change_on_boundary = TRUE)
129#' ceiling_date(ymd("2000-01-01"), "month")
130#'
131#' ## If `FALSE`, both instants and dates on the boundary remain the same
132#' ceiling_date(ymd_hms("2000-01-01 00:00:00"), "month", change_on_boundary = FALSE)
133#' ceiling_date(ymd("2000-01-01"), "month")
134#'
135
136#' @export
137round_date <- function(x, unit = "second", week_start = getOption("lubridate.week.start", 7)) {
138
139  if (!length(x)) return(x)
140
141  parsed_unit <- parse_period_unit(unit)
142  n <- parsed_unit$n
143  basic_unit <- standardise_period_names(parsed_unit$unit)
144
145  new <-
146    if (n == 1 && basic_unit %in% c("second", "minute", "hour", "day")) {
147      ## special case for fast rounding
148      round.POSIXt(as_datetime(x, tz = tz(x)), units = lub2base_units[[basic_unit]])
149    } else {
150      above <- unclass(as.POSIXct(ceiling_date(x, unit = unit, week_start = week_start)))
151      mid <- unclass(x)
152      below <- unclass(as.POSIXct(floor_date(x, unit = unit, week_start = week_start)))
153      wabove <- (above - mid) <= (mid - below)
154      wabove <- !is.na(wabove) & wabove
155      new <- below
156      new[wabove] <- above[wabove]
157      .POSIXct(new, tz = tz(x))
158    }
159
160  reclass_date_maybe(new, x, unit)
161}
162
163reclass_date_maybe <- function(new, orig, unit) {
164  if (is.Date(orig) && !unit %in% c("day", "week", "month", "year")) as.POSIXct(new)
165  else reclass_date(new, orig)
166}
167
168#' @description
169#' `floor_date()` takes a date-time object and rounds it down to the nearest
170#' boundary of the specified time unit.
171#' @rdname round_date
172#' @export
173floor_date <- function(x, unit = "seconds", week_start = getOption("lubridate.week.start", 7)) {
174  if (!length(x)) return(x)
175
176  parsed_unit <- parse_period_unit(unit)
177  n <- parsed_unit$n
178  unit <- standardise_period_names(parsed_unit$unit)
179
180  if (unit %in% c("second", "minute", "hour", "day")) {
181
182    # as_datetime is necesary for correct tz = UTC when x is Date
183    out <- trunc_multi_unit(as_datetime(x, tz = tz(x)), unit, n)
184    reclass_date_maybe(out, x, unit)
185
186  } else {
187
188    if (n > 1 && unit == "week") {
189      ## fixme:
190      warning("Multi-unit not supported for weeks. Ignoring.")
191    }
192
193    if (unit %in% c("bimonth", "quarter", "halfyear", "season") ||
194       (n > 1 && unit == "month")) {
195      new_months <-
196        switch(unit,
197               month    = floor_multi_unit1(month(x), n),
198               bimonth  = floor_multi_unit1(month(x), 2 * n),
199               quarter  = floor_multi_unit1(month(x), 3 * n),
200               halfyear = floor_multi_unit1(month(x), 6 * n),
201               season   = floor_multi_unit(month(x), 3 * n))
202      n <- Inf
203      unit <- "month"
204    }
205
206    switch(unit,
207           week     = update(x, wdays = 1, hours = 0, minutes = 0, seconds = 0, week_start = week_start),
208           month    = {
209             if (n > 1) update(x, months = new_months, mdays = 1, hours = 0, minutes = 0, seconds = 0)
210             else      update(x, mdays = 1, hours = 0, minutes = 0, seconds = 0)
211           },
212           year     = {
213             ## due to bug https://github.com/tidyverse/lubridate/issues/319 we
214             ## need to do it in two steps
215             if (n > 1) {
216               y <- update(x, ydays = 1, hours = 0, minutes = 0, seconds = 0)
217               update(y, years = floor_multi_unit(year(y), n))
218             } else {
219               update(x, ydays = 1, hours = 0, minutes = 0, seconds = 0)
220             }
221           })
222  }
223}
224
225#' @description
226#' `ceiling_date()` takes a date-time object and rounds it up to the nearest
227#' boundary of the specified time unit.
228#' @rdname round_date
229#' @export
230#' @examples
231#'
232#'  x <- ymd_hms("2000-01-01 00:00:00")
233#'  ceiling_date(x, "month")
234#'  ceiling_date(x, "month", change_on_boundary = TRUE)
235#'
236#'  ## For Date objects first day of the month is not on the
237#'  ## "boundary". change_on_boundary applies to instants only.
238#'  x <- ymd("2000-01-01")
239#'  ceiling_date(x, "month")
240#'  ceiling_date(x, "month", change_on_boundary = TRUE)
241ceiling_date <- function(x, unit = "seconds", change_on_boundary = NULL, week_start = getOption("lubridate.week.start", 7)) {
242
243  if (!length(x))
244    return(x)
245
246  parsed_unit <- parse_period_unit(unit)
247  n <- parsed_unit$n
248  unit <- standardise_period_names(parsed_unit$unit)
249
250  if (is.null(change_on_boundary)) {
251    change_on_boundary <- is.Date(x)
252  }
253
254  if (unit == "second") {
255
256    new <- as_datetime(x, tz = tz(x))
257    sec <- second(new)
258    csec <- ceil_multi_unit(sec, n)
259    if (!change_on_boundary) {
260      wsec <- which(csec - n ==  sec)
261      if (length(wsec))
262        csec[wsec] <- sec[wsec]
263    }
264    update(new, seconds = csec, simple = T)
265
266  } else if (unit %in% c("minute", "hour")) {
267
268    ## as_datetime converts Date to POSIXct with tz=UTC
269    new <- as_datetime(x, tz = tz(x))
270    delta <- switch(unit, minute = 60, hour = 3600, day = 86400) * n
271    new <-
272      if (change_on_boundary) {
273        trunc_multi_unit(new, unit, n) + delta
274      } else {
275        new1 <- trunc_multi_unit(new, unit, n)
276        not_same <- which(new1 != new)
277        new1[not_same] <- new1[not_same] + delta
278        new1
279      }
280    reclass_date_maybe(new, x, unit)
281
282  } else {
283
284    if (n > 1 && unit == "week") {
285      warning("Multi-unit not supported for weeks. Ignoring.")
286    }
287
288    ## need this to accomodate the case when date is on a boundary
289    new <-
290      if (change_on_boundary) x
291      else update(x, seconds = second(x) - 0.00001, simple = T)
292
293    if (unit %in% c("month", "bimonth", "quarter", "halfyear", "season")) {
294      new_month <-
295        switch(unit,
296               month    = ceil_multi_unit1(month(new), n),
297               bimonth  = ceil_multi_unit1(month(new), 2 * n),
298               quarter  = ceil_multi_unit1(month(new), 3 * n),
299               halfyear = ceil_multi_unit1(month(new), 6 * n),
300               season   = ceil_multi_unit(month(new), 3 * n))
301      unit <- "month"
302    }
303
304    new <- switch(unit,
305                  minute = update(new, minutes = ceil_multi_unit(minute(new), n), seconds = 0, simple = T),
306                  hour   = update(new, hours = ceil_multi_unit(hour(new), n), minutes = 0, seconds = 0, simple = T),
307                  day    = update(new, days = ceil_multi_unit1(day(new), n), hours = 0, minutes = 0, seconds = 0),
308                  week   = update(new, wdays = 8, hours = 0, minutes = 0, seconds = 0, week_start = week_start),
309                  month  = update(new, months = new_month, mdays = 1, hours = 0, minutes = 0, seconds = 0),
310                  year   = update(new, years = ceil_multi_unit(year(new), n), months = 1, mdays = 1, hours = 0, minutes = 0, seconds = 0))
311
312    reclass_date_maybe(new, x, unit)
313  }
314}
315
316trunc_multi_limits <- c(second = 60L, minute = 60L, hour = 24, day = 31)
317
318trunc_multi_unit <- function(x, unit, n) {
319  x <- as.POSIXlt(x)
320  if (n > trunc_multi_limits[[unit]])
321    stop(sprintf("Rounding with %s > %d is not supported", unit, trunc_multi_limits[[unit]]))
322
323  switch(unit,
324         second = {
325           x$sec <- if (n == 1) trunc(x$sec) else floor_multi_unit(x$sec, n)
326         },
327         minute = {
328           x$sec[] <- 0
329           x$min <- floor_multi_unit(x$min, n)
330         },
331         hour = {
332           x$sec[] <- 0
333           x$min[] <- 0L
334           x$hour <- floor_multi_unit(x$hour, n)
335         },
336         day = {
337           x$sec[] <- 0
338           x$min[] <- 0L
339           x$hour[] <- 0L
340           x$isdst[] <- -1L
341           x$mday <- floor_multi_unit1(x$mday, n)
342         },
343         stop("Invalid unit ", unit))
344  x
345}
346
347floor_multi_unit <- function(x, n) {
348  (x %/% n) * n
349}
350
351floor_multi_unit1 <- function(x, n) {
352  (((x - 1) %/% n) * n) + 1L
353}
354
355ceil_multi_unit <- function(x, n) {
356  (x %/% n) * n + n
357}
358
359ceil_multi_unit1 <- function(x, n) {
360  (((x - 1) %/% n) *  n) + n + 1L
361}
362