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: GENERATION OF TIMEDATE OBJECTS: 20# timeSequence Creates a regularly spaced 'timeDate' object 21# seq.timeDate A synonyme function for timeSequence 22################################################################################ 23 24# ---------------------------------------------------------------------------- # 25# Roxygen Tags 26#' @export 27# ---------------------------------------------------------------------------- # 28timeSequence <- 29 function(from, to = Sys.timeDate(), by, length.out = NULL, format = NULL, 30 zone = "", FinCenter = "") 31{ 32 # A function implemented by Diethelm Wuertz 33 34 # Description: 35 # Creates a regularly spaced 'timeDate' object 36 37 # Arguments: 38 # from - starting date. 39 # to - end date. Optional. If supplied must be after from. 40 # by - a character string, containing one of "sec", "min", 41 # "hour", "day", "week", "month" or "year". 42 # This can optionally be preceded by an integer and a 43 # space, or followed by "s". 44 # length.out - length.out integer, optional. Desired length 45 # of the sequence, if specified "to" will be ignored. 46 # format - the format specification of the input character 47 # vector. 48 # FinCenter - a character string with the the location of the 49 # financial center named as "continent/city". 50 51 # Value: 52 # Returns a 'timeDate' object corresponding to the "sequence" 53 # specification. 54 55 # Note: 56 # The 'zone' where the data were recorded is fixed to myFincenter! 57 58 # Example: 59 # x = timeSequence("2004-01-28", "2004-02-04", by = "day") 60 # x = timeSequence("2004-01-01", "2005-01-31", by = "month") 61 # x = timeSequence("2004-01-28", by = "day", length.out = 10) 62 # x = timeSequence("2004-01-01", by = "month", length.out = 12) 63 # x = timeSequence("2004-01-28 18:00:00", "2004-01-29 05:00:00", by = "hour") 64 # x = timeSequence("2004-01-28 18:00:00", by = "hour", length.out = 12) 65 66 # FUNCTION: 67 if (zone == "") 68 zone <- getRmetricsOptions("myFinCenter") 69 if (FinCenter == "") 70 FinCenter <- getRmetricsOptions("myFinCenter") 71 72 # Missing from: 73 if (missing(from)) 74 from <- timeDate(to, format = format, zone = zone, 75 FinCenter = FinCenter) - 24*29*3600 76 77 # Settings and Checks: 78 if (!is.null(length.out)) to <- from 79 if (missing(by)) by <- "day" 80 81 # Auto-detect Input Format: 82 if (is.null(format)) { 83 format.from <- whichFormat(as.character(from)) 84 format.to <- whichFormat(as.character(to)) 85 } else { 86 format.from <- format.to <- format 87 } 88 from <- timeDate(from, format = format.from, zone = zone, FinCenter = FinCenter) 89 to <- timeDate(to, format = format.to, zone = zone, FinCenter = FinCenter) 90 91 if (length(length.out)) 92 seq(from = from, by = by, length.out = length.out) 93 else 94 seq(from = from, to = to, by = by) 95} 96 97 98# ---------------------------------------------------------------------------- # 99# Roxygen Tags 100#' @export 101# ---------------------------------------------------------------------------- # 102seq.timeDate <- 103 function (from, to, by, length.out = NULL, along.with = NULL, ...) 104{ 105 # A function implemented by Diethelm Wuertz and Yohan Chalabi 106 107 # FUNCTION: 108 109 # This function is very similar to seq.POSIXt() from R's base, 110 # --> .../src/library/base/R/datetime.R 111 # Modifications by Yohan Chalabi & Martin Maechler marked with end-of-line ## 112 113 # YC: Note the only difference with seq.POSIXt apart that it works 114 # with timeDate objects is that argument 'by' accepts the syantax 115 # without whitespace, e.g. 1week, and accept 'by = quarter'. This 116 # is important for compatibilty purpose for the align timeDate 117 # method that is based on seq.timeDate. 118 119 if (missing(from)) stop("'from' must be specified") 120 if (!inherits(from, "timeDate")) stop("'from' must be a timeDate object") ## 121 122 DST <- ## 123 if (!missing(by) && is.character(by)) { 124 if (identical("quarter", by)) by <- "3 months" 125 by1 <- gsub("[ 0-9]", "", by, perl = TRUE) ## 126 !is.na(pmatch(by1, c("months", "years", "DSTdays"))) ## 127 } else FALSE 128 FinCenter <- finCenter(from) ## 129 zone <- if (DST) FinCenter else "GMT" ## 130 as.POSIX.. <- function(x) 131 if (DST) as.POSIXct(format(x), tz = "GMT") else as.POSIXct(x) 132 from <- as.POSIX..(from) 133 134 cfrom <- as.POSIXct(from) 135 if (length(cfrom) != 1) stop("'from' must be of length 1") 136 tz <- "GMT" ## 137 if (!missing(to)) { 138 if (!inherits(to, "timeDate")) stop("'to' must be a timeDate object") ## 139 # FinCenter of 'from' argument is used as reference ## 140 finCenter(to) <- FinCenter ## 141 to <- as.POSIX..(to)## 142 if (length(to) != 1) stop("'to' must be of length 1") 143 } 144 145 if (!missing(along.with)) { 146 length.out <- length(along.with) 147 } else if (!is.null(length.out)) { 148 if (length(length.out) != 1L) stop("'length.out' must be of length 1") 149 length.out <- ceiling(length.out) 150 } 151 status <- c(!missing(to), !missing(by), !is.null(length.out)) 152 if(sum(status) != 2L) 153 stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified") 154 if (missing(by)) { 155 from <- unclass(cfrom) 156 to <- unclass(as.POSIXct(to)) 157 ## Till (and incl.) 1.6.0 : 158 ##- incr <- (to - from)/length.out 159 ##- res <- seq.default(from, to, incr) 160 res <- seq.int(from, to, length.out = length.out) 161 return(timeDate(res, zone = zone, FinCenter = FinCenter)) ## 162 } 163 if (length(by) != 1L) stop("'by' must be of length 1") 164 valid <- 0L 165 if (inherits(by, "difftime")) { 166 by <- switch(attr(by,"units"), secs = 1, mins = 60, hours = 3600, 167 days = 86400, weeks = 7*86400) * unclass(by) 168 } else if(is.character(by)) { 169 by2 <- c(if (length(grep("[0-9]", by, perl = TRUE))) ## 170 gsub("[ A-Za-z]", "", by, perl = TRUE), 171 gsub("[ 0-9]", "", by, perl = TRUE)) ## 172 if(length(by2) > 2L || length(by2) < 1L) 173 stop("invalid 'by' string") 174 valid <- pmatch(by2[length(by2)], 175 c("secs", "mins", "hours", "days", "weeks", 176 "months", "years", "DSTdays")) 177 if(is.na(valid)) stop("invalid string for 'by'") 178 if(valid <= 5L) { 179 by <- c(1, 60, 3600, 86400, 7*86400)[valid] 180 if (length(by2) == 2L) by <- by * as.integer(by2[1L]) 181 } else 182 by <- if(length(by2) == 2L) as.integer(by2[1L]) else 1 183 } else if(!is.numeric(by)) stop("invalid mode for 'by'") 184 if(is.na(by)) stop("'by' is NA") 185 186 if(valid <= 5L) { # secs, mins, hours, days, weeks 187 from <- unclass(as.POSIXct(from)) 188 if(!is.null(length.out)) 189 res <- seq.int(from, by=by, length.out=length.out) 190 else { 191 to0 <- unclass(as.POSIXct(to)) 192 ## defeat test in seq.default 193 res <- seq.int(0, to0 - from, by) + from 194 } 195 ## return(.POSIXct(res, tz)) ## 196 } else { # months or years or DSTdays 197 r1 <- as.POSIXlt(from) 198 if(valid == 7L) { # years 199 if(missing(to)) { # years 200 yr <- seq.int(r1$year, by = by, length.out = length.out) 201 } else { 202 to <- as.POSIXlt(to) 203 yr <- seq.int(r1$year, to$year, by) 204 } 205 r1$year <- yr 206 } else if(valid == 6L) { # months 207 if(missing(to)) { 208 mon <- seq.int(r1$mon, by = by, length.out = length.out) 209 } else { 210 to0 <- as.POSIXlt(to) 211 mon <- seq.int(r1$mon, 12*(to0$year - r1$year) + to0$mon, by) 212 } 213 r1$mon <- mon 214 } else if(valid == 8L) { # DSTdays 215 if(!missing(to)) { 216 ## We might have a short day, so need to over-estimate. 217 length.out <- 2L + floor((unclass(as.POSIXct(to)) - 218 unclass(as.POSIXct(from)))/86400) 219 } 220 r1$mday <- seq.int(r1$mday, by = by, length.out = length.out) 221 } 222 r1$isdst <- -1L 223 res <- as.POSIXct(r1) 224 ## now shorten if necessary. 225 if(!missing(to)) { 226 to <- as.POSIXct(to) 227 res <- if(by > 0) res[res <= to] else res[res >= to] 228 } 229 } 230 timeDate(res, zone = zone, FinCenter = FinCenter) ## 231} 232 233 234################################################################################ 235 236