Nothing
# Upon input
# z is a zoo object containing input data. E.g. this could be all the
# prices of a bunch of stocks. The column name is the unit name.
# events is a data.frame containing 2 columns. The first column
# ("name") is the name of the unit. The second column is the date/time
# ("when") when the event happened.
# For each event, the outcome can be:
# unitmissing : a unit named in events isn't in z
# wrongspan : the event date isn't placed within the span of data for the unit
# wdatamissing: too many NAs within the crucial event window.
# success : all is well.
# A vector of these outcomes is returned.
phys2eventtime <- function(z, events, width=10) {
stopifnot(width > 0)
stopifnot("data.frame" %in% class(events))
stopifnot("zoo" %in% class(z) || "xts" %in% class(z))
if (is.null(ncol(z))) {
stop(paste("'z' should be of class zoo/xts with at least one column. Use '[' with drop = FALSE"))
}
if (!any(class(events$when) %in% c("POSIXt", "Date"))) {
stop("events$when should be one of 'Date' or 'date-time' classes.")
}
if (any(is.na(events$when))) {
stop("events$when should not contain NA values.")
}
if (any(is.na(events$name))) {
stop("events$name should not contain NA values.")
}
if (!is.character(events$name)) {
stop("events$name should a character class.")
}
answer <- lapply(1:nrow(events), function(i) timeshift(events[i, ], z, width))
outcomes <- sapply(answer, function(x) x$outcome)
z.e <- do.call(cbind, lapply(answer[outcomes == "success"], function(x) x$result))
## If no successful outcome, return NULL to z.e.
if (length(z.e) == 0) {
return(list(z.e = NULL, outcomes = factor(outcomes)))
}
colnames(z.e) <- which(outcomes == "success")
## :DOC
events.attrib <- do.call(c, lapply(answer[outcomes == "success"], function(x) x$event))
## class(events.attrib) <- class(events$when)
## Information verification within 'width'
## :: Will not be executed with width = 0
badcolumns <- NULL
if (width > 0) {
for (i in 1:ncol(z.e)) {
tmp <- z.e[,i]
tmp2 <- window(tmp, start = (-width + 1), end = +width)
if (any(is.na(tmp2))) {
outcomes[as.numeric(colnames(z.e)[i])] <- "wdatamissing"
badcolumns <- c(badcolumns, i)
} else {
z.e[,i] <- tmp # Put the fixed up column back in.
}
}
if (any(outcomes == "wdatamissing")) {
z.e <- z.e[, -badcolumns, drop = FALSE]
events.attrib <- events.attrib[-badcolumns]
}
if (NCOL(z.e) == 0) {
return(list(z.e = NULL, outcomes = factor(outcomes)))
}
}
## Double check
stopifnot(sum(outcomes=="success") == NCOL(z.e))
list(z.e=z.e, outcomes=factor(outcomes), events = events.attrib) # :DOC: events.attrib
}
timeshift <- function(x, z, width) {
firm.present <- x[, "name"] %in% colnames(z)
if (!firm.present) {
return(list(result=NULL, outcome="unitmissing"))
}
## Take previous date if exact data is not found.
location <- findInterval(x[, "when"], index(z[, x[, "name"]]))
if ((location <= (width - 1)) || # testing upper bound
(location > (length(index(z)) - width))) { # lower bound
return(list(result=NULL, outcome="wrongspan"))
}
remapped <- zoo(as.numeric(z[, x[, "name"]]),
order.by = (-location + 1):(length(z[, x[, "name"]]) - location))
return(list(result = remapped, outcome = "success", event = index(z)[location]))
}
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.