#
# xts: eXtensible time-series
#
# Copyright (C) 2008 Jeffrey A. Ryan jeff.a.ryan @ gmail.com
#
# Contributions from Joshua M. Ulrich
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
endpoints <-
function(x,on='months',k=1) {
if(timeBased(x)) {
NR <- length(x)
x <- xts(, order.by=x)
} else NR <- NROW(x)
addlast <- TRUE # remove automatic NR last value
#if( !is.logical(addlast))
# stop(paste(sQuote("addlast"),"must be logical"))
if(!is.xts(x))
x <- try.xts(x, error='must be either xts-coercible or timeBased')
# posixltindex is costly in memory (9x length of time)
# make sure we really need it
if(on %in% c('years','quarters','months','weeks','days'))
#posixltindex <- as.POSIXlt(structure( .index(x), class=c("POSIXt","POSIXct")))
posixltindex <- as.POSIXlt(.POSIXct(.index(x)),tz=indexTZ(x))
if(on == 'years') {
#as.integer(c(0, which(diff(as.POSIXlt(index(x))$year %/% k + 1) != 0), NR) )
as.integer(c(0, which(diff(posixltindex$year %/% k + 1) != 0), NR))
} else
if(on == 'quarters') {
xi <- (posixltindex$mon%/%3) + 1
as.integer(c(0,which(diff(xi) != 0),NR))
} else
if(on == 'months') {
#as.integer(c(0, which(diff(posixltindex$mon %/% k + 1) != 0), NR) )
# x[which(diff(as.POSIXlt(index(x))$mon) != 0)[seq(0,328,12)]]
ep <- .Call("endpoints", posixltindex$mon, 1L, 1L, addlast, PACKAGE='xts')
if(k > 1)
ep[seq(1,length(ep),k)]
else ep
} else
if(on == 'weeks') {
#as.integer(c(0, which(diff( (.index(x) + (3L * 86400L)) %/% 604800L %/% k + 1) != 0), NR) )
.Call("endpoints", .index(x)+3L*86400L, 604800L, k, addlast, PACKAGE='xts')
} else
if(on == 'days') {
#as.integer(c(0, which(diff(.index(x) %/% 86400L %/% k + 1) != 0), NR))
#as.integer(c(0, which(diff(posixltindex$yday %/% k + 1) != 0), NR))
.Call("endpoints", posixltindex$yday, 1L, k, addlast, PACKAGE='xts')
} else
# non-date slicing should be indifferent to TZ and DST, so use math instead
if(on == 'hours') {
#c(0, which(diff(as.POSIXlt(index(x))$hour %/% k + 1) != 0), NR)
#as.integer(c(0, which(diff(.index(x) %/% 3600L %/% k + 1) != 0), NR))
#as.integer(c(0, which(diff(posixltindex$hour %/% k + 1) != 0), NR))
.Call("endpoints", .index(x), 3600L, k, addlast, PACKAGE='xts')
} else
if(on == 'minutes' || on == 'mins') {
#c(0, which(diff(as.POSIXlt(index(x))$min %/% k + 1) != 0), NR)
#as.integer(c(0, which(diff(.index(x) %/% 60L %/% k + 1) != 0), NR))
#as.integer(c(0, which(diff(posixltindex$min %/% k + 1) != 0), NR))
.Call("endpoints", .index(x), 60L, k, addlast, PACKAGE='xts')
} else
if(on == 'seconds' || on == 'secs') {
#c(0, which(diff(as.POSIXlt(index(x))$sec %/% k + 1) != 0), NR)
#as.integer(c(0, which(diff(.index(x) %/% k + 1) != 0), NR))
.Call("endpoints", .index(x), 1L, k, addlast, PACKAGE='xts')
} else
if(on == 'milliseconds' || on == 'ms') {
#as.integer(c(0, which(diff(.index(x)%/%.001%/%k + 1) != 0), NR))
.Call("endpoints", .index(x)%/%.001, 1L, k, addlast, PACKAGE='xts')
} else
if(on == 'microseconds' || on == 'us') {
#as.integer(c(0, which(diff(.index(x)%/%.000001%/%k + 1) != 0), NR))
.Call("endpoints", .index(x)%/%.000001, 1L, k, addlast, PACKAGE='xts')
} else {
stop('unsupported "on" argument')
}
}
`startof` <-
function(x,by='months', k=1) {
ep <- endpoints(x,on=by, k=k)
(ep+1)[-length(ep)]
}
`endof` <-
function(x,by='months', k=1) {
endpoints(x,on=by, k=k)[-1]
}
`firstof` <-
function(year=1970,month=1,day=1,hour=0,min=0,sec=0,tz="") {
ISOdatetime(year,month,day,hour,min,sec,tz)
}
lastof <-
function (year = 1970,
month = 12,
day = 31,
hour = 23,
min = 59,
sec = 59,
subsec=.99999, tz = "")
{
if(!missing(sec) && sec %% 1 != 0)
subsec <- 0
sec <- ifelse(year < 1970, sec, sec+subsec) # <1970 asPOSIXct bug workaround
#sec <- sec + subsec
mon.lengths <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31,
30, 31)
if (missing(day)) {
day <- ifelse(month %in% 2, ifelse(((year%%4 %in% 0 &
!year%%100 %in% 0) | (year%%400 %in% 0)), 29, 28),
mon.lengths[month])
}
if (length(c(year, month, day, hour, min, sec)) == 6 && c(year,
month, day, hour, min, sec) == c(1969, 12, 31, 23, 59,
59) && Sys.getenv("TZ") %in% c("", "GMT", "UTC"))
sec <- sec-1
ISOdatetime(year, month, day, hour, min, sec, tz)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.