Nothing
".Holidays" <-
structure(.Data = c(8035, 8180, 8220, 8285, 8365, 8394),
format = structure(.Data = "m/d/y", .Names = "dates"),
origin = structure(.Data = c(1, 1, 1970),
.Names = c("month", "day", "year")),
class = c("dates", "times"),
.Names = c("New Year's Day", "Memorial Day",
"Independence Day", "Labor Day", "Thanksgiving",
"Christmas"))
"day.abb" <-
c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
"day.name" <-
c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday",
"Saturday")
"month.length"<-
c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
"days"<-
function(x)
{
if(!inherits(x, "dates"))
x <- as.chron(x)
d <- month.day.year(floor(as.numeric(x)), origin. = origin(x))$day
## use paste to avoid bug in ordered() as in beta release 8/92
d <- ordered(paste(d), paste(1:31))
d
}
"hours"<-
function(x)
{
if(!inherits(x, "times"))
x <- as.chron(x)
x <- as.numeric(x)
sec <- round(24 * 3600 * abs(x - floor(x)))
hh <- sec %/% 3600
hh
}
"minutes"<-
function(x)
{
if(!inherits(x, "times"))
x <- as.chron(x)
x <- as.numeric(x)
sec <- round(24 * 3600 * abs(x - floor(x)))
hh <- sec %/% 3600
mm <- (sec - hh * 3600) %/% 60
mm
}
"seconds"<-
function(x)
{
if(!inherits(x, "times"))
x <- as.chron(x)
x <- as.numeric(x)
sec <- round(24 * 3600 * abs(x - floor(x)))
hh <- sec %/% 3600
mm <- (sec - hh * 3600) %/% 60
ss <- trunc(sec - hh * 3600 - 60 * mm)
ss
}
"quarters.default"<-
function(x, abbreviate = TRUE)
{
if(!inherits(x, "dates"))
if((is.character(x) || is.numeric(x)))
x <- chron(x)
else return(NULL)
v <- month.day.year(floor(as.numeric(x)))$month
out <- (v - 1) %/% 3 + 1
lbl <- if(abbreviate)
c("1Q", "2Q", "3Q", "4Q")
else
c("I", "II", "III", "IV")
out <- lbl[out]
ordered(out, levels = lbl, labels = lbl)
}
"months.default"<-
function(x, abbreviate = TRUE)
{
if(!inherits(x, "dates"))
if((is.character(x) || is.numeric(x)))
x <- chron(x)
else return(NULL)
out <- month.day.year(as.numeric(x), origin. = origin(x))$month
lbl <- if(abbreviate) month.abb else month.name
out <- lbl[out]
ordered(out, levels = lbl, labels = lbl)
}
"weekdays.default" <-
function(x, abbreviate = TRUE)
{
if(!inherits(x, "dates"))
if((is.character(x) || is.numeric(x)))
x <- chron(x)
else stop("x must inherit from dates")
v <- month.day.year(as.numeric(x), origin. = origin(x))
out <- day.of.week(v$month, v$day, v$year) + 1
lbl <- if(abbreviate) day.abb else day.name
out <- lbl[out]
ordered(out, levels = lbl, labels = lbl)
}
"years" <-
function(x)
{
if(!inherits(x, "dates"))
x <- as.chron(x)
y <- month.day.year(as.numeric(x), origin. = origin(x))$year
y <- ordered(y)
y
}
"clock2frac" <-
function(str)
{
h <- as.numeric(substring(str, 1, 2))
m <- as.numeric(substring(str, 4, 5))
w <- substring(str, 6, 7)
if(any(h < 0, h > 12, m < 0, m > 59))
stop("misspecified time")
pm <- w == "pm" | w == "PM"
h[pm] <- h[pm] + 12
f <- (h * 3600 + m * 60)/(24 * 3600)
f
}
"count.events" <-
function(x, by)
table(cut(x, breaks = by))
"count.fields.str" <-
function(str, sep = "")
{
n <- length(str)
white.space <- missing(sep) || sep == ""
.C(C_cnt_flds_str,
strings = as.character(str),
nstrings = as.integer(n),
sep = as.character(sep),
white.space = as.integer(white.space),
counts = integer(n))$counts
}
"day.of.week" <-
function(month, day, year)
{
ix <- year + trunc((month - 14)/12)
jx <- (trunc((13 * (month + 10 - (month + 10) %/% 13 * 12) - 1)/5)
+ day + 77 + (5 * (ix - (ix %/% 100) * 100)) %/% 4
+ ix %/% 400 - (ix %/% 100) * 2)
jx %% 7
}
"format<-" <-
function(x, ..., value)
UseMethod("format<-")
"frac2clock" <-
function(f)
{
sec.per.day <- 24 * 3600
secs <- f * sec.per.day
h <- secs %/% 3600
m <- round((secs - h * 3600)/60, 0)
i <- h >= 13
h[i] <- h[i] - 12
pm <- rep("am", length(f))
i <- f > 0.5
pm[i] <- "pm"
m <- paste(m)
i <- nchar(m) == 1
m[i] <- paste("0", m[i], sep = "")
h <- paste(h)
i <- nchar(h) == 1
h[i] <- paste("0", h[i], sep = "")
paste(h, ":", m, pm, sep = "")
}
"is.holiday" <-
function(x, holidays)
{
if(!inherits(x, "dates")) x <- as.chron(x)
if(missing(holidays)) {
if(exists(".Holidays"))
holidays <- .Holidays
else holidays <- NULL
} else if (length(holidays) == 0) holidays <- NULL
if (is.null(holidays)) return(rep(FALSE, length(x)))
orig.x <- origin(x)
if(!is.null(orig.h <- origin(holidays)) && any(orig.x != orig.h))
origin(holidays) <- orig.x
out <- match(floor(x), floor(holidays), 0)
as.logical(out)
}
"is.weekend" <-
function(x)
{
if(!inherits(x, "dates")) x <- as.chron(x)
v <- month.day.year(as.numeric(x), origin. = origin(x))
out <- day.of.week(v$month, v$day, v$year) + 1
## recall out is between 1 (Sunday) and 7 (Saturday)
out == 1 | out == 7
}
"julian.default" <-
function(x, d, y, origin., ...)
{
only.origin <- all(missing(x), missing(d), missing(y))
if(only.origin) x <- d <- y <- NULL # return days since origin
if(missing(origin.) || is.null(origin.))
if(is.null(origin. <- getOption("chron.origin")))
origin. <- c(month = 1, day = 1, year = 1970)
nms <- names(d)
xdy <- cbind(x, d, y)
m <- c(origin.[1], xdy[, "x"]) # prepend month of new origin
d <- c(origin.[2], xdy[, "d"]) # prepend day of new origin
y <- c(origin.[3], xdy[, "y"]) # prepend year of new origin
##
## code from julian date in the S book (p.269)
##
y <- y + ifelse(m > 2, 0, -1)
m <- m + ifelse(m > 2, -3, 9)
c <- y %/% 100
ya <- y - 100 * c
out <- ((146097 * c) %/% 4 + (1461 * ya) %/% 4
+ (153 * m + 2) %/% 5 + d + 1721119)
## now subtract the new origin from all dates
if(!only.origin) {
if(all(origin. == 0))
out <- out[-1]
else
out <- out[-1] - out[1]
## orig according to S algorithm
}
names(out) <- nms
out
}
"julian2mine" <-
function(x)
{
v <- month.day.year(x)
d <- as.character(v$day)
i <- nchar(d) == 1
d[i] <- paste("0", d[i], sep = "")
paste(d, month.abb[v$month], v$year, sep = "")
}
"leap.year" <-
function(y)
{
if(inherits(y, "dates"))
y <- month.day.year(as.numeric(y), origin. = origin(y))$year
y %% 4 == 0 & (y %% 100 != 0 | y %% 400 == 0)
}
"mine2julian" <-
function(str)
{
d <- substring(str, 1, 2)
m <- substring(str, 3, 5)
y <- substring(str, 6, 9)
m <- match(m, month.abb, nomatch = NA)
julian(m, as.numeric(d), as.numeric(y))
}
"month.day.year" <-
function(jul, origin.)
{
if (!inherits(jul, "dates")) jul <- as.chron(jul)
if(missing(origin.) || is.null(origin.))
if(is.null(origin. <- getOption("chron.origin")))
origin. <- c(month = 1, day = 1, year = 1970)
if(all(origin. == 0)) shift <- 0 else shift <- julian(origin. = origin.)
## relative origin
## "absolute" origin
j <- as.integer(floor(jul)) + as.integer(shift)
j <- j - 1721119
y <- (4 * j - 1) %/% 146097
j <- 4 * j - 1 - 146097 * y
d <- j %/% 4
j <- (4 * d + 3) %/% 1461
d <- 4 * d + 3 - 1461 * j
d <- (d + 4) %/% 4
m <- (5 * d - 3) %/% 153
d <- 5 * d - 3 - 153 * m
d <- (d + 5) %/% 5
y <- 100 * y + j
y <- y + ifelse(m < 10, 0, 1)
m <- m + ifelse(m < 10, 3, -9)
list(month = m, day = d, year = y)
}
"my.axis" <-
function(x, simplify = TRUE, ...)
{
## put date labels in one line plus time lables on second line
px <- pretty(x)
xx <- chron(px, format = attr(x, "format"), origin. = origin(x))
lbls <- format(xx, enclose = c("", ""), sep = "\n", simplify = simplify)
axis(1, at = px, labels = lbls, ...)
invisible(list(at = px, labels = lbls))
}
"origin" <-
function(x)
attr(x, "origin")
"origin<-" <-
function(x, value)
{
if (length(value) != 3 || any(is.na(value)))
stop("origin must be a month, day, year vector")
if (value[1] < 1 || value[1] > 12)
stop("month out of range in origin")
n <- month.length[value[1]] +
as.numeric(value[1] == 2 && leap.year(value[3]))
if (value[2] < 1 || value[2] > n)
stop("day out of range in origin")
cl <- class(x)
class(x) <- NULL
jval <- julian(value[1], value[2], value[3], origin. = c(0, 0, 0))
## adjust days for new origin (new.x + new.o == old.x + old.o)
if (!is.null(ox <- attr(x, "origin")))
x <- x - jval + julian(ox[1], ox[2], ox[3], origin. = c(0, 0, 0))
new.origin <- unlist(month.day.year(jval, origin. = c(0, 0, 0)))
attr(x, "origin") <-
structure(new.origin, names = c("month", "day", "year"))
class(x) <- cl
x
}
"parse.format" <-
function(format, year.abb = getOption("chron.year.abb"), ...)
{
## determine order of month, day, year or hour, min, secs
abb <- TRUE # short notation?
mon.abb <- FALSE # should month names be abbreviated?
if(is.null(year.abb))
year.abb <- TRUE
if((nf <- nchar(format)) == 5) {
## abbreviated dates/times
sep <- substring(format, 2, 2)
fmt <- substring(format, first = c(1, 3, 5), last = c(1, 3, 5))
}
else if(nf == 3) {
sep <- "" # no sep
fmt <- substring(format, first = 1:3, last = 1:3)
}
else {
## full format (month names)
abb <- FALSE
sep <- gsub("^[[:alpha:]]+([^[:alpha:]]).*", "\\1", format)
if(sep == format)
stop(paste("unrecognized format", format))
fmt <- unlist(unpaste(format, sep = sep))
mon.abb <- if(any(fmt == "month")) FALSE else TRUE
}
periods <- substring(tolower(fmt), 1, 1) # m, d, & y in right order
return(list(abb = abb, sep = sep, periods = periods,
mon.abb = mon.abb, year.abb = year.abb))
}
"unpaste" <-
function(str, sep = "/", fnames = NULL, nfields = NULL,
first = c(1, 3, 5), width = 2)
{
## split str into fields separated by sep or by fiels specified by
## start positions and field widths; output a list
str <- as.character(str)
nas <- is.na(str) | str == ""
if(sep != "") {
if(is.null(nfields)) {
## use a simple heuristic
nf <- count.fields.str(str[!nas], sep = sep)
cnt <- table(nf)
nfields <- sort(unique(nf))[cnt == max(cnt)]
}
str[nas] <- paste(rep(NA, nfields), collapse = sep)
nf <- count.fields.str(str, sep = sep)
bad <- seq_along(str)[nf != nfields]
if(n.bad <- length(bad)) {
if(n.bad > 10)
msg <- paste(n.bad,
"entries set to NA",
"due to wrong number of fields")
else msg <- paste(
"wrong number of fields in entry(ies)",
paste(bad, collapse = ", "))
warning(msg)
nas[bad] <- TRUE
str[nas] <- paste(rep(NA, nfields), collapse = sep)
}
n <- length(str)
white.space <- FALSE
out <- .Call(C_unpaste,
as.character(str),
as.character(sep),
as.logical(white.space),
as.integer(nfields))
for(i in seq_along(out))
out[[i]][nas] <- as.character(NA)
}
else {
last <- first + width - 1
out <- vector("list", length = length(first))
for(i in seq_along(first)) {
out[[i]] <- substring(str, first[i], last[i])
out[[i]][nas] <- as.character(NA)
}
}
names(out) <- fnames
return(out)
}
.str_to_ymd_list <-
function(str, fmt)
{
str <- as.character(str)
nas <- is.na(str) | str == ""
periods <- fmt$periods
widths <- cbind(y = nchar(str) - 4, m = 2, d = 2)
last <- apply(widths[, fmt$periods, drop = FALSE], 1, cumsum)
first <- rbind(0, last[-3, , drop = FALSE]) + 1
out <- vector("list", length = 3)
for(i in seq_along(periods)) {
out[[i]] <- substring(str, first[i, ], last[i, ])
out[[i]][nas] <- as.character(NA)
}
names(out) <- periods
out
}
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.