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