[R-sig-finance] Monthly Sequences
Gabor Grothendieck
ggrothendieck at gmail.com
Tue Feb 21 16:26:49 CET 2006
There is still a problem with line wrapping. Check out:
https://stat.ethz.ch/pipermail/r-sig-finance/2006q1/000679.html
I believe the list will accept text attachments. To avoid these
problems just post it as an attachment or if you have web space
post it with a link.
Also it might be useful if you provide a sentence or two of
explanation and a few test cases to illustrate how it works.
On 2/21/06, Parlamis Franklin <fparlamis at mac.com> wrote:
> So sorry folks. Function I sent had an unintended linebreak in the
> middle of a "%%" operator, causing a syntax error.
> Below please find the function without that error.
>
> FP
>
> ------
>
> seq.Date <-
> ## enhances base R seq.Date function by allowing the
> ## end.end convention for monthly and yearly sequences
> function (from, to, by, length.out = NULL, along.with = NULL, end.end
> = FALSE,
> ...)
> {
> if (missing(from))
> stop("'from' must be specified")
> if (!inherits(from, "Date"))
> stop("'from' must be a Date object")
> if (length(as.Date(from)) != 1)
> stop("'from' must be of length 1")
> if (!missing(to)) {
> if (!inherits(to, "Date"))
> stop("'to' must be a Date object")
> if (length(as.Date(to)) != 1)
> stop("'to' must be of length 1")
> }
> if (!missing(along.with)) {
> length.out <- length(along.with)
> }
> else if (!missing(length.out)) {
> if (length(length.out) != 1)
> stop("'length.out' must be of length 1")
> length.out <- ceiling(length.out)
> }
> status <- c(!missing(to), !missing(by), !is.null(length.out))
> if (sum(status) != 2)
> stop("exactly two of 'to', 'by' and 'length.out' /
> 'along.with' must be specified")
> if (missing(by)) {
> from <- unclass(as.Date(from))
> to <- unclass(as.Date(to))
> res <- seq.default(from, to, length.out = length.out)
> return(structure(res, class = "Date"))
> }
> if (length(by) != 1)
> stop("'by' must be of length 1")
> valid <- 0
> if (inherits(by, "difftime")) {
> by <- switch(attr(by, "units"), secs = 1/86400, mins = 1/1440,
> hours = 1/24, days = 1, weeks = 7) * unclass(by)
> }
> else if (is.character(by)) {
> by2 <- strsplit(by, " ", fixed = TRUE)[[1]]
> if (length(by2) > 2 || length(by2) < 1)
> stop("invalid 'by' string")
> valid <- pmatch(by2[length(by2)], c("days", "weeks",
> "months", "years"))
> if (is.na(valid))
> stop("invalid string for 'by'")
> if (valid <= 2) {
> by <- c(1, 7)[valid]
> if (length(by2) == 2)
> by <- by * as.integer(by2[1])
> }
> else by <- if (length(by2) == 2)
> as.integer(by2[1])
> else 1
> }
> else if (!is.numeric(by))
> stop("invalid mode for 'by'")
> if (is.na(by))
> stop("'by' is NA")
> if (valid <= 2) {
> from <- unclass(as.Date(from))
> if (!is.null(length.out))
> res <- seq.default(from, by = by, length.out = length.out)
> else {
> to <- unclass(as.Date(to))
> res <- seq.default(0, to - from, by) + from
> }
> return(structure(res, class = "Date"))
> }
> else {
> r1 <- as.POSIXlt(from)
> if (valid == 4) {
> if (missing(to)) {
> yr <- seq(r1$year, by = by, length = length.out)
> }
> else {
> to <- as.POSIXlt(to)
> yr <- seq(r1$year, to$year, by)
> }
> r1$year <- yr
> ### begin FP addenda
> if (end.end && r1$mon==1 && r1$mday>27) {
> r1$mon <- rep(r1$mon, length(r1$year))
> r1$mday <- rep(r1$mday, length(r1$year))
> natyr <- r1$year+1900
> leap <- natyr %% 4 == 0 &
> (natyr %% 100 != 0 | natyr %% 400 == 0) ## thx Diethelm Wuertz
> mdayadj <- (r1$mon == 1) * (r1$mday == 28) * (leap) -
> (r1$mon == 1) * (r1$mday == 29) * (!leap)
> r1$mday <- r1$mday + mdayadj
> }
> ### end FP addenda
> res <- .Internal(POSIXlt2Date(r1))
> }
> else if (valid == 3) {
> if (missing(to)) {
> mon <- seq(r1$mon, by = by, length = length.out)
> }
> else {
> to <- as.POSIXlt(to)
> mon <- seq(r1$mon, 12 * (to$year - r1$year) +
> to$mon, by)
> }
> r1$mon <- mon
> ### begin FP addenda
> if (end.end && r1$mday>27) {
> r1$mday <- rep(r1$mday, length(r1$mon))
> natyr <- r1$year + 1900 + r1$mon %/% 12
> leap <- natyr %% 4 == 0 &
> (natyr %% 100 != 0 | natyr %% 400 == 0) ## thx Diethelm Wuertz
> last <- c(31,28,31,30,31,30,31,31,30,31,30,31)[r1$mon %
> % 12 + 1]
> last <- last + (last == 28)*(leap)
> if (last[1] == r1$mday[1]) {
> r1$mday <- last
> }
> else r1$mday <- pmin(last, r1$mday)
> }
> ### end FP addenda
> res <- .Internal(POSIXlt2Date(r1))
> }
> return(res)
> }
> }
>
>
>
> On Feb 20, 2006, at 6:46 PM, Parlamis Franklin wrote:
>
> > There was a thread a while ago about monthly sequences, and the "end-
> > end" convention used for interbank deposits. I've done some more
> > work on this, and come up with a version of the seq.Date function
> > (from base R) that I think can handle the convention. Generating
> > sequences of swap payment dates should be facilitated by this
> > function. Basically, all you do is add an 'end.end=TRUE' flag to
> > your regular 'seq' function call.
> >
> > The replacement function is printed below. It is verbatim the
> > 'seq.Date' function, with commented addenda. No additional packages
> > are required.
> >
> > If anyone finds the function helpful, I would appreciate your
> > thoughts on style, etc . . .
> >
> > Franklin Parlamis
> >
> > -----
> >
> > seq.Date <-
> > ## enhances base R seq.Date function by allowing the
> > ## end.end convention for monthly and yearly sequences
> > function (from, to, by, length.out = NULL, along.with = NULL, end.end
> > = FALSE,
> > ...)
> > {
> > if (missing(from))
> > stop("'from' must be specified")
> > if (!inherits(from, "Date"))
> > stop("'from' must be a Date object")
> > if (length(as.Date(from)) != 1)
> > stop("'from' must be of length 1")
> > if (!missing(to)) {
> > if (!inherits(to, "Date"))
> > stop("'to' must be a Date object")
> > if (length(as.Date(to)) != 1)
> > stop("'to' must be of length 1")
> > }
> > if (!missing(along.with)) {
> > length.out <- length(along.with)
> > }
> > else if (!missing(length.out)) {
> > if (length(length.out) != 1)
> > stop("'length.out' must be of length 1")
> > length.out <- ceiling(length.out)
> > }
> > status <- c(!missing(to), !missing(by), !is.null(length.out))
> > if (sum(status) != 2)
> > stop("exactly two of 'to', 'by' and 'length.out' /
> > 'along.with' must be specified")
> > if (missing(by)) {
> > from <- unclass(as.Date(from))
> > to <- unclass(as.Date(to))
> > res <- seq.default(from, to, length.out = length.out)
> > return(structure(res, class = "Date"))
> > }
> > if (length(by) != 1)
> > stop("'by' must be of length 1")
> > valid <- 0
> > if (inherits(by, "difftime")) {
> > by <- switch(attr(by, "units"), secs = 1/86400, mins =
> > 1/1440,
> > hours = 1/24, days = 1, weeks = 7) * unclass(by)
> > }
> > else if (is.character(by)) {
> > by2 <- strsplit(by, " ", fixed = TRUE)[[1]]
> > if (length(by2) > 2 || length(by2) < 1)
> > stop("invalid 'by' string")
> > valid <- pmatch(by2[length(by2)], c("days", "weeks",
> > "months", "years"))
> > if (is.na(valid))
> > stop("invalid string for 'by'")
> > if (valid <= 2) {
> > by <- c(1, 7)[valid]
> > if (length(by2) == 2)
> > by <- by * as.integer(by2[1])
> > }
> > else by <- if (length(by2) == 2)
> > as.integer(by2[1])
> > else 1
> > }
> > else if (!is.numeric(by))
> > stop("invalid mode for 'by'")
> > if (is.na(by))
> > stop("'by' is NA")
> > if (valid <= 2) {
> > from <- unclass(as.Date(from))
> > if (!is.null(length.out))
> > res <- seq.default(from, by = by, length.out =
> > length.out)
> > else {
> > to <- unclass(as.Date(to))
> > res <- seq.default(0, to - from, by) + from
> > }
> > return(structure(res, class = "Date"))
> > }
> > else {
> > r1 <- as.POSIXlt(from)
> > if (valid == 4) {
> > if (missing(to)) {
> > yr <- seq(r1$year, by = by, length = length.out)
> > }
> > else {
> > to <- as.POSIXlt(to)
> > yr <- seq(r1$year, to$year, by)
> > }
> > r1$year <- yr
> > ### begin FP addenda
> > if (end.end && r1$mon==1 && r1$mday>27) {
> > r1$mon <- rep(r1$mon, length(r1$year))
> > r1$mday <- rep(r1$mday, length(r1$year))
> > natyr <- r1$year+1900
> > leap <- natyr %% 4 == 0 &
> > (natyr %% 100 != 0 | natyr %% 400 == 0) ## thx Diethelm Wuertz
> > mdayadj <- (r1$mon == 1) * (r1$mday == 28) * (leap) -
> > (r1$mon == 1) * (r1$mday == 29) * (!leap)
> > r1$mday <- r1$mday + mdayadj
> > }
> > ### end FP addenda
> > res <- .Internal(POSIXlt2Date(r1))
> > }
> > else if (valid == 3) {
> > if (missing(to)) {
> > mon <- seq(r1$mon, by = by, length = length.out)
> > }
> > else {
> > to <- as.POSIXlt(to)
> > mon <- seq(r1$mon, 12 * (to$year - r1$year) +
> > to$mon, by)
> > }
> > r1$mon <- mon
> > ### begin FP addenda
> > if (end.end && r1$mday>27) {
> > r1$mday <- rep(r1$mday, length(r1$mon))
> > natyr <- r1$year + 1900 + r1$mon %/% 12
> > leap <- natyr %% 4 == 0 &
> > (natyr %% 100 != 0 | natyr %% 400 == 0) ## thx Diethelm Wuertz
> > last <- c(31,28,31,30,31,30,31,31,30,31,30,31)[r1$mon %
> > % 12 + 1]
> > last <- last + (last == 28)*(leap)
> > if (last[1] == r1$mday[1]) {
> > r1$mday <- last
> > }
> > else r1$mday <- pmin(last, r1$mday)
> > }
> > ### end FP addenda
> > res <- .Internal(POSIXlt2Date(r1))
> > }
> > return(res)
> > }
> > }
> >
> >
> >
> > [[alternative HTML version deleted]]
> >
> > _______________________________________________
> > R-sig-finance at stat.math.ethz.ch mailing list
> > https://stat.ethz.ch/mailman/listinfo/r-sig-finance
>
> _______________________________________________
> R-sig-finance at stat.math.ethz.ch mailing list
> https://stat.ethz.ch/mailman/listinfo/r-sig-finance
>
More information about the R-sig-finance
mailing list