# [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
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)
}
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
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)
}
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
> 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
> 			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
>              }
>              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
> 			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)
>              }
>              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

```