1#' @include timespans.r
2#' @include durations.r
3#' @include intervals.r
4#' @include periods.r
5#' @include Dates.r
6#' @include difftimes.r
7#' @include numeric.r
8#' @include POSIXt.r
9#' @include ops-addition.r
10NULL
11
12#' Add and subtract months to a date without exceeding the last day of the new month
13#'
14#' Adding months frustrates basic arithmetic because consecutive months have
15#' different lengths. With other elements, it is helpful for arithmetic to
16#' perform automatic roll over. For example, 12:00:00 + 61 seconds becomes
17#' 12:01:01. However, people often prefer that this behavior NOT occur with
18#' months. For example, we sometimes want January 31 + 1 month = February 28 and
19#' not March 3. \code{\%m+\%} performs this type of arithmetic. Date \code{\%m+\%} months(n)
20#' always returns a date in the nth month after Date. If the new date would
21#' usually spill over into the n + 1th month, \code{\%m+\%} will return the last day of
22#' the nth month ([rollback()]). Date \code{\%m-\%} months(n) always returns a
23#' date in the nth month before Date.
24#'
25#' \code{\%m+\%} and \code{\%m-\%} handle periods with components less than a month by first
26#' adding/subtracting months and then performing usual arithmetics with smaller
27#' units.
28#'
29#' \code{\%m+\%} and \code{\%m-\%} should be used with caution as they are not one-to-one
30#' operations and results for either will be sensitive to the order of
31#' operations.
32#'
33#' @rdname mplus
34#' @usage e1 \%m+\% e2
35#' @aliases m+ %m+% m- %m-% %m+%,ANY,ANY-method %m-%,ANY,ANY-method %m+%,Period,ANY-method %m+%,ANY,Period-method %m-%,Period,ANY-method %m-%,ANY,Period-method %m+%,Duration,ANY-method %m+%,ANY,Duration-method %m-%,Duration,ANY-method %m-%,ANY,Duration-method %m+%,Interval,ANY-method %m+%,ANY,Interval-method %m-%,Interval,ANY-method %m-%,ANY,Interval-method
36#' @param e1 A period or a date-time object of class [POSIXlt], [POSIXct]
37#' or [Date].
38#' @param e2 A period or a date-time object of class [POSIXlt], [POSIXct]
39#' or [Date]. Note that one of e1 and e2 must be a period and the other a
40#' date-time object.
41#' @return A date-time object of class POSIXlt, POSIXct or Date
42#' @examples
43#' jan <- ymd_hms("2010-01-31 03:04:05")
44#' jan + months(1:3) # Feb 31 and April 31 returned as NA
45#' # NA "2010-03-31 03:04:05 UTC" NA
46#' jan %m+% months(1:3) # No rollover
47#'
48#' leap <- ymd("2012-02-29")
49#' "2012-02-29 UTC"
50#' leap %m+% years(1)
51#' leap %m+% years(-1)
52#' leap %m-% years(1)
53#' @export
54"%m+%" <- function(e1, e2) standardGeneric("%m+%")
55
56#' @export
57setGeneric("%m+%")
58
59#' @export
60setMethod("%m+%", signature(e2 = "Period"),
61          function(e1, e2) add_with_rollback(e1, e2))
62
63#' @export
64setMethod("%m+%", signature(e1 = "Period"),
65          function(e1, e2) add_with_rollback(e2, e1))
66
67#' @export
68setMethod("%m+%", signature(e2 = "ANY"),
69          function(e1, e2)
70            stop("%m+% handles only Period objects as second argument"))
71
72#' @export
73"%m-%" <- function(e1, e2) standardGeneric("%m-%")
74
75#' @export
76setGeneric("%m-%")
77
78#' @export
79setMethod("%m-%", signature(e2 = "Period"),
80          function(e1, e2) add_with_rollback(e1, -e2))
81
82#' @export
83setMethod("%m-%", signature(e1 = "Period"),
84          function(e1, e2) add_with_rollback(e2, -e1))
85
86#' @export
87setMethod("%m-%", signature(e2 = "ANY"),
88          function(e1, e2)
89            stop("%m-% handles only Period objects as second argument"))
90
91#' `add_with_rollback()` is like \code{\%m+\%} and \code{\%m-\%} with more
92#' control over the rollback process. It allows the rollback to first day of the
93#' month instead of the last day of the previous month and controls whether HMS
94#' component of the end date is preserved or not. Please note that the rollback
95#' kicks in only when the resulting date lands on the non-existing date.
96#' @rdname mplus
97#' @param roll_to_first rollback to the first day of the month instead of the
98#'   last day of the previous month (passed to [rollback()])
99#' @param preserve_hms retains the same hour, minute, and second information? If
100#'   FALSE, the new date will be at 00:00:00 (passed to [rollback()])
101#' @examples
102#'
103#' x <- ymd_hms("2019-01-29 01:02:03")
104#' add_with_rollback(x, months(1))
105#' add_with_rollback(x, months(1), preserve_hms = FALSE)
106#' add_with_rollback(x, months(1), roll_to_first = TRUE)
107#' add_with_rollback(x, months(1), roll_to_first = TRUE, preserve_hms = FALSE)
108#' @export
109add_with_rollback <- function(e1, e2, roll_to_first = FALSE, preserve_hms = TRUE) {
110
111  any_HMS <- any(e2@.Data != 0) || any(e2@minute != 0) || any(e2@hour != 0) || any(e2@day != 0)
112  any_year <- any(e2@year != 0)
113  if (!is.na(any_year) && any_year) {
114    e2$month <- 12 * e2@year + e2@month
115    e2$year <- 0L
116  }
117
118  new <- .quick_month_add(e1, e2@month)
119  roll <- day(new) < day(e1)
120  roll <- !is.na(roll) & roll
121  new[roll] <- rollback(new[roll], roll_to_first = roll_to_first, preserve_hms = preserve_hms)
122
123  if (!is.na(any_HMS) && any_HMS) {
124    e2$month <- 0L
125    new + e2
126  } else {
127    new
128  }
129}
130
131.quick_month_add <- function(object, mval) {
132  tzs <- tz(object)
133  utc <- as.POSIXlt(force_tz(object, tzone = "UTC"))
134  utc$mon <- utc$mon + mval
135  utc <- as.POSIXct(utc)
136  new <- force_tz(utc, tzone = tzs, roll = TRUE)
137  reclass_date(new, object)
138}
139
140#' Roll backward or forward a date the previous, current or next month
141#'
142#' `rollbackward()` changes a date to the last day of the previous month or to
143#' the first day of the month. `rollforward()` rolls to the last day of the
144#' current month or to the first day of the next month. Optionally, the new date
145#' can retain the same hour, minute, and second information. `rollback()` is a
146#' synonym for `rollbackward()`.
147#'
148#' @export
149#' @param dates A POSIXct, POSIXlt or Date class object.
150#' @param roll_to_first Rollback to the first day of the month instead of the
151#' last day of the month
152#' @param preserve_hms Retains the same hour, minute, and second information? If
153#' FALSE, the new date will be at 00:00:00.
154#' @return A date-time object of class POSIXlt, POSIXct or Date, whose day has
155#' been adjusted to the last day of the previous month, or to the first day of
156#' the month.
157#' @examples
158#' date <- ymd("2010-03-03")
159#' rollbackward(date)
160#'
161#' dates <- date + months(0:2)
162#' rollbackward(dates)
163#'
164#' date <- ymd_hms("2010-03-03 12:44:22")
165#' rollbackward(date)
166#' rollbackward(date, roll_to_first = TRUE)
167#' rollbackward(date, preserve_hms = FALSE)
168#' rollbackward(date, roll_to_first = TRUE, preserve_hms = FALSE)
169rollbackward <- function(dates, roll_to_first = FALSE, preserve_hms = TRUE) {
170  .roll(dates, roll_to_first, preserve_hms)
171}
172
173#' @rdname rollbackward
174#' @export
175rollback <- rollbackward
176
177#' @rdname rollbackward
178#' @export
179rollforward <- function(dates, roll_to_first = FALSE, preserve_hms = TRUE) {
180  .roll(dates, roll_to_first, preserve_hms, forward = TRUE)
181}
182
183.roll <- function(dates, roll_to_first, preserve_hms, forward = FALSE) {
184  if (length(dates) == 0)
185    return(dates)
186  day(dates) <- 1
187  if (!preserve_hms) {
188    hour(dates) <- 0
189    minute(dates) <- 0
190    second(dates) <- 0
191  }
192  if (forward) {
193    dates <- dates + months(1)
194  }
195  if (roll_to_first) {
196    dates
197  } else {
198    dates - days(1)
199  }
200}
201