[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