[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