[R-sig-finance] Monthly Sequences

Parlamis Franklin fparlamis at mac.com
Tue Feb 21 08:12:51 CET 2006


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



More information about the R-sig-finance mailing list