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