Monthly Sequences

classic Classic list List threaded Threaded
4 messages Options
Reply | Threaded
Open this post in threaded view
|

Monthly Sequences

Parlamis Franklin
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]]

_______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-sig-finance
Reply | Threaded
Open this post in threaded view
|

Re: Monthly Sequences

Parlamis Franklin
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]]
>
> _______________________________________________
> [hidden email] mailing list
> https://stat.ethz.ch/mailman/listinfo/r-sig-finance

_______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-sig-finance
Reply | Threaded
Open this post in threaded view
|

Re: Monthly Sequences

Gabor Grothendieck
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 <[hidden email]> 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]]
> >
> > _______________________________________________
> > [hidden email] mailing list
> > https://stat.ethz.ch/mailman/listinfo/r-sig-finance
>
> _______________________________________________
> [hidden email] mailing list
> https://stat.ethz.ch/mailman/listinfo/r-sig-finance
>

_______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-sig-finance
Reply | Threaded
Open this post in threaded view
|

Re: Monthly Sequences

Parlamis Franklin

On Feb 21, 2006, at 5:26 AM, Gabor Grothendieck wrote:

> 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.
>

Thanks Gabor, and sorry again for problems.  Attached please find a  
text file with the new function.  Note that I have cleaned this up  
from yesterday's version so please use this one.



When the original seq.Date wants to do yearly or monthly sequences,  
it converts the "from" argument to POSIXlt and manipulates the "year"  
and "mon" vectors, respectively.  Then it converts back with .Internal
(POSIXlt2Date).

My function adds some appropriate manipulation of the "mday" vector  
in both cases before the .Internal reconversion, if the additional  
"end.end" argument is TRUE (default value is FALSE).  Along the way,  
it includes logic to provide leap-year and last-day-in-month  
information (the leap year logic was published by Diethelm Wuertz in  
this article -- http://www.itp.phys.ethz.ch/econophysics/R/pdf/ 
calendar.pdf).  I have embedded this logic in my code to minimize my  
intrusion on base R, although it could probably be handled in  
external functions that would have other usefulness.  I have also  
employed Gabor's "pmin" logic from the function he posted a week  
back, for which thanks.

I should add that I have no idea how .Internal(POSIXlt2Date) works,  
and I am hoping that no untoward behavior results from my addenda.

Here are some examples.

___

 > seq(as.Date("2005-01-31"), by="month", len=5)
[1] "2005-01-31" "2005-03-03" "2005-03-31" "2005-05-01" "2005-05-31"
 > seq(as.Date("2005-01-31"), by="month", len=5, end.end=TRUE)
[1] "2005-01-31" "2005-02-28" "2005-03-31" "2005-04-30" "2005-05-31"

## Adding the end.end flag caused the month end convention to be  
respected.

 > seq(as.Date("2008-02-28"), by="month", len=5)
[1] "2008-02-28" "2008-03-28" "2008-04-28" "2008-05-28" "2008-06-28"
 > seq(as.Date("2008-02-28"), by="month", len=5, end.end=TRUE)
[1] "2008-02-28" "2008-03-28" "2008-04-28" "2008-05-28" "2008-06-28"
 > seq(as.Date("2008-02-29"), by="month", len=5)
[1] "2008-02-29" "2008-03-29" "2008-04-29" "2008-05-29" "2008-06-29"
 > seq(as.Date("2008-02-29"), by="month", len=5, end.end=TRUE)
[1] "2008-02-29" "2008-03-31" "2008-04-30" "2008-05-31" "2008-06-30"

  ## It knew about leap years.

 > seq(as.Date("2008-01-30"), by="month", len=5)
[1] "2008-01-30" "2008-03-01" "2008-03-30" "2008-04-30" "2008-05-30"
 > seq(as.Date("2008-01-30"), by="month", len=5, end.end=TRUE)
[1] "2008-01-30" "2008-02-29" "2008-03-30" "2008-04-30" "2008-05-30"

## And it handled the case where the "from" date was not end-of-month,
## but exceeded the end-of-month date in later months.

 > seq(as.Date("2005-02-28"), by="year", len=5)
[1] "2005-02-28" "2006-02-28" "2007-02-28" "2008-02-28" "2009-02-28"
 > seq(as.Date("2005-02-28"), by="year", len=5, end.end=TRUE)
[1] "2005-02-28" "2006-02-28" "2007-02-28" "2008-02-29" "2009-02-28"
 > seq(as.Date("2008-02-28"), by="year", len=5, end.end=TRUE)
[1] "2008-02-28" "2009-02-28" "2010-02-28" "2011-02-28" "2012-02-28"
 > seq(as.Date("2008-02-29"), by="year", len=5, end.end=TRUE)
[1] "2008-02-29" "2009-02-28" "2010-02-28" "2011-02-28" "2012-02-29"

## It also handled yearly sequences with February "froms" correctly

___

Franklin
_______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-sig-finance

seq.Date.txt (4K) Download Attachment