1
2# This R package is free software; you can redistribute it and/or
3# modify it under the terms of the GNU Library General Public
4# License as published by the Free Software Foundation; either
5# version 2 of the License, or (at your option) any later version.
6#
7# This R package is distributed in the hope that it will be useful,
8# but WITHOUT ANY WARRANTY; without even the implied warranty of
9# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10# GNU Library General Public License for more details.
11#
12# You should have received a copy of the GNU Library General
13# Public License along with this R package; if not, write to the
14# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
15# MA  02111-1307  USA
16
17
18################################################################################
19# FUNCTION:                 DESCRIPTION:
20#  timeNdayOnOrAfter         Computes date in month that is a n-day ON OR AFTER
21#  timeNdayOnOrBefore        Computes date in month that is a n-day ON OR BEFORE
22# DEPRECATED:
23#  .on.or.after
24#  .on.or.before
25#  .nth.of.nday
26#  .sdate
27#  .month.day.year
28#  .sjulian
29#  .JULIAN
30#  .sday.of.week
31#  .day.of.week
32#  .sleap.year
33################################################################################
34
35# ---------------------------------------------------------------------------- #
36# Roxygen Tags
37#' @export
38# ---------------------------------------------------------------------------- #
39timeNdayOnOrAfter <-
40    function(charvec, nday = 1, format = "%Y-%m-%d", zone = "", FinCenter = "")
41{
42    # A function implemented by Diethelm Wuertz
43
44    # Description:
45    #   Computes date in month that is a n-day ON OR AFTER
46
47    # Arguments:
48    #   charvec - a character vector of dates and times.
49    #   nday - an integer vector with entries ranging from
50    #       0 (Sunday) to 6 (Saturday).
51    #   format - the format specification of the input character
52    #       vector.
53    #   FinCenter - a character string with the the location of the
54    #       financial center named as "continent/city".
55
56    # Value:
57    #   Returns the date in month that is a n-day ON OR AFTER as
58    #   a 'timeDate' object.
59
60    # Details:
61    #   nday = 1 is a Monday
62
63    # Example:
64    #   What date has the first Monday on or after March 15, 1986?
65    #   timeNdayOnOrAfter("1986-03-15", 1)
66
67    # Changes:
68    #
69
70    # FUNCTION:
71    if (zone == "")
72        zone <- getRmetricsOptions("myFinCenter")
73    if (FinCenter == "")
74        FinCenter <- getRmetricsOptions("myFinCenter")
75
76    # timeDate:
77    lt <- strptime(charvec, format, tz = "GMT")
78
79    # On or after:
80    ct <- 24*3600*(as.integer(julian.POSIXt(lt)) + (nday-lt$wday) %% 7)
81    class(ct) <- "POSIXct"
82
83    # Return Value:
84    timeDate(format(ct), format = format, zone = zone, FinCenter = FinCenter)
85}
86
87
88# ---------------------------------------------------------------------------- #
89# Roxygen Tags
90#' @export
91# ---------------------------------------------------------------------------- #
92timeNdayOnOrBefore <-
93    function(charvec, nday = 1, format = "%Y-%m-%d", zone = "", FinCenter = "")
94{
95    # A function implemented by Diethelm Wuertz
96
97    # Description:
98    #   Computes date in month that is a n-day ON OR BEFORE
99
100    # Arguments:
101    #   charvec - a character vector of dates and times.
102    #   nday - an integer vector with entries ranging from
103    #       0 (Sunday) to 6 (Saturday).
104    #   format - the format specification of the input character
105    #       vector.
106    #   FinCenter - a character string with the the location of the
107    #       financial center named as "continent/city".
108
109    # Value:
110    #   Returns the date in month that is a n-day ON OR BEFORE
111    #   as a 'timeDate' object.
112
113    # Example:
114    #   What date has Friday on or before April 22, 1977?
115
116    # FUNCTION:
117    if (zone == "")
118        zone <- getRmetricsOptions("myFinCenter")
119    if (FinCenter == "")
120        FinCenter <- getRmetricsOptions("myFinCenter")
121
122    # timeDate:
123    lt <- strptime(charvec, format, tz = "GMT")
124
125    # On or after:
126    ct <- 24*3600*(as.integer(julian.POSIXt(lt)) - (-(nday-lt$wday)) %% 7)
127    class(ct) <- "POSIXct"
128
129    # Return Value:
130    timeDate(format(ct), format = format, zone = zone,
131        FinCenter = FinCenter)
132}
133
134
135################################################################################
136# Internal Functions
137
138
139## DW
140##  These are relicts from very old times
141##  We should check where these function are needed and if we should
142##  replace them with 'timeDate' objects ...
143
144# ---------------------------------------------------------------------------- #
145# Roxygen Tags
146#' @export
147# ---------------------------------------------------------------------------- #
148.on.or.after <-
149function(year, month, day, nday)
150{
151    .sdate <- year*10000+month*100+day
152    .sdate(.sjulian(.sdate)+(nday-.day.of.week(month, day, year)) %% 7)
153}
154
155# ---------------------------------------------------------------------------- #
156# Roxygen Tags
157#' @export
158# ---------------------------------------------------------------------------- #
159.on.or.before <-
160function(year, month, day, nday)
161{
162    .sdate <- year*10000+month*100+day
163    .sdate(.sjulian(.sdate)-(-(nday-.day.of.week(month,day,year))) %% 7)
164}
165
166# ---------------------------------------------------------------------------- #
167# Roxygen Tags
168#' @export
169# ---------------------------------------------------------------------------- #
170.nth.of.nday <-
171function(year, month, nday, nth)
172{
173    .sdate <- year*10000+month*100+1
174    .sdate(.sjulian(.sdate)+(nth-1)*7+(nday-.day.of.week(month,1,year)) %% 7)
175}
176
177# ---------------------------------------------------------------------------- #
178# Roxygen Tags
179#' @export
180# ---------------------------------------------------------------------------- #
181.last.of.nday <-
182function(year, month, lastday, nday)
183{
184    .sdate <- year*10000 + month*100 + lastday
185    .sdate(.sjulian(.sdate)-(-(nday-.day.of.week(month,lastday,year))) %% 7)
186}
187
188# ---------------------------------------------------------------------------- #
189# Roxygen Tags
190#' @export
191# ---------------------------------------------------------------------------- #
192.sdate <-
193function (julians, origin = 19600101)
194{
195    year0 <- origin %/% 10000
196    month0 <- (origin-10000*year0) %/% 100
197    day0 <- origin-10000*year0-100*month0
198    mdylist <- .month.day.year(julians, origin = c(month0, day0, year0))
199    ans <- mdylist$year*10000 + mdylist$month*100 + mdylist$day
200    class(ans) <- ".sdate"
201    ans
202}
203
204# ---------------------------------------------------------------------------- #
205# Roxygen Tags
206#' @export
207# ---------------------------------------------------------------------------- #
208.month.day.year <-
209function(jul, origin = c(1, 1, 1960))
210{
211    # shift = .julian(1, 1, 1960, 0)
212    shift <- 2436935
213    j <- jul + shift
214    j <- j - 1721119
215    y <- (4 * j - 1) %/% 146097
216    j <- 4 * j - 1 - 146097 * y
217    d <- j %/% 4
218    j <- (4 * d + 3) %/% 1461
219    d <- 4 * d + 3 - 1461 * j
220    d <- (d + 4) %/% 4
221    m <- (5 * d - 3) %/% 153
222    d <- 5 * d - 3 - 153 * m
223    d <- (d + 5) %/% 5
224    y <- 100 * y + j
225    y <- y + ifelse(m < 10, 0, 1)
226    m <- m + ifelse(m < 10, 3, -9)
227    list(month = m, day = d, year = y)
228}
229
230# ---------------------------------------------------------------------------- #
231# Roxygen Tags
232#' @export
233# ---------------------------------------------------------------------------- #
234.sjulian <-
235function (.sdates, origin = 19600101)
236{
237    if(is(.sdates, ".sdate"))
238        .sdates <- as.vector(.sdates)
239    year <- .sdates %/% 10000
240    month <- (.sdates-10000*year) %/% 100
241    day <- .sdates-10000*year-100*month
242    year0 <- origin %/% 10000
243    month0 <- (origin-10000*year0) %/% 100
244    day0 <- origin-10000*year0-100*month0
245    .JULIAN(month, day, year, origin = c(month0, day0, year0))
246}
247
248# ---------------------------------------------------------------------------- #
249# Roxygen Tags
250#' @export
251# ---------------------------------------------------------------------------- #
252.JULIAN <-
253function(m, d, y, origin = c(month = 1, day = 1, year = 1960))
254{
255    only.origin <- all(missing(m), missing(d), missing(y))
256    if (only.origin) m = d = y = NULL
257    nms <- names(d)
258    max.len <- max(length(m), length(d), length(y))
259    m <- c(origin[1], rep(m, length = max.len))
260    d <- c(origin[2], rep(d, length = max.len))
261    y <- c(origin[3], rep(y, length = max.len))
262    y <- y + ifelse(m > 2, 0, -1)
263    m <- m + ifelse(m > 2, -3, 9)
264    c <- y %/% 100
265    ya <- y - 100 * c
266    out <- (146097 * c) %/% 4 + (1461 * ya) %/% 4 +
267        (153 * m + 2) %/% 5 + d + 1721119
268    if (!only.origin) {
269        if(all(origin == 0)) out = out[-1] else out = out[-1] - out[1] }
270    names(out) = nms
271    out
272}
273
274# ---------------------------------------------------------------------------- #
275# Roxygen Tags
276#' @export
277# ---------------------------------------------------------------------------- #
278.sday.of.week <-
279function(.sdates)
280{
281    if(is(.sdates, ".sdate"))
282        .sdates <- as.vector(.sdates)
283    year <- .sdates %/% 10000
284    month <- .sdates %/% 100 - year*100
285    day <- .sdates - year*10000 - month*100
286    a <- (14-month) %/% 12
287    y <- year - a
288    m <- month + 12*a - 2
289    (day + y + y %/% 4 - y %/% 100 + y %/% 400 + (31*m) %/% 12) %% 7
290}
291
292# ---------------------------------------------------------------------------- #
293# Roxygen Tags
294#' @export
295# ---------------------------------------------------------------------------- #
296.day.of.week <-
297function (month, day, year)
298{
299    .sday.of.week(year * 10000 + month * 100 + day)
300}
301
302# ---------------------------------------------------------------------------- #
303# Roxygen Tags
304#' @export
305# ---------------------------------------------------------------------------- #
306.sleap.year <-
307function(.sdates)
308{
309    if(is(.sdates, ".sdate"))
310        .sdates <- as.vector(.sdates)
311    year <- .sdates %/% 10000
312    year %% 4 == 0 & (year %% 100 != 0 | year %% 400 == 0)
313}
314
315
316################################################################################
317
318