[#509] Add week_start to rounding functions

NEWS.md

@@ -2,31 +2,32 @@ Version 1.6.0.9000
 ==================
 
 ### NEW FEATURES
+* [#257](https://github.com/hadley/lubridate/issues/257) New `start` parameter in `wday` and `wday<-` to set week start.
+* [#401](https://github.com/hadley/lubridate/issues/401) New parameter `locale` in `wday`. Labels of the returned factors (when `label=TRUE`) now respect current locale.
+* [#485](https://github.com/hadley/lubridate/pull/485) `quarter` gained a new argument `fiscal_start` to address the issue of different fiscal conventions.
+* [#492](https://github.com/hadley/lubridate/issues/492) New functions `epiweek` and `epiyear`.
+* [#508](https://github.com/hadley/lubridate/pull/508) New parameter `locale` in `month`. Labels of the returned factors (when `label=TRUE`) now respect current locale.
+* [#509](https://github.com/hadley/lubridate/issues/509) New parameter `week_start` to `floor_date`, `ceiling_date` and `round_date`.
+* [#519](https://github.com/hadley/lubridate/issues/519) Support fractional units in duration and period string constructors.
+* [#529](https://github.com/hadley/lubridate/issues/529) Internal parser now ignores the case of alpha months (B format)
+* [#535](https://github.com/hadley/lubridate/issues/535) Rounding to `season` is now supported.
+* [#536](https://github.com/hadley/lubridate/issues/536) `as_date` and `as_datetime` now understand character vectors.
 * New parsing parameters to `parse_date_time` - `train=TRUE` and `drop=FALSE`
   which allow more refined control of the format guessing. Formats are no longer
   droped in the process by default, process which resulted in surprising
   behavior on several occasions ([#516](https://github.com/hadley/lubridate/issues/516),[#308](https://github.com/hadley/lubridate/issues/308),[#307](https://github.com/hadley/lubridate/issues/307)).
-* [#529](https://github.com/hadley/lubridate/issues/529) Internal parser now ignores the case of alpha months (B format)
-* [#535](https://github.com/hadley/lubridate/issues/535) Rounding to `season` is now supported.
-* [#536](https://github.com/hadley/lubridate/issues/536) `as_date` and `as_datetime` now understand character vectors.
-* [#519](https://github.com/hadley/lubridate/issues/519) Support fractional units in duration and period string constructors.
-* [#508](https://github.com/hadley/lubridate/pull/508) New parameter `locale` in `month`. Labels of the returned factors (when `label=TRUE`) now respect current locale.
-* [#485](https://github.com/hadley/lubridate/pull/485) `quarter` gained a new argument `fiscal_start` to address the issue of different fiscal conventions.
-* [#492](https://github.com/hadley/lubridate/issues/492) New functions `epiweek` and `epiyear`.
-* [#257](https://github.com/hadley/lubridate/issues/257) New `start` parameter in `wday` and `wday<-` to set week start.
-* [#401](https://github.com/hadley/lubridate/issues/401) New parameter `locale` in `wday`. Labels of the returned factors (when `label=TRUE`) now respect current locale.
 
 ### BUG FIXES
-* [#530](https://github.com/hadley/lubridate/issues/530) `parse_date_time` now throw warnings only for actual parsing errors (input with all NAs are silent)
-* [#534](https://github.com/hadley/lubridate/issues/534) Fix arithmetics with large numbers
-* [#507](https://github.com/hadley/lubridate/issues/507) Period and duration parsers now understand 0 units.
 * [#466](https://github.com/hadley/lubridate/pull/466) Fix wrong formats within ymd_h family of functions.
 * [#472](https://github.com/hadley/lubridate/pull/472) Printing method for duration doesn't throw format error on fractional seconds.
 * [#475](https://github.com/hadley/lubridate/pull/475) character<> comparisons is no longer slow.
-* [#486](https://github.com/hadley/lubridate/issues/486) ceiling_date handles `NA` properly.
 * [#483](https://github.com/hadley/lubridate/pull/483) Fix add_duration_to_date error when duration first element is NA.
+* [#486](https://github.com/hadley/lubridate/issues/486) ceiling_date handles `NA` properly.
+* [#507](https://github.com/hadley/lubridate/issues/507) Period and duration parsers now understand 0 units.
 * [#524](https://github.com/hadley/lubridate/pull/524) Correctly compute length of period in months (issue #490)
 * [#525](https://github.com/hadley/lubridate/pull/525) Fix to prevent `day<-`, `minute<-`, etc. from producing an error when length(x) is 0 (issue #517)
+* [#530](https://github.com/hadley/lubridate/issues/530) `parse_date_time` now throw warnings only for actual parsing errors (input with all NAs are silent)
+* [#534](https://github.com/hadley/lubridate/issues/534) Fix arithmetics with large numbers
 
 Version 1.6.0
 =============

R/RcppExports.R

@@ -1,8 +1,8 @@
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
-C_update_dt <- function(dt, year, month, yday, mday, wday, hour, minute, second, tz = NULL, roll = FALSE) {
-    .Call('lubridate_C_update_dt', PACKAGE = 'lubridate', dt, year, month, yday, mday, wday, hour, minute, second, tz, roll)
+C_update_dt <- function(dt, year, month, yday, mday, wday, hour, minute, second, tz = NULL, roll = FALSE, week_start = 7L) {
+    .Call('lubridate_C_update_dt', PACKAGE = 'lubridate', dt, year, month, yday, mday, wday, hour, minute, second, tz, roll, week_start)
 }
 
 C_force_tz <- function(dt, tz, roll = FALSE) {

R/durations.r

@@ -178,7 +178,7 @@ setMethod("[[<-", signature(x = "Duration"),
 #' @param x numeric value of the number of units to be contained in the
 #'   duration.
 #' @return a duration object
-#' @seealso [as.duration()] [Duration.class]
+#' @seealso [as.duration()] [Duration-class]
 #' @keywords chron classes
 #' @examples
 #'

R/parse.r

@@ -559,7 +559,7 @@ hms <- function(..., quiet = FALSE, roll = FALSE) {
 ##'
 ##' ## to give priority to %y format, define your own select_format function:
 ##'
-##' my_select <-   function(trained){
+##' my_select <-   function(trained, drop=FALSE, ...){
 ##'    n_fmts <- nchar(gsub("[^%]", "", names(trained))) + grepl("%y", names(trained))*1.5
 ##'    names(trained[ which.max(n_fmts) ])
 ##' }

R/round.r

@@ -56,6 +56,7 @@
 #'   `FALSE`, date-time on the boundary are never rounded up (this was the
 #'   default for \pkg{lubridate} prior to `v1.6.0`. See section `Rounding Up
 #'   Date Objects` below for more details.
+#' @param week_start when unit is `weeks` specify the reference day; 7 being Sunday.
 #' @keywords manip chron
 #' @seealso [base::round()]
 #' @examples
@@ -100,7 +101,7 @@
 #' ceiling_date(x, "halfyear")
 #' ceiling_date(x, "year")
 #' @export
-round_date <- function(x, unit = "second") {
+round_date <- function(x, unit = "second", week_start = getOption("lubridate.week.start", 7)) {
 
   if(!length(x)) return(x)
 
@@ -136,7 +137,7 @@ reclass_date_maybe <- function(new, orig, unit){
 #' boundary of the specified time unit.
 #' @rdname round_date
 #' @export
-floor_date <- function(x, unit = "seconds") {
+floor_date <- function(x, unit = "seconds", week_start = getOption("lubridate.week.start", 7)) {
   if(!length(x)) return(x)
 
   parsed_unit <- parse_period_unit(unit)
@@ -169,7 +170,7 @@ floor_date <- function(x, unit = "seconds") {
     }
 
     switch(unit,
-           week     = update(x, wdays = 1, hours = 0, minutes = 0, seconds = 0),
+           week     = update(x, wdays = 1, hours = 0, minutes = 0, seconds = 0, week_start = week_start),
            month    = {
              if(n > 1) update(x, months = new_months, mdays = 1, hours = 0, minutes = 0, seconds = 0)
              else      update(x, mdays = 1, hours = 0, minutes = 0, seconds = 0)
@@ -196,7 +197,7 @@ floor_date <- function(x, unit = "seconds") {
 #' x <- ymd("2000-01-01")
 #' ceiling_date(x, "month")
 #' ceiling_date(x, "month", change_on_boundary = TRUE)
-ceiling_date <- function(x, unit = "seconds", change_on_boundary = NULL) {
+ceiling_date <- function(x, unit = "seconds", change_on_boundary = NULL, week_start = getOption("lubridate.week.start", 7)) {
 
   if(!length(x))
     return(x)
@@ -262,7 +263,7 @@ ceiling_date <- function(x, unit = "seconds", change_on_boundary = NULL) {
     new <- switch(unit,
                   minute = update(new, minute = ceil_multi_unit(minute(new), n), second = 0, simple = T),
                   hour   = update(new, hour = ceil_multi_unit(hour(new), n), minute = 0, second = 0, simple = T),
-                  week   = update(new, wday = 8, hour = 0, minute = 0, second = 0),
+                  week   = update(new, wday = 8, hour = 0, minute = 0, second = 0, week_start = week_start),
                   month  = update(new, month = new_month, mdays = 1, hours = 0, minutes = 0, seconds = 0),
                   year   = update(new, year = ceil_multi_unit(year(new), n), month = 1, mday = 1,  hour = 0, minute = 0, second = 0))
 

R/update.r

@@ -6,14 +6,16 @@
 #' substitute them for the appropriate parts of the existing date.
 #'
 #'
-#' @name DateUpdate
+#' @name DateTimeUpdate
 #' @param object a date-time object
 #' @param ... named arguments: years, months, ydays, wdays, mdays, days, hours,
 #'   minutes, seconds, tzs (time zone compnent)
 #' @param roll logical. If `TRUE`, and the resulting date-time lands on a
 #'   non-existent civil time instant (DST, 29th February, etc.) roll the date
 #'   till next valid point. When `FALSE`, the default, produce NA for non
 #'   existing date-times.
+#' @param week_start week starting day (Default is 7, Sunday). Set
+#'   `lubridate.week.start` option to control this.
 #' @param simple logical. Deprecated. Same as `roll`.
 #' @return a date object with the requested elements updated. The object will
 #'   retain its original class unless an element is updated which the original

src/RcppExports.cpp

@@ -6,8 +6,8 @@
 using namespace Rcpp;
 
 // C_update_dt
-Rcpp::newDatetimeVector C_update_dt(const Rcpp::NumericVector& dt, const Rcpp::IntegerVector& year, const Rcpp::IntegerVector& month, const Rcpp::IntegerVector& yday, const Rcpp::IntegerVector& mday, const Rcpp::IntegerVector& wday, const Rcpp::IntegerVector& hour, const Rcpp::IntegerVector& minute, const Rcpp::NumericVector& second, const SEXP tz, const bool roll);
-RcppExport SEXP lubridate_C_update_dt(SEXP dtSEXP, SEXP yearSEXP, SEXP monthSEXP, SEXP ydaySEXP, SEXP mdaySEXP, SEXP wdaySEXP, SEXP hourSEXP, SEXP minuteSEXP, SEXP secondSEXP, SEXP tzSEXP, SEXP rollSEXP) {
+Rcpp::newDatetimeVector C_update_dt(const Rcpp::NumericVector& dt, const Rcpp::IntegerVector& year, const Rcpp::IntegerVector& month, const Rcpp::IntegerVector& yday, const Rcpp::IntegerVector& mday, const Rcpp::IntegerVector& wday, const Rcpp::IntegerVector& hour, const Rcpp::IntegerVector& minute, const Rcpp::NumericVector& second, const SEXP tz, const bool roll, const int week_start);
+RcppExport SEXP lubridate_C_update_dt(SEXP dtSEXP, SEXP yearSEXP, SEXP monthSEXP, SEXP ydaySEXP, SEXP mdaySEXP, SEXP wdaySEXP, SEXP hourSEXP, SEXP minuteSEXP, SEXP secondSEXP, SEXP tzSEXP, SEXP rollSEXP, SEXP week_startSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::RNGScope rcpp_rngScope_gen;
@@ -22,7 +22,8 @@ BEGIN_RCPP
     Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type second(secondSEXP);
     Rcpp::traits::input_parameter< const SEXP >::type tz(tzSEXP);
     Rcpp::traits::input_parameter< const bool >::type roll(rollSEXP);
-    rcpp_result_gen = Rcpp::wrap(C_update_dt(dt, year, month, yday, mday, wday, hour, minute, second, tz, roll));
+    Rcpp::traits::input_parameter< const int >::type week_start(week_startSEXP);
+    rcpp_result_gen = Rcpp::wrap(C_update_dt(dt, year, month, yday, mday, wday, hour, minute, second, tz, roll, week_start));
     return rcpp_result_gen;
 END_RCPP
 }

src/update.cpp

@@ -61,7 +61,8 @@ Rcpp::newDatetimeVector C_update_dt(const Rcpp::NumericVector& dt,
                                     const Rcpp::IntegerVector& minute,
                                     const Rcpp::NumericVector& second,
                                     const SEXP tz = R_NilValue,
-                                    const bool roll = false) {
+                                    const bool roll = false,
+                                    const int week_start = 7) {
 
   if (dt.size() == 0) return(Rcpp::newDatetimeVector(dt));
 
@@ -153,8 +154,8 @@ Rcpp::newDatetimeVector C_update_dt(const Rcpp::NumericVector& dt,
         if (loop_yday) d += yday[i]; else d += yday[0];
       }
       if (do_wday) {
-        // wday is 1 based and starts on Sunday
-        int cur_wday = (static_cast<int>(cctz::get_weekday(cctz::civil_day(ct1))) + 1) % 7;
+        // wday is 1 based and starts on week_start
+        int cur_wday = (static_cast<int>(cctz::get_weekday(cctz::civil_day(ct1))) + 8 - week_start) % 7;
         d = d - cur_wday - 1;
         if (loop_wday) d += wday[i]; else d += wday[0];
       }

tests/testthat/test-round.R

@@ -393,3 +393,46 @@ test_that("ceiling_date works for seasons", {
   dts <- force_tz(dts, "America/New_York")
   expect_equal(month(ceiling_date(dts, "season")), c(3, 3, 6, 6, 6, 9, 9, 9, 12, 12, 12, 3))
 })
+
+
+test_that("round on week respects week_start",{
+  date <- ymd("2017-05-07") ## sunday
+  ct <- as.POSIXct("2010-02-03 13:45:59", tz = "America/New_York", format = "%Y-%m-%d %H:%M:%S") ## Wednesday
+
+  expect_equal(wday(floor_date(ct, "week", week_start = 1)), 2)
+  expect_equal(wday(floor_date(ct, "week", week_start = 2)), 3)
+  expect_equal(wday(floor_date(ct, "week", week_start = 5)), 6)
+  expect_equal(wday(floor_date(ct, "week", week_start = 7)), 1)
+  expect_equal(wday(floor_date(date, "week", week_start = 1)), 2)
+  expect_equal(wday(floor_date(date, "week", week_start = 2)), 3)
+  expect_equal(wday(floor_date(date, "week", week_start = 5)), 6)
+  expect_equal(wday(floor_date(date, "week", week_start = 7)), 1)
+
+  expect_equal(wday(floor_date(ct, "week", week_start = 1), start = 1), 1)
+  expect_equal(wday(floor_date(ct, "week", week_start = 2), start = 2), 1)
+  expect_equal(wday(floor_date(ct, "week", week_start = 5), start = 5), 1)
+  expect_equal(wday(floor_date(ct, "week", week_start = 7), start = 7), 1)
+  expect_equal(wday(floor_date(date, "week", week_start = 1), start = 1), 1)
+  expect_equal(wday(floor_date(date, "week", week_start = 2), start = 2), 1)
+  expect_equal(wday(floor_date(date, "week", week_start = 5), start = 5), 1)
+  expect_equal(wday(floor_date(date, "week", week_start = 7), start = 7), 1)
+
+  expect_equal(wday(ceiling_date(ct, "week", week_start = 1)), 2)
+  expect_equal(wday(ceiling_date(ct, "week", week_start = 2)), 3)
+  expect_equal(wday(ceiling_date(ct, "week", week_start = 5)), 6)
+  expect_equal(wday(ceiling_date(ct, "week", week_start = 7)), 1)
+  expect_equal(wday(ceiling_date(date, "week", week_start = 1)), 2)
+  expect_equal(wday(ceiling_date(date, "week", week_start = 2)), 3)
+  expect_equal(wday(ceiling_date(date, "week", week_start = 5)), 6)
+  expect_equal(wday(ceiling_date(date, "week", week_start = 7)), 1)
+
+  expect_equal(wday(ceiling_date(ct, "week", week_start = 1), start = 1), 1)
+  expect_equal(wday(ceiling_date(ct, "week", week_start = 2), start = 2), 1)
+  expect_equal(wday(ceiling_date(ct, "week", week_start = 5), start = 5), 1)
+  expect_equal(wday(ceiling_date(ct, "week", week_start = 7), start = 7), 1)
+  expect_equal(wday(ceiling_date(date, "week", week_start = 1), start = 1), 1)
+  expect_equal(wday(ceiling_date(date, "week", week_start = 2), start = 2), 1)
+  expect_equal(wday(ceiling_date(date, "week", week_start = 5), start = 5), 1)
+  expect_equal(wday(ceiling_date(date, "week", week_start = 7), start = 7), 1)
+
+})