Nothing
dateWarp <- function(date, spec, holidays = NULL, by = NULL,
direction = 1, duplicates.keep = TRUE, optimize.dups = TRUE) {
UseMethod("dateWarp")
}
dateWarp.character <- function(date, spec, holidays = NULL, by = NULL,
direction = 1, duplicates.keep = TRUE, optimize.dups = TRUE)
{
x <- NextMethod('dateWarp')
as.character(x)
}
dateWarp.factor <- function(date, spec, holidays = NULL, by = NULL,
direction = 1, duplicates.keep = TRUE, optimize.dups = TRUE)
{
lev <- levels(date)
new.lev <- dateWarp.Date(dateParse(lev), spec=spec, holidays=holidays, by=by,
direction=direction, duplicates.keep=duplicates.keep, optimize.dups=FALSE)
new.lev <- as.character(new.lev)
if (!any(duplicated(new.lev)) && length(new.lev)==length(lev) && !any(is.na(new.lev) & !is.na(lev))) {
levels(date) <- new.lev
} else {
# Have duplicates new.lev; must recode factor to a smaller set of levels.
new.lev2 <- unique(new.lev)
new.lev2 <- sort(new.lev2[!is.na(new.lev2)])
recode <- match(new.lev, new.lev2)
date <- structure(recode[as.integer(date)], levels=new.lev2, class='factor')
}
date
}
dateWarp.POSIXct <- function(date, spec, holidays = NULL, by = NULL,
direction = 1, duplicates.keep = TRUE, optimize.dups = TRUE)
{
tz <- attr(date, 'tzone')
x <- NextMethod('dateWarp')
# Need to convert Date to character before converting back to POSIXct
# see examples in tests/pitfalls.Rt
# TODO: can we do better with this?
x <- as.POSIXct(as.character(x))
if (!is.null(tz))
attr(x, 'tzone') <- tz
return(x)
}
dateWarp.POSIXlt <- function(date, spec, holidays = NULL, by = NULL,
direction = 1, duplicates.keep = TRUE, optimize.dups = TRUE)
{
tz <- attr(date, 'tzone')
x <- NextMethod('dateWarp')
# need to convert Date to character before converting back to POSIXlt
# see examples in tests/pitfalls.Rt
x <- as.POSIXlt(as.character(x))
if (!is.null(tz))
attr(x, 'tzone') <- tz
return(x)
}
dateWarp.Date <- function(date, spec, holidays = NULL, by = NULL,
direction = 1, duplicates.keep = TRUE, optimize.dups = TRUE)
{
# This is the workhorse method -- this handles all type of input
### BEGIN ARGUMENT PROCESSING ###
if (!hasArg(date))
stop("'date' argument missing.")
if (!hasArg(spec))
stop("'spec' argument missing.")
if (optimize.dups && duplicates.keep && length(date) > 50
&& length(xu <- unique(date)) < length(date)/2) {
# Lots of duplicates -- do the slow date computations only for the unique values.
# Don't need to worry too much about the test for whether optimization should
# be used -- with daily dates usually there are either lots of duplicates
# or no duplicates.
yu <- dateWarp.Date(xu, spec=spec, holidays=holidays, by=by, direction=direction, duplicates.keep=duplicates.keep, optimize.dups=FALSE)
i <- match(date, xu)
return(yu[i])
}
if (!inherits(date, "Date")) {
date <- dateParse(date)
if (is.null(date))
stop("'date' argument must inherit or be convertible from the 'Date' class.")
}
if (!is.null(by)) {
if (!is.character(by))
stop("'by' must be a character vector.")
if (length(by) > 1) {
by <- by[1]
warning("only the first element of 'by' will be used.")
}
# TODO: parse direction & k.by out of by
if ((atPos <- regexpr("@", by)[1]) > 0) {
byStr <- by
by <- substring(byStr, 1, atPos - 1)
if (!is.null(holidays))
stop("double specification of holidays.")
holidays <- substring(byStr, atPos + 1)
if (holidays == "")
stop("could not parse holiday name out of '", byStr, "'.")
if (by == "")
stop("could not parse 'by' out of '", byStr, "'.")
}
if (!(by %in% c('days', 'bizdays', 'weeks', 'months', 'years')))
stop("'by' must contain only the values 'days', 'bizdays','weeks', 'months' or 'years'.")
}
if (!is.null(holidays)) {
if ((!is.null(by) && by != "bizdays") &&
!is.list(spec) && !("bizdays" %in% unlist(spec, use.names = FALSE))) {
# This test doesn't work with spec that is a list
warning("ignoring holidays argument. Only relevant when 'by = \"bizdays\"'.")
holidays <- NULL
} else if (!all(holidays %in% allHolidays())) {
stop(paste('no', holidays[!(holidays %in% allHolidays())][1],'holidays exist.'))
}
}
## 'direction' is +1 for after, -1 for before
direction <- as.integer(direction)
if (!(direction == -1 || direction == 1))
stop("'direction' must be -1 or 1.")
duplicates.keep <- as.logical(duplicates.keep)
if (!is.finite(duplicates.keep) || length(duplicates.keep) != 1)
stop("'duplicates.keep' must be either TRUE or FALSE.")
### END ARGUMENT PROCESSING ###
if (is.numeric(spec) || is.character(spec))
spec <- list(spec)
if (is.list(spec)) {
for (i in seq_along(spec)) {
byUse <- NULL
holidaysUse <- NULL
name <- if (is.null(names(spec))) "" else names(spec)[i]
if ((name == "latest" || name == "earliest") && is.character(spec[[i]]))
op <- dateParse(spec[[i]])
else
op <- spec[[i]]
if (is.character(op) && (name == "" || name == "shift")) {
## Parse something like "+3 bizdays@NYSEC", "+3 bizdays", or "+3".
## (It's necessary to supply 'by' to dateWarp(), but it can be picked
## up from elsewhere.)
opStr <- op
if ((spPos <- regexpr(" ", opStr)[1]) != -1) {
byStr <- substring(opStr, spPos + 1)
opStr <- substring(opStr, 1, spPos - 1)
if ((atPos <- regexpr("@", byStr)[1]) > 0) {
byUse <- substring(byStr, 1, atPos - 1)
holidaysUse <- substring(byStr, atPos + 1)
if (holidaysUse == "")
stop("could not parse holiday name out of '", byStr, "'.")
} else {
byUse <- byStr
}
if (byUse == "")
stop("could not parse 'by' out of '", byStr, "'.")
if (!(byUse %in% c('days', 'bizdays', 'weeks', 'months', 'years')))
stop("'by' must contain only the values 'days', 'bizdays','weeks', 'months' or 'years'.")
}
# all that is left in "a.str" should a number like "-1" or "+3"
op <- as.numeric(opStr)
if (any(is.na(op)))
stop("could not parse some elements of 'spec' vector to numbers: ",
paste(opStr[is.na(op)][seq(len=min(3, sum(is.na(op))))], collapse=", "),
if (sum(is.na(op))>3) " ...")
}
if (is.numeric(op)) {
if (name == "" || name == "shift") {
if (is.null(byUse) && !is.null(by))
byUse <- by
if (is.null(byUse))
stop("must supply 'by'")
if (is.null(holidaysUse) && !is.null(holidays))
holidaysUse <- holidays
res <- emptyDate()
## TODO: replace this for loop with vectorized call?
for (i in seq_along(op)) {
if (op[i] == 0)
tmp <- dateAlign(date, by = byUse, direction = direction,
holidays = holidaysUse, silent = TRUE, optimize.dups = optimize.dups)
else if (op[i] < 0)
tmp <- dateShift(date, by = byUse, k.by = -op[i], direction = -direction,
holidays = holidaysUse, silent = TRUE, optimize.dups = optimize.dups)
else
tmp <- dateShift(date, by = byUse, k.by = op[i], direction = direction,
holidays = holidaysUse, silent = TRUE, optimize.dups = optimize.dups)
res <- c(res, tmp)
}
if (!duplicates.keep)
res <- unique(res)
date <- res
} else if (name == "unique") {
date <- unique(date)
} else {
stop("names of integer operations can be '', 'shift' or 'unique'.")
}
} else if (is.logical(op) && name == "unique") {
date <- unique(date)
} else if (inherits(op, "Date")) {
if (name == "latest")
date <- pmin(date, op)
else if (name=="earliest")
date <- pmax(date, op)
else
stop("names of Date can be \"latest\" or \"earliest\"")
} else if (is.list(op)) {
## A list element is treated as a list of arguments for dateAlign or dateShift.
if (name == "align" && any(is.element(c("to", "table"), names(op)))) {
names(op)[names(op) == "to"] <- "table"
date <- op$table[do.call("dateMatch", c(list(x = date), op))]
} else if (name == "align") {
## For arguments "by", "direction", and "holidays", substitute a default if not supplied.
if (all(is.na(pmatch(names(op), "by")))) {
if (is.null(by))
stop("must supply 'by'.")
op$by <- by
}
if ((atPos <- regexpr("@", op$by)[1]) > 0) {
if (any(!is.na(i <- pmatch(names(op), "holidays"))))
stop("double specification of holidays in '", name, "' component.")
op$holidays <- substring(op$by, atPos+1)
if (op$holidays == "")
stop("could not parse holiday name out of '", op$by, "'.")
op$by <- substring(op$by, 1, atPos-1)
}
if (all(is.na(pmatch(names(op), "direction"))))
op$direction <- direction
if (all(is.na(pmatch(names(op), "holidays"))))
op$holidays <- holidays
date <- do.call("dateAlign", c(list(x = date, silent = TRUE, optimize.dups = optimize.dups), op))
} else if (name == "shift") {
## TODO: need tests for parsing 'N bizdays@HOLIDAYS' here
## Check if unnamed item looks like '3 bizdays' or '-3 bizdays@NYSEC'
if (all(is.na(pmatch(names(op), "k.by")))
&& length(i <- which(names(op) == ""))
&& is.character(op[[i]])
&& (spPos <- regexpr(" ", op[[i]])[1]) != -1) {
if (any(!is.na(i <- pmatch(names(op), "by"))))
stop("double specification of 'by' in '", name, "' component.")
op$by <- substring(op[[i]], spPos + 1)
op$k.by <- substring(op[[i]], 1, spPos - 1)
}
if ((atPos <- regexpr("@", op$by)[1]) > 0) {
if (any(!is.na(i <- pmatch(names(op), "holidays"))))
stop("double specification of holidays in '", name, "' component.")
op$holidays <- substring(op$by, atPos+1)
if (op$holidays == "")
stop("could not parse holiday name out of '", op$by, "'.")
op$by <- substring(op$by, 1, atPos-1)
}
## Check if unnamed item is intended to be a k.by argument.
if (all(is.na(pmatch(names(op), "k.by"))) &&
length(i <- which(names(op) == ""))) {
if (is.numeric(op[[i]]))
names(op)[i] <- "k.by"
}
if (all(is.na(pmatch(names(op), "direction"))))
op$direction <- direction
if (all(is.na(pmatch(names(op), "holidays"))))
op$holidays <- holidays
if ("k.by" %in% names(op) && op$k.by < 0) {
op$k.by <- -op$k.by
op$direction <- -op$direction
}
date <- do.call("dateShift", c(list(x = date, silent = TRUE), op))
} else
stop("names of lists must be 'align' or 'shift'.")
}
}
}
if (!duplicates.keep)
date <- unique(date)
date
}
dateWarp.default <- dateWarp.Date
dateWarpAppend <- function(date, ..., where=c("sorted", "start", "end"), empty.ok=FALSE, duplicates.ok=FALSE) {
where <- match.arg(where)
new.date <- dateWarp(date, ...)
if (!empty.ok && length(new.date)==0)
stop("no new date to add")
# handle the perversity that c() on POSIXct does not preserve tzone...
tzone <- attr(date, 'tzone')
if (where=="sorted") {
if (!all(diff(date) >= 0))
stop("input date are not sorted")
date <- sort(c(new.date, date))
} else if (where=="start") {
date <- c(new.date, date)
} else {
date <- c(date, new.date)
}
if (!duplicates.ok){
dups <- duplicated(date)
if (any(dups)) date <- date[!dups]
}
if (!is.null(tzone))
attr(date, 'tzone') <- tzone
date
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.